gdb/testsuite/lib/tuiterm.exp

   1 # Copyright 2019-2021 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 proc tuiterm_spawn { args } {
  23     set result [uplevel builtin_spawn $args]
  24     global gdb_spawn_name
  25     upvar spawn_out spawn_out
  26     if { [info exists spawn_out] } {
  27         set gdb_spawn_name $spawn_out(slave,name)
  28     } else {
  29         unset gdb_spawn_name
  30     }
  31     return $result
  32 }
  33
  34 # Initialize tuiterm.exp environment.
  35 proc tuiterm_env_init { } {
  36     # Override spawn with tui_spawn.
  37     rename spawn builtin_spawn
  38     rename tuiterm_spawn spawn
  39 }
  40
  41 # Finalize tuiterm.exp environment.
  42 proc tuiterm_env_finish { } {
  43     # Restore spawn.
  44     rename spawn tuiterm_spawn
  45     rename builtin_spawn spawn
  46 }
  47
  48 namespace eval Term {
  49     # Size of the terminal.
  50     variable _rows
  51     variable _cols
  52
  53     # Buffer / contents of the terminal.
  54     variable _chars
  55
  56     # Position of the cursor.
  57     variable _cur_col
  58     variable _cur_row
  59
  60     variable _attrs
  61
  62     variable _last_char
  63
  64     variable _resize_count
  65
  66     proc _log { what } {
  67         verbose -log "+++ $what"
  68     }
  69
  70     # Call BODY, then log WHAT along with the original and new cursor position.
  71     proc _log_cur { what body } {
  72         variable _cur_row
  73         variable _cur_col
  74
  75         set orig_cur_row $_cur_row
  76         set orig_cur_col $_cur_col
  77
  78         uplevel $body
  79
  80         _log "$what, cursor: ($orig_cur_row, $orig_cur_col) -> ($_cur_row, $_cur_col)"
  81     }
  82
  83     # If ARG is empty, return DEF: otherwise ARG.  This is useful for
  84     # defaulting arguments in CSIs.
  85     proc _default {arg def} {
  86         if {$arg == ""} {
  87             return $def
  88         }
  89         return $arg
  90     }
  91
  92     # Erase in the line Y from SX to just before EX.
  93     proc _clear_in_line {sx ex y} {
  94         variable _attrs
  95         variable _chars
  96         set lattr [array get _attrs]
  97         while {$sx < $ex} {
  98             set _chars($sx,$y) [list " " $lattr]
  99             incr sx
 100         }
 101     }
 102
 103     # Erase the lines from SY to just before EY.
 104     proc _clear_lines {sy ey} {
 105         variable _cols
 106         while {$sy < $ey} {
 107             _clear_in_line 0 $_cols $sy
 108             incr sy
 109         }
 110     }
 111
 112     # Beep.
 113     proc _ctl_0x07 {} {
 114     }
 115
 116     # Backspace.
 117     proc _ctl_0x08 {} {
 118         _log_cur "Backspace" {
 119             variable _cur_col
 120
 121             incr _cur_col -1
 122             if {$_cur_col < 0} {
 123                 variable _cur_row
 124                 variable _cols
 125
 126                 set _cur_col [expr {$_cols - 1}]
 127                 incr _cur_row -1
 128                 if {$_cur_row < 0} {
 129                     set _cur_row 0
 130                 }
 131             }
 132         }
 133     }
 134
 135     # Linefeed.
 136     proc _ctl_0x0a {} {
 137         _log_cur "Line feed" {
 138             variable _cur_row
 139             variable _rows
 140
 141             incr _cur_row 1
 142             if {$_cur_row >= $_rows} {
 143                 error "FIXME scroll"
 144             }
 145         }
 146     }
 147
 148     # Carriage return.
 149     proc _ctl_0x0d {} {
 150         _log_cur "Carriage return" {
 151             variable _cur_col
 152
 153             set _cur_col 0
 154         }
 155     }
 156
 157     # Insert Character.
 158     #
 159     # https://vt100.net/docs/vt510-rm/ICH.html
 160     proc _csi_@ {args} {
 161         set n [_default [lindex $args 0] 1]
 162
 163         _log_cur "Insert Character ($n)" {
 164             variable _cur_col
 165             variable _cur_row
 166             variable _chars
 167
 168             set in_x $_cur_col
 169             set out_x [expr {$_cur_col + $n}]
 170             for {set i 0} {$i < $n} {incr i} {
 171                 set _chars($out_x,$_cur_row) $_chars($in_x,$_cur_row)
 172                 incr in_x
 173                 incr out_x
 174             }
 175         }
 176     }
 177
 178     # Cursor Up.
 179     #
 180     # https://vt100.net/docs/vt510-rm/CUU.html
 181     proc _csi_A {args} {
 182         set arg [_default [lindex $args 0] 1]
 183
 184         _log_cur "Cursor Up ($arg)" {
 185             variable _cur_row
 186
 187             set _cur_row [expr {max ($_cur_row - $arg, 0)}]
 188         }
 189     }
 190
 191     # Cursor Down.
 192     #
 193     # https://vt100.net/docs/vt510-rm/CUD.html
 194     proc _csi_B {args} {
 195         set arg [_default [lindex $args 0] 1]
 196
 197         _log_cur "Cursor Down ($arg)" {
 198             variable _cur_row
 199             variable _rows
 200
 201             set _cur_row [expr {min ($_cur_row + $arg, $_rows)}]
 202         }
 203     }
 204
 205     # Cursor Forward.
 206     #
 207     # https://vt100.net/docs/vt510-rm/CUF.html
 208     proc _csi_C {args} {
 209         set arg [_default [lindex $args 0] 1]
 210
 211         _log_cur "Cursor Forward ($arg)" {
 212             variable _cur_col
 213             variable _cols
 214
 215             set _cur_col [expr {min ($_cur_col + $arg, $_cols)}]
 216         }
 217     }
 218
 219     # Cursor Backward.
 220     #
 221     # https://vt100.net/docs/vt510-rm/CUB.html
 222     proc _csi_D {args} {
 223         set arg [_default [lindex $args 0] 1]
 224
 225         _log_cur "Cursor Backward ($arg)" {
 226             variable _cur_col
 227
 228             set _cur_col [expr {max ($_cur_col - $arg, 0)}]
 229         }
 230     }
 231
 232     # Cursor Next Line.
 233     #
 234     # https://vt100.net/docs/vt510-rm/CNL.html
 235     proc _csi_E {args} {
 236         set arg [_default [lindex $args 0] 1]
 237
 238         _log_cur "Cursor Next Line ($arg)" {
 239             variable _cur_col
 240             variable _cur_row
 241             variable _rows
 242
 243             set _cur_col 0
 244             set _cur_row [expr {min ($_cur_row + $arg, $_rows)}]
 245         }
 246     }
 247
 248     # Cursor Previous Line.
 249     #
 250     # https://vt100.net/docs/vt510-rm/CPL.html
 251     proc _csi_F {args} {
 252         set arg [_default [lindex $args 0] 1]
 253
 254         _log_cur "Cursor Previous Line ($arg)" {
 255             variable _cur_col
 256             variable _cur_row
 257             variable _rows
 258
 259             set _cur_col 0
 260             set _cur_row [expr {max ($_cur_row - $arg, 0)}]
 261         }
 262     }
 263
 264     # Cursor Horizontal Absolute.
 265     #
 266     # https://vt100.net/docs/vt510-rm/CHA.html
 267     proc _csi_G {args} {
 268         set arg [_default [lindex $args 0] 1]
 269
 270         _log_cur "Cursor Horizontal Absolute ($arg)" {
 271             variable _cur_col
 272             variable _cols
 273
 274             set _cur_col [expr {min ($arg - 1, $_cols)}]
 275         }
 276     }
 277
 278     # Cursor Position.
 279     #
 280     # https://vt100.net/docs/vt510-rm/CUP.html
 281     proc _csi_H {args} {
 282         set row [_default [lindex $args 0] 1]
 283         set col [_default [lindex $args 1] 1]
 284
 285         _log_cur "Cursor Position ($row, $col)" {
 286             variable _cur_col
 287             variable _cur_row
 288
 289             set _cur_row [expr {$row - 1}]
 290             set _cur_col [expr {$col - 1}]
 291         }
 292     }
 293
 294     # Cursor Horizontal Forward Tabulation.
 295     #
 296     # https://vt100.net/docs/vt510-rm/CHT.html
 297     proc _csi_I {args} {
 298         set n [_default [lindex $args 0] 1]
 299
 300         _log_cur "Cursor Horizontal Forward Tabulation ($n)" {
 301             variable _cur_col
 302             variable _cols
 303
 304             incr _cur_col [expr {$n * 8 - $_cur_col % 8}]
 305             if {$_cur_col >= $_cols} {
 306                 set _cur_col [expr {$_cols - 1}]
 307             }
 308         }
 309     }
 310
 311     # Erase in Display.
 312     #
 313     # https://vt100.net/docs/vt510-rm/ED.html
 314     proc _csi_J {args} {
 315         set arg [_default [lindex $args 0] 0]
 316
 317         _log_cur "Erase in Display ($arg)" {
 318             variable _cur_col
 319             variable _cur_row
 320             variable _rows
 321             variable _cols
 322
 323             if {$arg == 0} {
 324                 _clear_in_line $_cur_col $_cols $_cur_row
 325                 _clear_lines [expr {$_cur_row + 1}] $_rows
 326             } elseif {$arg == 1} {
 327                 _clear_lines 0 [expr {$_cur_row - 1}]
 328                 _clear_in_line 0 $_cur_col $_cur_row
 329             } elseif {$arg == 2} {
 330                 _clear_lines 0 $_rows
 331             }
 332         }
 333     }
 334
 335     # Erase in Line.
 336     #
 337     # https://vt100.net/docs/vt510-rm/EL.html
 338     proc _csi_K {args} {
 339         set arg [_default [lindex $args 0] 0]
 340
 341         _log_cur "Erase in Line ($arg)" {
 342             variable _cur_col
 343             variable _cur_row
 344             variable _cols
 345
 346             if {$arg == 0} {
 347                 # From cursor to end.
 348                 _clear_in_line $_cur_col $_cols $_cur_row
 349             } elseif {$arg == 1} {
 350                 _clear_in_line 0 $_cur_col $_cur_row
 351             } elseif {$arg == 2} {
 352                 _clear_in_line 0 $_cols $_cur_row
 353             }
 354         }
 355     }
 356
 357     # Delete line.
 358     #
 359     # https://vt100.net/docs/vt510-rm/DL.html
 360     proc _csi_M {args} {
 361         set count [_default [lindex $args 0] 1]
 362
 363         _log_cur "Delete line ($count)" {
 364             variable _cur_row
 365             variable _rows
 366             variable _cols
 367             variable _chars
 368
 369             set y $_cur_row
 370             set next_y [expr {$y + $count}]
 371             while {$next_y < $_rows} {
 372                 for {set x 0} {$x < $_cols} {incr x} {
 373                     set _chars($x,$y) $_chars($x,$next_y)
 374                 }
 375                 incr y
 376                 incr next_y
 377             }
 378             _clear_lines $y $_rows
 379         }
 380     }
 381
 382     # Erase chars.
 383     #
 384     # https://vt100.net/docs/vt510-rm/ECH.html
 385     proc _csi_X {args} {
 386         set n [_default [lindex $args 0] 1]
 387
 388         _log_cur "Erase chars ($n)" {
 389             # Erase characters but don't move cursor.
 390             variable _cur_col
 391             variable _cur_row
 392             variable _attrs
 393             variable _chars
 394
 395             set lattr [array get _attrs]
 396             set x $_cur_col
 397             for {set i 0} {$i < $n} {incr i} {
 398                 set _chars($x,$_cur_row) [list " " $lattr]
 399                 incr x
 400             }
 401         }
 402     }
 403
 404     # Cursor Backward Tabulation.
 405     #
 406     # https://vt100.net/docs/vt510-rm/CBT.html
 407     proc _csi_Z {args} {
 408         set n [_default [lindex $args 0] 1]
 409
 410         _log_cur "Cursor Backward Tabulation ($n)" {
 411             variable _cur_col
 412
 413             set _cur_col [expr {max (int (($_cur_col - 1) / 8) * 8 - ($n - 1) * 8, 0)}]
 414         }
 415     }
 416
 417     # Repeat.
 418     #
 419     # https://www.xfree86.org/current/ctlseqs.html (See `(REP)`)
 420     proc _csi_b {args} {
 421         set n [_default [lindex $args 0] 1]
 422
 423         _log_cur "Repeat ($n)" {
 424             variable _last_char
 425
 426             _insert [string repeat $_last_char $n]
 427         }
 428     }
 429
 430     # Vertical Line Position Absolute.
 431     #
 432     # https://vt100.net/docs/vt510-rm/VPA.html
 433     proc _csi_d {args} {
 434         set row [_default [lindex $args 0] 1]
 435
 436         _log_cur "Vertical Line Position Absolute ($row)" {
 437             variable _cur_row
 438
 439             set _cur_row [expr {$row - 1}]
 440         }
 441     }
 442
 443     # Select Graphic Rendition.
 444     #
 445     # https://vt100.net/docs/vt510-rm/SGR.html
 446     proc _csi_m {args} {
 447         _log_cur "Select Graphic Rendition ([join $args {, }])" {
 448           variable _attrs
 449
 450           foreach item $args {
 451               switch -exact -- $item {
 452                   "" - 0 {
 453                       set _attrs(intensity) normal
 454                       set _attrs(fg) default
 455                       set _attrs(bg) default
 456                       set _attrs(underline) 0
 457                       set _attrs(reverse) 0
 458                   }
 459                   1 {
 460                       set _attrs(intensity) bold
 461                   }
 462                   2 {
 463                       set _attrs(intensity) dim
 464                   }
 465                   4 {
 466                       set _attrs(underline) 1
 467                   }
 468                   7 {
 469                       set _attrs(reverse) 1
 470                   }
 471                   22 {
 472                       set _attrs(intensity) normal
 473                   }
 474                   24 {
 475                       set _attrs(underline) 0
 476                   }
 477                   27 {
 478                       set _attrs(reverse) 1
 479                   }
 480                   30 - 31 - 32 - 33 - 34 - 35 - 36 - 37 {
 481                       set _attrs(fg) $item
 482                   }
 483                   39 {
 484                       set _attrs(fg) default
 485                   }
 486                   40 - 41 - 42 - 43 - 44 - 45 - 46 - 47 {
 487                       set _attrs(bg) $item
 488                   }
 489                   49 {
 490                       set _attrs(bg) default
 491                   }
 492               }
 493           }
 494         }
 495     }
 496
 497     # Insert string at the cursor location.
 498     proc _insert {str} {
 499         _log_cur "Inserted string '$str'" {
 500             _log "Inserting string '$str'"
 501
 502             variable _cur_col
 503             variable _cur_row
 504             variable _rows
 505             variable _cols
 506             variable _attrs
 507             variable _chars
 508             set lattr [array get _attrs]
 509             foreach char [split $str {}] {
 510                   _log_cur "  Inserted char '$char'" {
 511                     set _chars($_cur_col,$_cur_row) [list $char $lattr]
 512                     incr _cur_col
 513                     if {$_cur_col >= $_cols} {
 514                         set _cur_col 0
 515                         incr _cur_row
 516                         if {$_cur_row >= $_rows} {
 517                             error "FIXME scroll"
 518                         }
 519                     }
 520                 }
 521             }
 522         }
 523     }
 524
 525     # Initialize.
 526     proc _setup {rows cols} {
 527         global stty_init
 528         set stty_init "rows $rows columns $cols"
 529
 530         variable _rows
 531         variable _cols
 532         variable _cur_col
 533         variable _cur_row
 534         variable _attrs
 535         variable _resize_count
 536
 537         set _rows $rows
 538         set _cols $cols
 539         set _cur_col 0
 540         set _cur_row 0
 541         set _resize_count 0
 542         array set _attrs {
 543             intensity normal
 544             fg default
 545             bg default
 546             underline 0
 547             reverse 0
 548         }
 549
 550         _clear_lines 0 $_rows
 551     }
 552
 553     # Accept some output from gdb and update the screen.  WAIT_FOR is
 554     # a regexp matching the line to wait for.  Return 0 on timeout, 1
 555     # on success.
 556     proc wait_for {wait_for} {
 557         global expect_out
 558         global gdb_prompt
 559         variable _cur_col
 560         variable _cur_row
 561
 562         set prompt_wait_for "$gdb_prompt \$"
 563
 564         while 1 {
 565             gdb_expect {
 566                 -re "^\[\x07\x08\x0a\x0d\]" {
 567                     scan $expect_out(0,string) %c val
 568                     set hexval [format "%02x" $val]
 569                     _log "wait_for: _ctl_0x${hexval}"
 570                     _ctl_0x${hexval}
 571                 }
 572                 -re "^\x1b(\[0-9a-zA-Z\])" {
 573                     _log "wait_for: unsupported escape"
 574                     error "unsupported escape"
 575                 }
 576                 -re "^\x1b\\\[(\[0-9;\]*)(\[a-zA-Z@\])" {
 577                     set cmd $expect_out(2,string)
 578                     set params [split $expect_out(1,string) ";"]
 579                     _log "wait_for: _csi_$cmd <<<$expect_out(1,string)>>>"
 580                     eval _csi_$cmd $params
 581                 }
 582                 -re "^\[^\x07\x08\x0a\x0d\x1b\]+" {
 583                     _insert $expect_out(0,string)
 584                     variable _last_char
 585                     set _last_char [string index $expect_out(0,string) end]
 586                 }
 587
 588                 timeout {
 589                     # Assume a timeout means we somehow missed the
 590                     # expected result, and carry on.
 591                     return 0
 592                 }
 593             }
 594
 595             # If the cursor appears just after the prompt, return.  It
 596             # isn't reliable to check this only after an insertion,
 597             # because curses may make "unusual" redrawing decisions.
 598             if {$wait_for == "$prompt_wait_for"} {
 599                 set prev [get_line $_cur_row $_cur_col]
 600             } else {
 601                 set prev [get_line $_cur_row]
 602             }
 603             if {[regexp -- $wait_for $prev]} {
 604                 if {$wait_for == "$prompt_wait_for"} {
 605                     break
 606                 }
 607                 set wait_for $prompt_wait_for
 608             }
 609         }
 610
 611         return 1
 612     }
 613
 614     # Like ::clean_restart, but ensures that gdb starts in an
 615     # environment where the TUI can work.  ROWS and COLS are the size
 616     # of the terminal.  EXECUTABLE, if given, is passed to
 617     # clean_restart.
 618     proc clean_restart {rows cols {executable {}}} {
 619         global env stty_init
 620         save_vars {env(TERM) stty_init} {
 621             setenv TERM ansi
 622             _setup $rows $cols
 623             if {$executable == ""} {
 624                 ::clean_restart
 625             } else {
 626                 ::clean_restart $executable
 627             }
 628         }
 629     }
 630
 631     # Setup ready for starting the tui, but don't actually start it.
 632     # Returns 1 on success, 0 if TUI tests should be skipped.
 633     proc prepare_for_tui {} {
 634         if {[skip_tui_tests]} {
 635             return 0
 636         }
 637
 638         gdb_test_no_output "set tui border-kind ascii"
 639         gdb_test_no_output "maint set tui-resize-message on"
 640         return 1
 641     }
 642
 643     # Start the TUI.  Returns 1 on success, 0 if TUI tests should be
 644     # skipped.
 645     proc enter_tui {} {
 646         if {![prepare_for_tui]} {
 647             return 0
 648         }
 649
 650         command_no_prompt_prefix "tui enable"
 651         return 1
 652     }
 653
 654     # Send the command CMD to gdb, then wait for a gdb prompt to be
 655     # seen in the TUI.  CMD should not end with a newline -- that will
 656     # be supplied by this function.
 657     proc command {cmd} {
 658         global gdb_prompt
 659         send_gdb "$cmd\n"
 660         set str [string_to_regexp $cmd]
 661         set str "^$gdb_prompt $str"
 662         wait_for $str
 663     }
 664
 665     # As proc command, but don't wait for a initial prompt.  This is used for
 666     # inital terminal commands, where there's no prompt yet.
 667     proc command_no_prompt_prefix {cmd} {
 668         send_gdb "$cmd\n"
 669         set str [string_to_regexp $cmd]
 670         wait_for "^$str"
 671     }
 672
 673     # Return the text of screen line N, without attributes.  Lines are
 674     # 0-based.  If C is given, stop before column C.  Columns are also
 675     # zero-based.
 676     proc get_line {n {c ""}} {
 677         variable _rows
 678         # This can happen during resizing, if the cursor seems to
 679         # temporarily be off-screen.
 680         if {$n >= $_rows} {
 681             return ""
 682         }
 683
 684         set result ""
 685         variable _cols
 686         variable _chars
 687         set c [_default $c $_cols]
 688         set x 0
 689         while {$x < $c} {
 690             append result [lindex $_chars($x,$n) 0]
 691             incr x
 692         }
 693         return $result
 694     }
 695
 696     # Get just the character at (X, Y).
 697     proc get_char {x y} {
 698         variable _chars
 699         return [lindex $_chars($x,$y) 0]
 700     }
 701
 702     # Get the entire screen as a string.
 703     proc get_all_lines {} {
 704         variable _rows
 705         variable _cols
 706         variable _chars
 707
 708         set result ""
 709         for {set y 0} {$y < $_rows} {incr y} {
 710             for {set x 0} {$x < $_cols} {incr x} {
 711                 append result [lindex $_chars($x,$y) 0]
 712             }
 713             append result "\n"
 714         }
 715
 716         return $result
 717     }
 718
 719     # Get the text just before the cursor.
 720     proc get_current_line {} {
 721         variable _cur_col
 722         variable _cur_row
 723         return [get_line $_cur_row $_cur_col]
 724     }
 725
 726     # Helper function for check_box.  Returns empty string if the box
 727     # is found, description of why not otherwise.
 728     proc _check_box {x y width height} {
 729         set x2 [expr {$x + $width - 1}]
 730         set y2 [expr {$y + $height - 1}]
 731
 732         verbose -log "_check_box x=$x, y=$y, x2=$x2, y2=$y2, width=$width, height=$height"
 733
 734         set c [get_char $x $y]
 735         if {$c != "+"} {
 736             return "ul corner is $c, not +"
 737         }
 738
 739         set c [get_char $x $y2]
 740         if {$c != "+"} {
 741             return "ll corner is $c, not +"
 742         }
 743
 744         set c [get_char $x2 $y]
 745         if {$c != "+"} {
 746             return "ur corner is $c, not +"
 747         }
 748
 749         set c [get_char $x2 $y2]
 750         if {$c != "+"} {
 751             return "lr corner is $c, not +"
 752         }
 753
 754         # Note we do not check the full horizonal borders of the box.
 755         # The top will contain a title, and the bottom may as well, if
 756         # it is overlapped by some other border.  However, at most a
 757         # title should appear as '+-VERY LONG TITLE-+', so we can
 758         # check for the '+-' on the left, and '-+' on the right.
 759         set c [get_char [expr {$x + 1}] $y]
 760         if {$c != "-"} {
 761             return "ul title padding is $c, not -"
 762         }
 763
 764         set c [get_char [expr {$x2 - 1}] $y]
 765         if {$c != "-"} {
 766             return "ul title padding is $c, not -"
 767         }
 768
 769         # Now check the vertical borders.
 770         for {set i [expr {$y + 1}]} {$i < $y2 - 1} {incr i} {
 771             set c [get_char $x $i]
 772             if {$c != "|"} {
 773                 return "left side $i is $c, not |"
 774             }
 775
 776             set c [get_char $x2 $i]
 777             if {$c != "|"} {
 778                 return "right side $i is $c, not |"
 779             }
 780         }
 781
 782         return ""
 783     }
 784
 785     # Check for a box at the given coordinates.
 786     proc check_box {test_name x y width height} {
 787         set why [_check_box $x $y $width $height]
 788         if {$why == ""} {
 789             pass $test_name
 790         } else {
 791             dump_screen
 792             fail "$test_name ($why)"
 793         }
 794     }
 795
 796     # Check whether the text contents of the terminal match the
 797     # regular expression.  Note that text styling is not considered.
 798     proc check_contents {test_name regexp} {
 799         set contents [get_all_lines]
 800         if {![gdb_assert {[regexp -- $regexp $contents]} $test_name]} {
 801             dump_screen
 802         }
 803     }
 804
 805     # Check that the region of the screen described by X, Y, WIDTH,
 806     # and HEIGHT match REGEXP.  This is like check_contents except
 807     # only part of the screen is checked.  This can be used to check
 808     # the contents within a box (though check_box_contents is a better
 809     # choice for boxes with a border).
 810     proc check_region_contents { test_name x y width height regexp } {
 811         variable _chars
 812
 813         # Now grab the contents of the box, join each line together
 814         # with a '\r\n' sequence and match against REGEXP.
 815         set result ""
 816         for {set yy $y} {$yy < [expr {$y + $height}]} {incr yy} {
 817             if {$yy > $y} {
 818                 # Add the end of line sequence only if this isn't the
 819                 # first line.
 820                 append result "\r\n"
 821             }
 822             for {set xx $x} {$xx < [expr {$x + $width}]} {incr xx} {
 823                 append result [lindex $_chars($xx,$yy) 0]
 824             }
 825         }
 826
 827         if {![gdb_assert {[regexp -- $regexp $result]} $test_name]} {
 828             dump_screen
 829         }
 830     }
 831
 832     # Check the contents of a box on the screen.  This is a little
 833     # like check_contents, but doens't check the whole screen
 834     # contents, only the contents of a single box.  This procedure
 835     # includes (effectively) a call to check_box to ensure there is a
 836     # box where expected, if there is then the contents of the box are
 837     # matched against REGEXP.
 838     proc check_box_contents {test_name x y width height regexp} {
 839         variable _chars
 840
 841         set why [_check_box $x $y $width $height]
 842         if {$why != ""} {
 843             dump_screen
 844             fail "$test_name (box check: $why)"
 845             return
 846         }
 847
 848         check_region_contents $test_name [expr {$x + 1}] [expr {$y + 1}] \
 849             [expr {$width - 2}] [expr {$height - 2}] $regexp
 850     }
 851
 852     # A debugging function to dump the current screen, with line
 853     # numbers.
 854     proc dump_screen {} {
 855         variable _rows
 856         variable _cols
 857         verbose -log "Screen Dump ($_cols x $_rows):"
 858         for {set y 0} {$y < $_rows} {incr y} {
 859             set fmt [format %5d $y]
 860             verbose -log "$fmt [get_line $y]"
 861         }
 862     }
 863
 864     # Resize the terminal.
 865     proc _do_resize {rows cols} {
 866         variable _chars
 867         variable _rows
 868         variable _cols
 869
 870         set old_rows [expr {min ($_rows, $rows)}]
 871         set old_cols [expr {min ($_cols, $cols)}]
 872
 873         # Copy locally.
 874         array set local_chars [array get _chars]
 875         unset _chars
 876
 877         set _rows $rows
 878         set _cols $cols
 879         _clear_lines 0 $_rows
 880
 881         for {set x 0} {$x < $old_cols} {incr x} {
 882             for {set y 0} {$y < $old_rows} {incr y} {
 883                 set _chars($x,$y) $local_chars($x,$y)
 884             }
 885         }
 886     }
 887
 888     proc resize {rows cols} {
 889         variable _rows
 890         variable _cols
 891         variable _resize_count
 892
 893         global gdb_spawn_name
 894         # expect handles each argument to stty separately.  This means
 895         # that gdb will see SIGWINCH twice.  Rather than rely on this
 896         # behavior (which, after all, could be changed), we make it
 897         # explicit here.  This also simplifies waiting for the redraw.
 898         _do_resize $rows $_cols
 899         stty rows $_rows < $gdb_spawn_name
 900         # Due to the strange column resizing behavior, and because we
 901         # don't care about this intermediate resize, we don't check
 902         # the size here.
 903         wait_for "@@ resize done $_resize_count"
 904         incr _resize_count
 905         # Somehow the number of columns transmitted to gdb is one less
 906         # than what we request from expect.  We hide this weird
 907         # details from the caller.
 908         _do_resize $_rows $cols
 909         stty columns [expr {$_cols + 1}] < $gdb_spawn_name
 910         wait_for "@@ resize done $_resize_count, size = ${_cols}x${rows}"
 911         incr _resize_count
 912     }
 913 }