gdb/testsuite/lib/tuiterm.exp

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