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     # Cursor Up.
 108     proc _csi_A {args} {
 109         variable _cur_y
 110         set arg [_default [lindex $args 0] 1]
 111         set _cur_y [expr {max ($_cur_y - $arg, 0)}]
 112     }
 113
 114     # Cursor Down.
 115     proc _csi_B {args} {
 116         variable _cur_y
 117         variable _rows
 118         set arg [_default [lindex $args 0] 1]
 119         set _cur_y [expr {min ($_cur_y + $arg, $_rows)}]
 120     }
 121
 122     # Cursor Forward.
 123     proc _csi_C {args} {
 124         variable _cur_x
 125         variable _cols
 126         set arg [_default [lindex $args 0] 1]
 127         set _cur_x [expr {min ($_cur_x + $arg, $_cols)}]
 128     }
 129
 130     # Cursor Back.
 131     proc _csi_D {args} {
 132         variable _cur_x
 133         set arg [_default [lindex $args 0] 1]
 134         set _cur_x [expr {max ($_cur_x - $arg, 0)}]
 135     }
 136
 137     # Cursor Next Line.
 138     proc _csi_E {args} {
 139         variable _cur_x
 140         variable _cur_y
 141         variable _rows
 142         set arg [_default [lindex $args 0] 1]
 143         set _cur_x 0
 144         set _cur_y [expr {min ($_cur_y + $arg, $_rows)}]
 145     }
 146
 147     # Cursor Previous Line.
 148     proc _csi_F {args} {
 149         variable _cur_x
 150         variable _cur_y
 151         variable _rows
 152         set arg [_default [lindex $args 0] 1]
 153         set _cur_x 0
 154         set _cur_y [expr {max ($_cur_y - $arg, 0)}]
 155     }
 156
 157     # Cursor Horizontal Absolute.
 158     proc _csi_G {args} {
 159         variable _cur_x
 160         variable _cols
 161         set arg [_default [lindex $args 0] 1]
 162         set _cur_x [expr {min ($arg - 1, $_cols)}]
 163     }
 164
 165     # Move cursor (don't know the official name of this one).
 166     proc _csi_H {args} {
 167         variable _cur_x
 168         variable _cur_y
 169         set _cur_y [expr {[_default [lindex $args 0] 1] - 1}]
 170         set _cur_x [expr {[_default [lindex $args 1] 1] - 1}]
 171     }
 172
 173     # Cursor Forward Tabulation.
 174     proc _csi_I {args} {
 175         set n [_default [lindex $args 0] 1]
 176         variable _cur_x
 177         variable _cols
 178         incr _cur_x [expr {$n * 8 - $_cur_x % 8}]
 179         if {$_cur_x >= $_cols} {
 180             set _cur_x [expr {$_cols - 1}]
 181         }
 182     }
 183
 184     # Erase.
 185     proc _csi_J {args} {
 186         variable _cur_x
 187         variable _cur_y
 188         variable _rows
 189         variable _cols
 190         set arg [_default [lindex $args 0] 0]
 191         if {$arg == 0} {
 192             _clear_in_line $_cur_x $_cols $_cur_y
 193             _clear_lines [expr {$_cur_y + 1}] $_rows
 194         } elseif {$arg == 1} {
 195             _clear_lines 0 [expr {$_cur_y - 1}]
 196             _clear_in_line 0 $_cur_x $_cur_y
 197         } elseif {$arg == 2} {
 198             _clear_lines 0 $_rows
 199         }
 200     }
 201
 202     # Erase Line.
 203     proc _csi_K {args} {
 204         variable _cur_x
 205         variable _cur_y
 206         variable _cols
 207         set arg [_default [lindex $args 0] 0]
 208         if {$arg == 0} {
 209             # From cursor to end.
 210             _clear_in_line $_cur_x $_cols $_cur_y
 211         } elseif {$arg == 1} {
 212             _clear_in_line 0 $_cur_x $_cur_y
 213         } elseif {$arg == 2} {
 214             _clear_in_line 0 $_cols $_cur_y
 215         }
 216     }
 217
 218     # Delete lines.
 219     proc _csi_M {args} {
 220         variable _cur_y
 221         variable _rows
 222         variable _cols
 223         variable _chars
 224         set count [_default [lindex $args 0] 1]
 225         set y $_cur_y
 226         set next_y [expr {$y + 1}]
 227         while {$count > 0 && $next_y < $_rows} {
 228             for {set x 0} {$x < $_cols} {incr x} {
 229                 set _chars($x,$y) $_chars($x,$next_y)
 230             }
 231             incr y
 232             incr next_y
 233             incr count -1
 234         }
 235         _clear_lines $next_y $_rows
 236     }
 237
 238     # Erase chars.
 239     proc _csi_X {args} {
 240         set n [_default [lindex $args 0] 1]
 241         _insert [string repeat " " $n]
 242     }
 243
 244     # Repeat.
 245     proc _csi_b {args} {
 246         variable _last_char
 247         set n [_default [lindex $args 0] 1]
 248         _insert [string repeat $_last_char $n]
 249     }
 250
 251     # Line Position Absolute.
 252     proc _csi_d {args} {
 253         variable _cur_y
 254         set _cur_y [expr {[_default [lindex $args 0] 1] - 1}]
 255     }
 256
 257     # Select Graphic Rendition.
 258     proc _csi_m {args} {
 259         variable _attrs
 260         foreach item $args {
 261             switch -exact -- $item {
 262                 "" - 0 {
 263                     set _attrs(intensity) normal
 264                     set _attrs(fg) default
 265                     set _attrs(bg) default
 266                     set _attrs(underline) 0
 267                     set _attrs(reverse) 0
 268                 }
 269                 1 {
 270                     set _attrs(intensity) bold
 271                 }
 272                 2 {
 273                     set _attrs(intensity) dim
 274                 }
 275                 4 {
 276                     set _attrs(underline) 1
 277                 }
 278                 7 {
 279                     set _attrs(reverse) 1
 280                 }
 281                 22 {
 282                     set _attrs(intensity) normal
 283                 }
 284                 24 {
 285                     set _attrs(underline) 0
 286                 }
 287                 27 {
 288                     set _attrs(reverse) 1
 289                 }
 290                 30 - 31 - 32 - 33 - 34 - 35 - 36 - 37 {
 291                     set _attrs(fg) $item
 292                 }
 293                 39 {
 294                     set _attrs(fg) default
 295                 }
 296                 40 - 41 - 42 - 43 - 44 - 45 - 46 - 47 {
 297                     set _attrs(bg) $item
 298                 }
 299                 49 {
 300                     set _attrs(bg) default
 301                 }
 302             }
 303         }
 304     }
 305
 306     # Insert string at the cursor location.
 307     proc _insert {str} {
 308         verbose "INSERT <<$str>>"
 309         variable _cur_x
 310         variable _cur_y
 311         variable _rows
 312         variable _cols
 313         variable _attrs
 314         variable _chars
 315         set lattr [array get _attrs]
 316         foreach char [split $str {}] {
 317             set _chars($_cur_x,$_cur_y) [list $char $lattr]
 318             incr _cur_x
 319             if {$_cur_x >= $_cols} {
 320                 set _cur_x 0
 321                 incr _cur_y
 322                 if {$_cur_y >= $_rows} {
 323                     error "FIXME scroll"
 324                 }
 325             }
 326         }
 327     }
 328
 329     # Initialize.
 330     proc _setup {rows cols} {
 331         global stty_init
 332         set stty_init "rows $rows columns $cols"
 333
 334         variable _rows
 335         variable _cols
 336         variable _cur_x
 337         variable _cur_y
 338         variable _attrs
 339
 340         set _rows $rows
 341         set _cols $cols
 342         set _cur_x 0
 343         set _cur_y 0
 344         array set _attrs {
 345             intensity normal
 346             fg default
 347             bg default
 348             underline 0
 349             reverse 0
 350         }
 351
 352         _clear_lines 0 $_rows
 353     }
 354
 355     # Accept some output from gdb and update the screen.
 356     proc _accept {} {
 357         global expect_out
 358         gdb_expect {
 359             -re "^\[\x07\x08\x0a\x0d\]" {
 360                 scan $expect_out(0,string) %c val
 361                 set hexval [format "%02x" $val]
 362                 verbose "+++ _ctl_0x${hexval}"
 363                 _ctl_0x${hexval}
 364                 exp_continue
 365             }
 366             -re "^\x1b(\[0-9a-zA-Z\])" {
 367                 verbose "+++ unsupported escape"
 368                 error "unsupported escape"
 369             }
 370             -re "^\x1b\\\[(\[0-9;\]*)(\[0-9a-zA-Z@\])" {
 371                 set cmd $expect_out(2,string)
 372                 set params [split $expect_out(1,string) ";"]
 373                 verbose "+++ _csi_$cmd <<<$expect_out(1,string)>>>"
 374                 eval _csi_$cmd $params
 375                 exp_continue
 376             }
 377             -re "^\[^\x07\x08\x0a\x0d\x1b\]+" {
 378                 _insert $expect_out(0,string)
 379                 variable _last_char
 380                 set _last_char [string index $expect_out(0,string) end]
 381                 # If the prompt was just inserted, return.
 382                 variable _cur_x
 383                 variable _cur_y
 384                 global gdb_prompt
 385                 set prev [get_line $_cur_y $_cur_x]
 386                 if {![regexp -- "$gdb_prompt \$" $prev]} {
 387                     exp_continue
 388                 }
 389             }
 390         }
 391     }
 392
 393     # Like ::clean_restart, but ensures that gdb starts in an
 394     # environment where the TUI can work.  ROWS and COLS are the size
 395     # of the terminal.  EXECUTABLE, if given, is passed to
 396     # clean_restart.
 397     proc clean_restart {rows cols {executable {}}} {
 398         global env stty_init
 399         save_vars {env(TERM) stty_init} {
 400             setenv TERM ansi
 401             _setup $rows $cols
 402             if {$executable == ""} {
 403                 ::clean_restart
 404             } else {
 405                 ::clean_restart $executable
 406             }
 407         }
 408     }
 409
 410     # Start the TUI.  Returns 1 on success, 0 if TUI tests should be
 411     # skipped.
 412     proc enter_tui {} {
 413         if {[skip_tui_tests]} {
 414             return 0
 415         }
 416
 417         gdb_test_no_output "set tui border-kind ascii"
 418         command "tui enable"
 419         return 1
 420     }
 421
 422     # Send the command CMD to gdb, then wait for a gdb prompt to be
 423     # seen in the TUI.  CMD should not end with a newline -- that will
 424     # be supplied by this function.
 425     proc command {cmd} {
 426         send_gdb "$cmd\n"
 427         _accept
 428     }
 429
 430     # Return the text of screen line N, without attributes.  Lines are
 431     # 0-based.  If C is given, stop before column C.  Columns are also
 432     # zero-based.
 433     proc get_line {n {c ""}} {
 434         set result ""
 435         variable _cols
 436         variable _chars
 437         set c [_default $c $_cols]
 438         set x 0
 439         while {$x < $c} {
 440             append result [lindex $_chars($x,$n) 0]
 441             incr x
 442         }
 443         return $result
 444     }
 445
 446     # Get just the character at (X, Y).
 447     proc get_char {x y} {
 448         variable _chars
 449         return [lindex $_chars($x,$y) 0]
 450     }
 451
 452     # Get the entire screen as a string.
 453     proc get_all_lines {} {
 454         variable _rows
 455         variable _cols
 456         variable _chars
 457
 458         set result ""
 459         for {set y 0} {$y < $_rows} {incr y} {
 460             for {set x 0} {$x < $_cols} {incr x} {
 461                 append result [lindex $_chars($x,$y) 0]
 462             }
 463             append result "\n"
 464         }
 465
 466         return $result
 467     }
 468
 469     # Get the text just before the cursor.
 470     proc get_current_line {} {
 471         variable _cur_x
 472         variable _cur_y
 473         return [get_line $_cur_y $_cur_x]
 474     }
 475
 476     # Helper function for check_box.  Returns empty string if the box
 477     # is found, description of why not otherwise.
 478     proc _check_box {x y width height} {
 479         set x2 [expr {$x + $width - 1}]
 480         set y2 [expr {$y + $height - 1}]
 481
 482         if {[get_char $x $y] != "+"} {
 483             return "ul corner"
 484         }
 485         if {[get_char $x $y2] != "+"} {
 486             return "ll corner"
 487         }
 488         if {[get_char $x2 $y] != "+"} {
 489             return "ur corner"
 490         }
 491         if {[get_char $x2 $y2] != "+"} {
 492             return "lr corner"
 493         }
 494
 495         for {set i [expr {$x + 1}]} {$i < $x2 - 1} {incr i} {
 496             # Note we do not check the top border of the box, because
 497             # it will contain a title.
 498             if {[get_char $i $y2] != "-"} {
 499                 return "bottom border $i"
 500             }
 501         }
 502         for {set i [expr {$y + 1}]} {$i < $y2 - 1} {incr i} {
 503             if {[get_char $x $i] != "|"} {
 504                 return "left side $i"
 505             }
 506             if {[get_char $x2 $i] != "|"} {
 507                 return "right side $i"
 508             }
 509         }
 510
 511         return ""
 512     }
 513
 514     # Check for a box at the given coordinates.
 515     proc check_box {test_name x y width height} {
 516         set why [_check_box $x $y $width $height]
 517         if {$why == ""} {
 518             pass $test_name
 519         } else {
 520             dump_screen
 521             fail "$test_name ($why)"
 522         }
 523     }
 524
 525     # Check whether the text contents of the terminal match the
 526     # regular expression.  Note that text styling is not considered.
 527     proc check_contents {test_name regexp} {
 528         set contents [get_all_lines]
 529         if {![gdb_assert {[regexp -- $regexp $contents]} $test_name]} {
 530             dump_screen
 531         }
 532     }
 533
 534     # A debugging function to dump the current screen, with line
 535     # numbers.
 536     proc dump_screen {} {
 537         variable _rows
 538         verbose "Screen Dump:"
 539         for {set y 0} {$y < $_rows} {incr y} {
 540             set fmt [format %5d $y]
 541             verbose "$fmt [get_line $y]"
 542         }
 543     }
 544
 545     # Resize the terminal.
 546     proc resize {rows cols} {
 547         variable _chars
 548         variable _rows
 549         variable _cols
 550
 551         set old_rows [expr {min ($_rows, $rows)}]
 552         set old_cols [expr {min ($_cols, $cols)}]
 553
 554         # Copy locally.
 555         array set local_chars [array get _chars]
 556         unset _chars
 557
 558         set _rows $rows
 559         set _cols $cols
 560         _clear_lines 0 $_rows
 561
 562         for {set x 0} {$x < $old_cols} {incr x} {
 563             for {set y 0} {$y < $old_rows} {incr y} {
 564                 set _chars($x,$y) $local_chars($x,$y)
 565             }
 566         }
 567
 568         global gdb_spawn_name
 569         # Somehow the number of columns transmitted to gdb is one less
 570         # than what we request from expect.  We hide this weird
 571         # details from the caller.
 572         stty rows $_rows columns [expr {$_cols + 1}] \
 573             < $gdb_spawn_name
 574         _accept
 575     }
 576 }