gdb/testsuite/lib/tuiterm.exp

   1 # Copyright 2019 Free Software Foundation, Inc.
   2
   3 # This program is free software; you can redistribute it and/or modify
   4 # it under the terms of the GNU General Public License as published by
   5 # the Free Software Foundation; either version 3 of the License, or
   6 # (at your option) any later version.
   7 #
   8 # This program is distributed in the hope that it will be useful,
   9 # but WITHOUT ANY WARRANTY; without even the implied warranty of
  10 # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  11 # GNU General Public License for more details.
  12 #
  13 # You should have received a copy of the GNU General Public License
  14 # along with this program.  If not, see <http://www.gnu.org/licenses/>.
  15
  16 # An ANSI terminal emulator for expect.
  17
  18 # The expect "spawn" function puts the tty name into the spawn_out
  19 # array; but dejagnu doesn't export this globally.  So, we have to
  20 # wrap spawn with our own function, so that we can capture this value.
  21 # The value is later used in calls to stty.
  22 rename spawn builtin_spawn
  23 proc spawn {args} {
  24     set result [uplevel builtin_spawn $args]
  25     global gdb_spawn_name
  26     upvar spawn_out spawn_out
  27     set gdb_spawn_name $spawn_out(slave,name)
  28     return $result
  29 }
  30
  31 namespace eval Term {
  32     variable _rows
  33     variable _cols
  34     variable _chars
  35
  36     variable _cur_x
  37     variable _cur_y
  38
  39     variable _attrs
  40
  41     variable _last_char
  42
  43     # If ARG is empty, return DEF: otherwise ARG.  This is useful for
  44     # defaulting arguments in CSIs.
  45     proc _default {arg def} {
  46         if {$arg == ""} {
  47             return $def
  48         }
  49         return $arg
  50     }
  51
  52     # Erase in the line Y from SX to just before EX.
  53     proc _clear_in_line {sx ex y} {
  54         variable _attrs
  55         variable _chars
  56         set lattr [array get _attrs]
  57         while {$sx < $ex} {
  58             set _chars($sx,$y) [list " " $lattr]
  59             incr sx
  60         }
  61     }
  62
  63     # Erase the lines from SY to just before EY.
  64     proc _clear_lines {sy ey} {
  65         variable _cols
  66         while {$sy < $ey} {
  67             _clear_in_line 0 $_cols $sy
  68             incr sy
  69         }
  70     }
  71
  72     # Beep.
  73     proc _ctl_0x07 {} {
  74     }
  75
  76     # Backspace.
  77     proc _ctl_0x08 {} {
  78         variable _cur_x
  79         incr _cur_x -1
  80         if {$_cur_x < 0} {
  81             variable _cur_y
  82             variable _cols
  83             set _cur_x [expr {$_cols - 1}]
  84             incr _cur_y -1
  85             if {$_cur_y < 0} {
  86                 set _cur_y 0
  87             }
  88         }
  89     }
  90
  91     # Linefeed.
  92     proc _ctl_0x0a {} {
  93         variable _cur_y
  94         variable _rows
  95         incr _cur_y 1
  96         if {$_cur_y >= $_rows} {
  97             error "FIXME scroll"
  98         }
  99     }
 100
 101     # Carriage return.
 102     proc _ctl_0x0d {} {
 103         variable _cur_x
 104         set _cur_x 0
 105     }
 106
 107     # Make room for characters.
 108     proc _csi_@ {args} {
 109         set n [_default [lindex $args 0] 1]
 110         variable _cur_x
 111         variable _cur_y
 112         variable _chars
 113         set in_x $_cur_x
 114         set out_x [expr {$_cur_x + $n}]
 115         for {set i 0} {$i < $n} {incr i} {
 116             set _chars($out_x,$_cur_y) $_chars($in_x,$_cur_y)
 117             incr in_x
 118             incr out_x
 119         }
 120     }
 121
 122     # Cursor Up.
 123     proc _csi_A {args} {
 124         variable _cur_y
 125         set arg [_default [lindex $args 0] 1]
 126         set _cur_y [expr {max ($_cur_y - $arg, 0)}]
 127     }
 128
 129     # Cursor Down.
 130     proc _csi_B {args} {
 131         variable _cur_y
 132         variable _rows
 133         set arg [_default [lindex $args 0] 1]
 134         set _cur_y [expr {min ($_cur_y + $arg, $_rows)}]
 135     }
 136
 137     # Cursor Forward.
 138     proc _csi_C {args} {
 139         variable _cur_x
 140         variable _cols
 141         set arg [_default [lindex $args 0] 1]
 142         set _cur_x [expr {min ($_cur_x + $arg, $_cols)}]
 143     }
 144
 145     # Cursor Back.
 146     proc _csi_D {args} {
 147         variable _cur_x
 148         set arg [_default [lindex $args 0] 1]
 149         set _cur_x [expr {max ($_cur_x - $arg, 0)}]
 150     }
 151
 152     # Cursor Next Line.
 153     proc _csi_E {args} {
 154         variable _cur_x
 155         variable _cur_y
 156         variable _rows
 157         set arg [_default [lindex $args 0] 1]
 158         set _cur_x 0
 159         set _cur_y [expr {min ($_cur_y + $arg, $_rows)}]
 160     }
 161
 162     # Cursor Previous Line.
 163     proc _csi_F {args} {
 164         variable _cur_x
 165         variable _cur_y
 166         variable _rows
 167         set arg [_default [lindex $args 0] 1]
 168         set _cur_x 0
 169         set _cur_y [expr {max ($_cur_y - $arg, 0)}]
 170     }
 171
 172     # Cursor Horizontal Absolute.
 173     proc _csi_G {args} {
 174         variable _cur_x
 175         variable _cols
 176         set arg [_default [lindex $args 0] 1]
 177         set _cur_x [expr {min ($arg - 1, $_cols)}]
 178     }
 179
 180     # Move cursor (don't know the official name of this one).
 181     proc _csi_H {args} {
 182         variable _cur_x
 183         variable _cur_y
 184         set _cur_y [expr {[_default [lindex $args 0] 1] - 1}]
 185         set _cur_x [expr {[_default [lindex $args 1] 1] - 1}]
 186     }
 187
 188     # Cursor Forward Tabulation.
 189     proc _csi_I {args} {
 190         set n [_default [lindex $args 0] 1]
 191         variable _cur_x
 192         variable _cols
 193         incr _cur_x [expr {$n * 8 - $_cur_x % 8}]
 194         if {$_cur_x >= $_cols} {
 195             set _cur_x [expr {$_cols - 1}]
 196         }
 197     }
 198
 199     # Erase.
 200     proc _csi_J {args} {
 201         variable _cur_x
 202         variable _cur_y
 203         variable _rows
 204         variable _cols
 205         set arg [_default [lindex $args 0] 0]
 206         if {$arg == 0} {
 207             _clear_in_line $_cur_x $_cols $_cur_y
 208             _clear_lines [expr {$_cur_y + 1}] $_rows
 209         } elseif {$arg == 1} {
 210             _clear_lines 0 [expr {$_cur_y - 1}]
 211             _clear_in_line 0 $_cur_x $_cur_y
 212         } elseif {$arg == 2} {
 213             _clear_lines 0 $_rows
 214         }
 215     }
 216
 217     # Erase Line.
 218     proc _csi_K {args} {
 219         variable _cur_x
 220         variable _cur_y
 221         variable _cols
 222         set arg [_default [lindex $args 0] 0]
 223         if {$arg == 0} {
 224             # From cursor to end.
 225             _clear_in_line $_cur_x $_cols $_cur_y
 226         } elseif {$arg == 1} {
 227             _clear_in_line 0 $_cur_x $_cur_y
 228         } elseif {$arg == 2} {
 229             _clear_in_line 0 $_cols $_cur_y
 230         }
 231     }
 232
 233     # Delete lines.
 234     proc _csi_M {args} {
 235         variable _cur_y
 236         variable _rows
 237         variable _cols
 238         variable _chars
 239         set count [_default [lindex $args 0] 1]
 240         set y $_cur_y
 241         set next_y [expr {$y + 1}]
 242         while {$count > 0 && $next_y < $_rows} {
 243             for {set x 0} {$x < $_cols} {incr x} {
 244                 set _chars($x,$y) $_chars($x,$next_y)
 245             }
 246             incr y
 247             incr next_y
 248             incr count -1
 249         }
 250         _clear_lines $next_y $_rows
 251     }
 252
 253     # Erase chars.
 254     proc _csi_X {args} {
 255         set n [_default [lindex $args 0] 1]
 256         # Erase characters but don't move cursor.
 257         variable _cur_x
 258         variable _cur_y
 259         variable _attrs
 260         variable _chars
 261         set lattr [array get _attrs]
 262         set x $_cur_x
 263         for {set i 0} {$i < $n} {incr i} {
 264             set _chars($x,$_cur_y) [list " " $lattr]
 265             incr x
 266         }
 267     }
 268
 269     # Repeat.
 270     proc _csi_b {args} {
 271         variable _last_char
 272         set n [_default [lindex $args 0] 1]
 273         _insert [string repeat $_last_char $n]
 274     }
 275
 276     # Line Position Absolute.
 277     proc _csi_d {args} {
 278         variable _cur_y
 279         set _cur_y [expr {[_default [lindex $args 0] 1] - 1}]
 280     }
 281
 282     # Select Graphic Rendition.
 283     proc _csi_m {args} {
 284         variable _attrs
 285         foreach item $args {
 286             switch -exact -- $item {
 287                 "" - 0 {
 288                     set _attrs(intensity) normal
 289                     set _attrs(fg) default
 290                     set _attrs(bg) default
 291                     set _attrs(underline) 0
 292                     set _attrs(reverse) 0
 293                 }
 294                 1 {
 295                     set _attrs(intensity) bold
 296                 }
 297                 2 {
 298                     set _attrs(intensity) dim
 299                 }
 300                 4 {
 301                     set _attrs(underline) 1
 302                 }
 303                 7 {
 304                     set _attrs(reverse) 1
 305                 }
 306                 22 {
 307                     set _attrs(intensity) normal
 308                 }
 309                 24 {
 310                     set _attrs(underline) 0
 311                 }
 312                 27 {
 313                     set _attrs(reverse) 1
 314                 }
 315                 30 - 31 - 32 - 33 - 34 - 35 - 36 - 37 {
 316                     set _attrs(fg) $item
 317                 }
 318                 39 {
 319                     set _attrs(fg) default
 320                 }
 321                 40 - 41 - 42 - 43 - 44 - 45 - 46 - 47 {
 322                     set _attrs(bg) $item
 323                 }
 324                 49 {
 325                     set _attrs(bg) default
 326                 }
 327             }
 328         }
 329     }
 330
 331     # Insert string at the cursor location.
 332     proc _insert {str} {
 333         verbose "INSERT <<$str>>"
 334         variable _cur_x
 335         variable _cur_y
 336         variable _rows
 337         variable _cols
 338         variable _attrs
 339         variable _chars
 340         set lattr [array get _attrs]
 341         foreach char [split $str {}] {
 342             set _chars($_cur_x,$_cur_y) [list $char $lattr]
 343             incr _cur_x
 344             if {$_cur_x >= $_cols} {
 345                 set _cur_x 0
 346                 incr _cur_y
 347                 if {$_cur_y >= $_rows} {
 348                     error "FIXME scroll"
 349                 }
 350             }
 351         }
 352     }
 353
 354     # Initialize.
 355     proc _setup {rows cols} {
 356         global stty_init
 357         set stty_init "rows $rows columns $cols"
 358
 359         variable _rows
 360         variable _cols
 361         variable _cur_x
 362         variable _cur_y
 363         variable _attrs
 364
 365         set _rows $rows
 366         set _cols $cols
 367         set _cur_x 0
 368         set _cur_y 0
 369         array set _attrs {
 370             intensity normal
 371             fg default
 372             bg default
 373             underline 0
 374             reverse 0
 375         }
 376
 377         _clear_lines 0 $_rows
 378     }
 379
 380     # Accept some output from gdb and update the screen.
 381     proc _accept {} {
 382         global expect_out
 383         gdb_expect {
 384             -re "^\[\x07\x08\x0a\x0d\]" {
 385                 scan $expect_out(0,string) %c val
 386                 set hexval [format "%02x" $val]
 387                 verbose "+++ _ctl_0x${hexval}"
 388                 _ctl_0x${hexval}
 389                 exp_continue
 390             }
 391             -re "^\x1b(\[0-9a-zA-Z\])" {
 392                 verbose "+++ unsupported escape"
 393                 error "unsupported escape"
 394             }
 395             -re "^\x1b\\\[(\[0-9;\]*)(\[0-9a-zA-Z@\])" {
 396                 set cmd $expect_out(2,string)
 397                 set params [split $expect_out(1,string) ";"]
 398                 verbose "+++ _csi_$cmd <<<$expect_out(1,string)>>>"
 399                 eval _csi_$cmd $params
 400                 exp_continue
 401             }
 402             -re "^\[^\x07\x08\x0a\x0d\x1b\]+" {
 403                 _insert $expect_out(0,string)
 404                 variable _last_char
 405                 set _last_char [string index $expect_out(0,string) end]
 406                 # If the prompt was just inserted, return.
 407                 variable _cur_x
 408                 variable _cur_y
 409                 global gdb_prompt
 410                 set prev [get_line $_cur_y $_cur_x]
 411                 if {![regexp -- "$gdb_prompt \$" $prev]} {
 412                     exp_continue
 413                 }
 414             }
 415         }
 416     }
 417
 418     # Like ::clean_restart, but ensures that gdb starts in an
 419     # environment where the TUI can work.  ROWS and COLS are the size
 420     # of the terminal.  EXECUTABLE, if given, is passed to
 421     # clean_restart.
 422     proc clean_restart {rows cols {executable {}}} {
 423         global env stty_init
 424         save_vars {env(TERM) stty_init} {
 425             setenv TERM ansi
 426             _setup $rows $cols
 427             if {$executable == ""} {
 428                 ::clean_restart
 429             } else {
 430                 ::clean_restart $executable
 431             }
 432         }
 433     }
 434
 435     # Start the TUI.  Returns 1 on success, 0 if TUI tests should be
 436     # skipped.
 437     proc enter_tui {} {
 438         if {[skip_tui_tests]} {
 439             return 0
 440         }
 441
 442         gdb_test_no_output "set tui border-kind ascii"
 443         command "tui enable"
 444         return 1
 445     }
 446
 447     # Send the command CMD to gdb, then wait for a gdb prompt to be
 448     # seen in the TUI.  CMD should not end with a newline -- that will
 449     # be supplied by this function.
 450     proc command {cmd} {
 451         send_gdb "$cmd\n"
 452         _accept
 453     }
 454
 455     # Return the text of screen line N, without attributes.  Lines are
 456     # 0-based.  If C is given, stop before column C.  Columns are also
 457     # zero-based.
 458     proc get_line {n {c ""}} {
 459         set result ""
 460         variable _cols
 461         variable _chars
 462         set c [_default $c $_cols]
 463         set x 0
 464         while {$x < $c} {
 465             append result [lindex $_chars($x,$n) 0]
 466             incr x
 467         }
 468         return $result
 469     }
 470
 471     # Get just the character at (X, Y).
 472     proc get_char {x y} {
 473         variable _chars
 474         return [lindex $_chars($x,$y) 0]
 475     }
 476
 477     # Get the entire screen as a string.
 478     proc get_all_lines {} {
 479         variable _rows
 480         variable _cols
 481         variable _chars
 482
 483         set result ""
 484         for {set y 0} {$y < $_rows} {incr y} {
 485             for {set x 0} {$x < $_cols} {incr x} {
 486                 append result [lindex $_chars($x,$y) 0]
 487             }
 488             append result "\n"
 489         }
 490
 491         return $result
 492     }
 493
 494     # Get the text just before the cursor.
 495     proc get_current_line {} {
 496         variable _cur_x
 497         variable _cur_y
 498         return [get_line $_cur_y $_cur_x]
 499     }
 500
 501     # Helper function for check_box.  Returns empty string if the box
 502     # is found, description of why not otherwise.
 503     proc _check_box {x y width height} {
 504         set x2 [expr {$x + $width - 1}]
 505         set y2 [expr {$y + $height - 1}]
 506
 507         if {[get_char $x $y] != "+"} {
 508             return "ul corner"
 509         }
 510         if {[get_char $x $y2] != "+"} {
 511             return "ll corner"
 512         }
 513         if {[get_char $x2 $y] != "+"} {
 514             return "ur corner"
 515         }
 516         if {[get_char $x2 $y2] != "+"} {
 517             return "lr corner"
 518         }
 519
 520         for {set i [expr {$x + 1}]} {$i < $x2 - 1} {incr i} {
 521             # Note we do not check the top border of the box, because
 522             # it will contain a title.
 523             if {[get_char $i $y2] != "-"} {
 524                 return "bottom border $i"
 525             }
 526         }
 527         for {set i [expr {$y + 1}]} {$i < $y2 - 1} {incr i} {
 528             if {[get_char $x $i] != "|"} {
 529                 return "left side $i"
 530             }
 531             if {[get_char $x2 $i] != "|"} {
 532                 return "right side $i"
 533             }
 534         }
 535
 536         return ""
 537     }
 538
 539     # Check for a box at the given coordinates.
 540     proc check_box {test_name x y width height} {
 541         set why [_check_box $x $y $width $height]
 542         if {$why == ""} {
 543             pass $test_name
 544         } else {
 545             dump_screen
 546             fail "$test_name ($why)"
 547         }
 548     }
 549
 550     # Check whether the text contents of the terminal match the
 551     # regular expression.  Note that text styling is not considered.
 552     proc check_contents {test_name regexp} {
 553         set contents [get_all_lines]
 554         if {![gdb_assert {[regexp -- $regexp $contents]} $test_name]} {
 555             dump_screen
 556         }
 557     }
 558
 559     # A debugging function to dump the current screen, with line
 560     # numbers.
 561     proc dump_screen {} {
 562         variable _rows
 563         verbose "Screen Dump:"
 564         for {set y 0} {$y < $_rows} {incr y} {
 565             set fmt [format %5d $y]
 566             verbose "$fmt [get_line $y]"
 567         }
 568     }
 569
 570     # Resize the terminal.
 571     proc resize {rows cols} {
 572         variable _chars
 573         variable _rows
 574         variable _cols
 575
 576         set old_rows [expr {min ($_rows, $rows)}]
 577         set old_cols [expr {min ($_cols, $cols)}]
 578
 579         # Copy locally.
 580         array set local_chars [array get _chars]
 581         unset _chars
 582
 583         set _rows $rows
 584         set _cols $cols
 585         _clear_lines 0 $_rows
 586
 587         for {set x 0} {$x < $old_cols} {incr x} {
 588             for {set y 0} {$y < $old_rows} {incr y} {
 589                 set _chars($x,$y) $local_chars($x,$y)
 590             }
 591         }
 592
 593         global gdb_spawn_name
 594         # Somehow the number of columns transmitted to gdb is one less
 595         # than what we request from expect.  We hide this weird
 596         # details from the caller.
 597         stty rows $_rows columns [expr {$_cols + 1}] \
 598             < $gdb_spawn_name
 599         _accept
 600     }
 601 }