1# Copyright 2019-2024 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 18namespace 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 variable _cols 103 variable _chars 104 105 incr _cur_row 1 106 while {$_cur_row >= $_rows} { 107 # Scroll the display contents. We scroll one line at 108 # a time here; as _cur_row was only increased by one, 109 # a single line scroll should be enough to put the 110 # cursor back on the screen. But we wrap the 111 # scrolling inside a while loop just to be on the safe 112 # side. 113 for {set y 0} {$y < [expr $_rows - 1]} {incr y} { 114 set next_y [expr $y + 1] 115 for {set x 0} {$x < $_cols} {incr x} { 116 set _chars($x,$y) $_chars($x,$next_y) 117 } 118 } 119 120 incr _cur_row -1 121 } 122 } 123 } 124 125 # Carriage return. 126 proc _ctl_0x0d {} { 127 _log_cur "Carriage return" { 128 variable _cur_col 129 130 set _cur_col 0 131 } 132 } 133 134 # Insert Character. 135 # 136 # https://vt100.net/docs/vt510-rm/ICH.html 137 proc _csi_@ {args} { 138 set n [_default [lindex $args 0] 1] 139 140 _log_cur "Insert Character ($n)" { 141 variable _cur_col 142 variable _cur_row 143 variable _cols 144 variable _chars 145 146 # Move characters right of the cursor right by N positions, 147 # starting with the rightmost one. 148 for {set in_col [expr $_cols - $n - 1]} {$in_col >= $_cur_col} {incr in_col -1} { 149 set out_col [expr $in_col + $n] 150 set _chars($out_col,$_cur_row) $_chars($in_col,$_cur_row) 151 } 152 153 # Write N blank spaces starting from the cursor. 154 _clear_in_line $_cur_col [expr $_cur_col + $n] $_cur_row 155 } 156 } 157 158 # Cursor Up. 159 # 160 # https://vt100.net/docs/vt510-rm/CUU.html 161 proc _csi_A {args} { 162 set arg [_default [lindex $args 0] 1] 163 164 _log_cur "Cursor Up ($arg)" { 165 variable _cur_row 166 167 set _cur_row [expr {max ($_cur_row - $arg, 0)}] 168 } 169 } 170 171 # Cursor Down. 172 # 173 # https://vt100.net/docs/vt510-rm/CUD.html 174 proc _csi_B {args} { 175 set arg [_default [lindex $args 0] 1] 176 177 _log_cur "Cursor Down ($arg)" { 178 variable _cur_row 179 variable _rows 180 181 set _cur_row [expr {min ($_cur_row + $arg, $_rows - 1)}] 182 } 183 } 184 185 # Cursor Forward. 186 # 187 # https://vt100.net/docs/vt510-rm/CUF.html 188 proc _csi_C {args} { 189 set arg [_default [lindex $args 0] 1] 190 191 _log_cur "Cursor Forward ($arg)" { 192 variable _cur_col 193 variable _cols 194 195 set _cur_col [expr {min ($_cur_col + $arg, $_cols - 1)}] 196 } 197 } 198 199 # Cursor Backward. 200 # 201 # https://vt100.net/docs/vt510-rm/CUB.html 202 proc _csi_D {args} { 203 set arg [_default [lindex $args 0] 1] 204 205 _log_cur "Cursor Backward ($arg)" { 206 variable _cur_col 207 208 set _cur_col [expr {max ($_cur_col - $arg, 0)}] 209 } 210 } 211 212 # Cursor Next Line. 213 # 214 # https://vt100.net/docs/vt510-rm/CNL.html 215 proc _csi_E {args} { 216 set arg [_default [lindex $args 0] 1] 217 218 _log_cur "Cursor Next Line ($arg)" { 219 variable _cur_col 220 variable _cur_row 221 variable _rows 222 223 set _cur_col 0 224 set _cur_row [expr {min ($_cur_row + $arg, $_rows - 1)}] 225 } 226 } 227 228 # Cursor Previous Line. 229 # 230 # https://vt100.net/docs/vt510-rm/CPL.html 231 proc _csi_F {args} { 232 set arg [_default [lindex $args 0] 1] 233 234 _log_cur "Cursor Previous Line ($arg)" { 235 variable _cur_col 236 variable _cur_row 237 variable _rows 238 239 set _cur_col 0 240 set _cur_row [expr {max ($_cur_row - $arg, 0)}] 241 } 242 } 243 244 # Cursor Horizontal Absolute. 245 # 246 # https://vt100.net/docs/vt510-rm/CHA.html 247 proc _csi_G {args} { 248 set arg [_default [lindex $args 0] 1] 249 250 _log_cur "Cursor Horizontal Absolute ($arg)" { 251 variable _cur_col 252 variable _cols 253 254 set _cur_col [expr {min ($arg - 1, $_cols)}] 255 } 256 } 257 258 # Cursor Position. 259 # 260 # https://vt100.net/docs/vt510-rm/CUP.html 261 proc _csi_H {args} { 262 set row [_default [lindex $args 0] 1] 263 set col [_default [lindex $args 1] 1] 264 265 _log_cur "Cursor Position ($row, $col)" { 266 variable _cur_col 267 variable _cur_row 268 269 set _cur_row [expr {$row - 1}] 270 set _cur_col [expr {$col - 1}] 271 } 272 } 273 274 # Cursor Horizontal Forward Tabulation. 275 # 276 # https://vt100.net/docs/vt510-rm/CHT.html 277 proc _csi_I {args} { 278 set n [_default [lindex $args 0] 1] 279 280 _log_cur "Cursor Horizontal Forward Tabulation ($n)" { 281 variable _cur_col 282 variable _cols 283 284 incr _cur_col [expr {$n * 8 - $_cur_col % 8}] 285 if {$_cur_col >= $_cols} { 286 set _cur_col [expr {$_cols - 1}] 287 } 288 } 289 } 290 291 # Erase in Display. 292 # 293 # https://vt100.net/docs/vt510-rm/ED.html 294 proc _csi_J {args} { 295 set arg [_default [lindex $args 0] 0] 296 297 _log_cur "Erase in Display ($arg)" { 298 variable _cur_col 299 variable _cur_row 300 variable _rows 301 variable _cols 302 303 if {$arg == 0} { 304 # Cursor (inclusive) to end of display. 305 _clear_in_line $_cur_col $_cols $_cur_row 306 _clear_lines [expr {$_cur_row + 1}] $_rows 307 } elseif {$arg == 1} { 308 # Beginning of display to cursor (inclusive). 309 _clear_lines 0 $_cur_row 310 _clear_in_line 0 [expr $_cur_col + 1] $_cur_row 311 } elseif {$arg == 2} { 312 # Entire display. 313 _clear_lines 0 $_rows 314 } 315 } 316 } 317 318 # Erase in Line. 319 # 320 # https://vt100.net/docs/vt510-rm/EL.html 321 proc _csi_K {args} { 322 set arg [_default [lindex $args 0] 0] 323 324 _log_cur "Erase in Line ($arg)" { 325 variable _cur_col 326 variable _cur_row 327 variable _cols 328 329 if {$arg == 0} { 330 # Cursor (inclusive) to end of line. 331 _clear_in_line $_cur_col $_cols $_cur_row 332 } elseif {$arg == 1} { 333 # Beginning of line to cursor (inclusive). 334 _clear_in_line 0 [expr $_cur_col + 1] $_cur_row 335 } elseif {$arg == 2} { 336 # Entire line. 337 _clear_in_line 0 $_cols $_cur_row 338 } 339 } 340 } 341 342 # Insert Line 343 # 344 # https://vt100.net/docs/vt510-rm/IL.html 345 proc _csi_L {args} { 346 set arg [_default [lindex $args 0] 1] 347 348 _log_cur "Insert Line ($arg)" { 349 variable _cur_col 350 variable _cur_row 351 variable _rows 352 variable _cols 353 variable _chars 354 355 set y [expr $_rows - 2] 356 set next_y [expr $y + $arg] 357 while {$y >= $_cur_row} { 358 for {set x 0} {$x < $_cols} {incr x} { 359 set _chars($x,$next_y) $_chars($x,$y) 360 } 361 incr y -1 362 incr next_y -1 363 } 364 365 _clear_lines $_cur_row [expr $_cur_row + $arg] 366 } 367 } 368 369 # Delete line. 370 # 371 # https://vt100.net/docs/vt510-rm/DL.html 372 proc _csi_M {args} { 373 set count [_default [lindex $args 0] 1] 374 375 _log_cur "Delete line ($count)" { 376 variable _cur_row 377 variable _rows 378 variable _cols 379 variable _chars 380 381 set y $_cur_row 382 set next_y [expr {$y + $count}] 383 while {$next_y < $_rows} { 384 for {set x 0} {$x < $_cols} {incr x} { 385 set _chars($x,$y) $_chars($x,$next_y) 386 } 387 incr y 388 incr next_y 389 } 390 _clear_lines $y $_rows 391 } 392 } 393 394 # Delete Character. 395 # 396 # https://vt100.net/docs/vt510-rm/DCH.html 397 proc _csi_P {args} { 398 set count [_default [lindex $args 0] 1] 399 400 _log_cur "Delete character ($count)" { 401 variable _cur_row 402 variable _cur_col 403 variable _chars 404 variable _cols 405 406 # Move all characters right of the cursor N positions left. 407 set out_col [expr $_cur_col] 408 set in_col [expr $_cur_col + $count] 409 410 while {$in_col < $_cols} { 411 set _chars($out_col,$_cur_row) $_chars($in_col,$_cur_row) 412 incr in_col 413 incr out_col 414 } 415 416 # Clear the rest of the line. 417 _clear_in_line $out_col $_cols $_cur_row 418 } 419 } 420 421 # Pan Down 422 # 423 # https://vt100.net/docs/vt510-rm/SU.html 424 proc _csi_S {args} { 425 set count [_default [lindex $args 0] 1] 426 427 _log_cur "Pan Down ($count)" { 428 variable _cur_col 429 variable _cur_row 430 variable _cols 431 variable _rows 432 variable _chars 433 434 # The following code is written without consideration for 435 # the scroll margins. At this time this comment was 436 # written the tuiterm library doesn't support the scroll 437 # margins. If/when that changes, then the following will 438 # need to be updated. 439 440 set dy 0 441 set y $count 442 443 while {$y < $_rows} { 444 for {set x 0} {$x < $_cols} {incr x} { 445 set _chars($x,$dy) $_chars($x,$y) 446 } 447 incr y 1 448 incr dy 1 449 } 450 451 _clear_lines $dy $_rows 452 } 453 } 454 455 # Pan Up 456 # 457 # https://vt100.net/docs/vt510-rm/SD.html 458 proc _csi_T {args} { 459 set count [_default [lindex $args 0] 1] 460 461 _log_cur "Pan Up ($count)" { 462 variable _cur_col 463 variable _cur_row 464 variable _cols 465 variable _rows 466 variable _chars 467 468 # The following code is written without consideration for 469 # the scroll margins. At this time this comment was 470 # written the tuiterm library doesn't support the scroll 471 # margins. If/when that changes, then the following will 472 # need to be updated. 473 474 set y [expr $_rows - $count] 475 set dy $_rows 476 477 while {$dy >= $count} { 478 for {set x 0} {$x < $_cols} {incr x} { 479 set _chars($x,$dy) $_chars($x,$y) 480 } 481 incr y -1 482 incr dy -1 483 } 484 485 _clear_lines 0 $count 486 } 487 } 488 489 # Erase chars. 490 # 491 # https://vt100.net/docs/vt510-rm/ECH.html 492 proc _csi_X {args} { 493 set n [_default [lindex $args 0] 1] 494 495 _log_cur "Erase chars ($n)" { 496 # Erase characters but don't move cursor. 497 variable _cur_col 498 variable _cur_row 499 variable _attrs 500 variable _chars 501 502 set lattr [array get _attrs] 503 set x $_cur_col 504 for {set i 0} {$i < $n} {incr i} { 505 set _chars($x,$_cur_row) [list " " $lattr] 506 incr x 507 } 508 } 509 } 510 511 # Cursor Backward Tabulation. 512 # 513 # https://vt100.net/docs/vt510-rm/CBT.html 514 proc _csi_Z {args} { 515 set n [_default [lindex $args 0] 1] 516 517 _log_cur "Cursor Backward Tabulation ($n)" { 518 variable _cur_col 519 520 set _cur_col [expr {max (int (($_cur_col - 1) / 8) * 8 - ($n - 1) * 8, 0)}] 521 } 522 } 523 524 # Repeat. 525 # 526 # https://www.xfree86.org/current/ctlseqs.html (See `(REP)`) 527 proc _csi_b {args} { 528 set n [_default [lindex $args 0] 1] 529 530 _log_cur "Repeat ($n)" { 531 variable _last_char 532 533 _insert [string repeat $_last_char $n] 534 } 535 } 536 537 # Vertical Line Position Absolute. 538 # 539 # https://vt100.net/docs/vt510-rm/VPA.html 540 proc _csi_d {args} { 541 set row [_default [lindex $args 0] 1] 542 543 _log_cur "Vertical Line Position Absolute ($row)" { 544 variable _cur_row 545 variable _rows 546 547 set _cur_row [expr min ($row - 1, $_rows - 1)] 548 } 549 } 550 551 # Reset the attributes in attributes array UPVAR_NAME to the default values. 552 proc _reset_attrs { upvar_name } { 553 upvar $upvar_name var 554 array set var { 555 intensity normal 556 fg default 557 bg default 558 underline 0 559 reverse 0 560 invisible 0 561 blinking 0 562 } 563 } 564 565 # Translate the color numbers as used in proc _csi_m to a name. 566 proc _color_attr { n } { 567 switch -exact -- $n { 568 0 { 569 return black 570 } 571 1 { 572 return red 573 } 574 2 { 575 return green 576 } 577 3 { 578 return yellow 579 } 580 4 { 581 return blue 582 } 583 5 { 584 return magenta 585 } 586 6 { 587 return cyan 588 } 589 7 { 590 return white 591 } 592 default { error "unsupported color number: $n" } 593 } 594 } 595 596 # Select Graphic Rendition. 597 # 598 # https://vt100.net/docs/vt510-rm/SGR.html 599 proc _csi_m {args} { 600 _log_cur "Select Graphic Rendition ([join $args {, }])" { 601 variable _attrs 602 603 foreach item $args { 604 switch -exact -- $item { 605 "" - 0 { 606 _reset_attrs _attrs 607 } 608 1 { 609 set _attrs(intensity) bold 610 } 611 2 { 612 set _attrs(intensity) dim 613 } 614 4 { 615 set _attrs(underline) 1 616 } 617 5 { 618 set _attrs(blinking) 1 619 } 620 7 { 621 set _attrs(reverse) 1 622 } 623 8 { 624 set _attrs(invisible) 1 625 } 626 22 { 627 set _attrs(intensity) normal 628 } 629 24 { 630 set _attrs(underline) 0 631 } 632 25 { 633 set _attrs(blinking) 0 634 } 635 27 { 636 set _attrs(reverse) 0 637 } 638 28 { 639 set _attrs(invisible) 0 640 } 641 30 - 31 - 32 - 33 - 34 - 35 - 36 - 37 { 642 set _attrs(fg) [_color_attr [expr $item - 30]] 643 } 644 39 { 645 set _attrs(fg) default 646 } 647 40 - 41 - 42 - 43 - 44 - 45 - 46 - 47 { 648 set _attrs(bg) [_color_attr [expr $item - 40]] 649 } 650 49 { 651 set _attrs(bg) default 652 } 653 } 654 } 655 } 656 } 657 658 # Insert string at the cursor location. 659 proc _insert {str} { 660 _log_cur "Inserted string '$str'" { 661 _log "Inserting string '$str'" 662 663 variable _cur_col 664 variable _cur_row 665 variable _rows 666 variable _cols 667 variable _attrs 668 variable _chars 669 set lattr [array get _attrs] 670 foreach char [split $str {}] { 671 _log_cur " Inserted char '$char'" { 672 set _chars($_cur_col,$_cur_row) [list $char $lattr] 673 incr _cur_col 674 if {$_cur_col >= $_cols} { 675 set _cur_col 0 676 incr _cur_row 677 if {$_cur_row >= $_rows} { 678 error "FIXME scroll" 679 } 680 } 681 } 682 } 683 } 684 } 685 686 # Move the cursor to the (0-based) COL and ROW positions. 687 proc _move_cursor { col row } { 688 variable _cols 689 variable _rows 690 variable _cur_col 691 variable _cur_row 692 693 if { $col < 0 || $col >= $_cols } { 694 error "_move_cursor: invalid col value: $col" 695 } 696 697 if { $row < 0 || $row >= $_rows } { 698 error "_move_cursor: invalid row value: $row" 699 } 700 701 702 set _cur_col $col 703 set _cur_row $row 704 } 705 706 # Initialize. 707 proc _setup {rows cols} { 708 global stty_init 709 set stty_init "rows $rows columns $cols" 710 711 variable _rows 712 variable _cols 713 variable _cur_col 714 variable _cur_row 715 variable _attrs 716 variable _resize_count 717 718 set _rows $rows 719 set _cols $cols 720 set _cur_col 0 721 set _cur_row 0 722 set _resize_count 0 723 _reset_attrs _attrs 724 725 _clear_lines 0 $_rows 726 } 727 728 # Accept some output from gdb and update the screen. 729 # Return 1 if successful, or 0 if a timeout occurred. 730 proc accept_gdb_output { } { 731 global expect_out 732 gdb_expect { 733 -re "^\[\x07\x08\x0a\x0d\]" { 734 scan $expect_out(0,string) %c val 735 set hexval [format "%02x" $val] 736 _log "wait_for: _ctl_0x${hexval}" 737 _ctl_0x${hexval} 738 } 739 -re "^\x1b(\[0-9a-zA-Z\])" { 740 _log "wait_for: unsupported escape" 741 error "unsupported escape" 742 } 743 -re "^\x1b\\\[(\[0-9;\]*)(\[a-zA-Z@\])" { 744 set cmd $expect_out(2,string) 745 set params [split $expect_out(1,string) ";"] 746 _log "wait_for: _csi_$cmd <<<$expect_out(1,string)>>>" 747 eval _csi_$cmd $params 748 } 749 -re "^\[^\x07\x08\x0a\x0d\x1b\]+" { 750 _insert $expect_out(0,string) 751 variable _last_char 752 set _last_char [string index $expect_out(0,string) end] 753 } 754 755 timeout { 756 # Assume a timeout means we somehow missed the 757 # expected result, and carry on. 758 warning "timeout in accept_gdb_output" 759 dump_screen 760 return 0 761 } 762 } 763 764 return 1 765 } 766 767 # Print arg using "verbose -log" if DEBUG_TUI_MATCHING == 1. 768 proc debug_tui_matching { arg } { 769 set debug 0 770 if { [info exists ::DEBUG_TUI_MATCHING] } { 771 set debug $::DEBUG_TUI_MATCHING 772 } 773 774 if { ! $debug } { 775 return 776 } 777 778 verbose -log "$arg" 779 } 780 781 # Accept some output from gdb and update the screen. WAIT_FOR is 782 # a regexp matching the line to wait for. Return 0 on timeout, 1 783 # on success. 784 proc wait_for {wait_for} { 785 global gdb_prompt 786 variable _cur_col 787 variable _cur_row 788 789 set fn "wait_for" 790 791 set prompt_wait_for "(^|\\|)$gdb_prompt \$" 792 if { $wait_for == "" } { 793 set wait_for $prompt_wait_for 794 } 795 796 debug_tui_matching "$fn: regexp: '$wait_for'" 797 798 while 1 { 799 if { [accept_gdb_output] == 0 } { 800 return 0 801 } 802 803 # If the cursor appears just after the prompt, return. It 804 # isn't reliable to check this only after an insertion, 805 # because curses may make "unusual" redrawing decisions. 806 if {$wait_for == "$prompt_wait_for"} { 807 set prev [get_line $_cur_row $_cur_col] 808 } else { 809 set prev [get_line $_cur_row] 810 } 811 if {[regexp -- $wait_for $prev]} { 812 debug_tui_matching "$fn: match: '$prev'" 813 if {$wait_for == "$prompt_wait_for"} { 814 break 815 } 816 set wait_for $prompt_wait_for 817 debug_tui_matching "$fn: regexp prompt: '$wait_for'" 818 } else { 819 debug_tui_matching "$fn: mismatch: '$prev'" 820 } 821 } 822 823 return 1 824 } 825 826 # Accept some output from gdb and update the screen. Wait for the screen 827 # region X/Y/WIDTH/HEIGTH to matches REGEXP. Return 0 on timeout, 1 on 828 # success. 829 proc wait_for_region_contents {x y width height regexp} { 830 while 1 { 831 if { [accept_gdb_output] == 0 } { 832 return 0 833 } 834 835 if { [check_region_contents_p $x $y $width $height $regexp] } { 836 break 837 } 838 } 839 840 return 1 841 } 842 843 # Setup the terminal with dimensions ROWSxCOLS, TERM=ansi, and execute 844 # BODY. 845 proc with_tuiterm {rows cols body} { 846 global env stty_init 847 save_vars {env(TERM) env(NO_COLOR) stty_init} { 848 setenv TERM ansi 849 setenv NO_COLOR "" 850 _setup $rows $cols 851 852 uplevel $body 853 } 854 } 855 856 # Like ::clean_restart, but ensures that gdb starts in an 857 # environment where the TUI can work. ROWS and COLS are the size 858 # of the terminal. EXECUTABLE, if given, is passed to 859 # clean_restart. 860 proc clean_restart {rows cols {executable {}}} { 861 with_tuiterm $rows $cols { 862 save_vars { ::GDBFLAGS } { 863 # Make GDB not print the directory names. Use this setting to 864 # remove the differences in test runs due to varying directory 865 # names. 866 append ::GDBFLAGS " -ex \"set filename-display basename\"" 867 868 if {$executable == ""} { 869 ::clean_restart 870 } else { 871 ::clean_restart $executable 872 } 873 } 874 875 ::gdb_test_no_output "set pagination off" 876 } 877 } 878 879 # Generate prompt on TUIterm. 880 proc gen_prompt {} { 881 # Generate a prompt. 882 send_gdb "echo\n" 883 884 # Drain the output before the prompt. 885 gdb_expect { 886 -re "echo\r\n" { 887 } 888 } 889 890 # Interpret prompt using TUIterm. 891 wait_for "" 892 } 893 894 # Setup ready for starting the tui, but don't actually start it. 895 # Returns 1 on success, 0 if TUI tests should be skipped. 896 proc prepare_for_tui {} { 897 if { [is_remote host] } { 898 # In clean_restart, we're using "setenv TERM ansi", which has 899 # effect on build. If we have [is_remote host] == 0, so 900 # build == host, then it also has effect on host. But for 901 # [is_remote host] == 1, it has no effect on host. 902 return 0 903 } 904 905 if {![allow_tui_tests]} { 906 return 0 907 } 908 909 gdb_test_no_output "set tui border-kind ascii" 910 gdb_test_no_output "maint set tui-resize-message on" 911 return 1 912 } 913 914 # Start the TUI. Returns 1 on success, 0 if TUI tests should be 915 # skipped. 916 proc enter_tui {} { 917 if {![prepare_for_tui]} { 918 return 0 919 } 920 921 command_no_prompt_prefix "tui enable" 922 return 1 923 } 924 925 # Send the command CMD to gdb, then wait for a gdb prompt to be 926 # seen in the TUI. CMD should not end with a newline -- that will 927 # be supplied by this function. 928 proc command {cmd} { 929 global gdb_prompt 930 send_gdb "$cmd\n" 931 set str [string_to_regexp $cmd] 932 set str "(^|\\|)$gdb_prompt $str" 933 wait_for $str 934 } 935 936 # As proc command, but don't wait for an initial prompt. This is used for 937 # initial terminal commands, where there's no prompt yet. 938 proc command_no_prompt_prefix {cmd} { 939 gen_prompt 940 command $cmd 941 } 942 943 # Apply the attribute list in ATTRS to attributes array UPVAR_NAME. 944 # Return a string annotating the changed attributes. 945 proc apply_attrs { upvar_name attrs } { 946 set res "" 947 upvar $upvar_name var 948 foreach { attr val } $attrs { 949 if { $var($attr) != $val } { 950 append res "<$attr:$val>" 951 set var($attr) $val 952 } 953 } 954 955 return $res 956 } 957 958 # Return the text of screen line N. Lines are 0-based. If C is given, 959 # stop before column C. Columns are also zero-based. If ATTRS, annotate 960 # with attributes. 961 proc get_line_1 {n c attrs} { 962 variable _rows 963 # This can happen during resizing, if the cursor seems to 964 # temporarily be off-screen. 965 if {$n >= $_rows} { 966 return "" 967 } 968 969 set result "" 970 variable _cols 971 variable _chars 972 set c [_default $c $_cols] 973 set x 0 974 if { $attrs } { 975 _reset_attrs line_attrs 976 } 977 while {$x < $c} { 978 if { $attrs } { 979 set char_attrs [lindex $_chars($x,$n) 1] 980 append result [apply_attrs line_attrs $char_attrs] 981 } 982 append result [lindex $_chars($x,$n) 0] 983 incr x 984 } 985 if { $attrs } { 986 _reset_attrs zero_attrs 987 set char_attrs [array get zero_attrs] 988 append result [apply_attrs line_attrs $char_attrs] 989 } 990 return $result 991 } 992 993 # Return the text of screen line N, without attributes. Lines are 994 # 0-based. If C is given, stop before column C. Columns are also 995 # zero-based. 996 proc get_line {n {c ""} } { 997 return [get_line_1 $n $c 0] 998 } 999 1000 # As get_line, but annotate with attributes. 1001 proc get_line_with_attrs {n {c ""}} { 1002 return [get_line_1 $n $c 1] 1003 } 1004 1005 # Get just the character at (X, Y). 1006 proc get_char {x y} { 1007 variable _chars 1008 return [lindex $_chars($x,$y) 0] 1009 } 1010 1011 # Get the entire screen as a string. 1012 proc get_all_lines {} { 1013 variable _rows 1014 variable _cols 1015 variable _chars 1016 1017 set result "" 1018 for {set y 0} {$y < $_rows} {incr y} { 1019 for {set x 0} {$x < $_cols} {incr x} { 1020 append result [lindex $_chars($x,$y) 0] 1021 } 1022 append result "\n" 1023 } 1024 1025 return $result 1026 } 1027 1028 # Get the text just before the cursor. 1029 proc get_current_line {} { 1030 variable _cur_col 1031 variable _cur_row 1032 return [get_line $_cur_row $_cur_col] 1033 } 1034 1035 # Helper function for check_box. Returns empty string if the box 1036 # is found, description of why not otherwise. 1037 proc _check_box {x y width height} { 1038 set x2 [expr {$x + $width - 1}] 1039 set y2 [expr {$y + $height - 1}] 1040 1041 verbose -log "_check_box x=$x, y=$y, x2=$x2, y2=$y2, width=$width, height=$height" 1042 1043 set c [get_char $x $y] 1044 if {$c != "+"} { 1045 return "ul corner is $c, not +" 1046 } 1047 1048 set c [get_char $x $y2] 1049 if {$c != "+"} { 1050 return "ll corner is $c, not +" 1051 } 1052 1053 set c [get_char $x2 $y] 1054 if {$c != "+"} { 1055 return "ur corner is $c, not +" 1056 } 1057 1058 set c [get_char $x2 $y2] 1059 if {$c != "+"} { 1060 return "lr corner is $c, not +" 1061 } 1062 1063 # Note we do not check the full horizonal borders of the box. 1064 # The top will contain a title, and the bottom may as well, if 1065 # it is overlapped by some other border. However, at most a 1066 # title should appear as '+-VERY LONG TITLE-+', so we can 1067 # check for the '+-' on the left, and '-+' on the right. 1068 set c [get_char [expr {$x + 1}] $y] 1069 if {$c != "-"} { 1070 return "ul title padding is $c, not -" 1071 } 1072 1073 set c [get_char [expr {$x2 - 1}] $y] 1074 if {$c != "-"} { 1075 return "ul title padding is $c, not -" 1076 } 1077 1078 # Now check the vertical borders. 1079 for {set i [expr {$y + 1}]} {$i < $y2 - 1} {incr i} { 1080 set c [get_char $x $i] 1081 if {$c != "|"} { 1082 return "left side $i is $c, not |" 1083 } 1084 1085 set c [get_char $x2 $i] 1086 if {$c != "|"} { 1087 return "right side $i is $c, not |" 1088 } 1089 } 1090 1091 return "" 1092 } 1093 1094 # Check for a box at the given coordinates. 1095 proc check_box {test_name x y width height} { 1096 dump_box $x $y $width $height 1097 set why [_check_box $x $y $width $height] 1098 if {$why == ""} { 1099 pass $test_name 1100 } else { 1101 fail "$test_name ($why)" 1102 } 1103 } 1104 1105 # Wait until a box appears at the given coordinates. 1106 proc wait_for_box {test_name x y width height} { 1107 while 1 { 1108 if { [accept_gdb_output] == 0 } { 1109 return 0 1110 } 1111 1112 set why [_check_box $x $y $width $height] 1113 if {$why == ""} { 1114 pass $test_name 1115 break 1116 } 1117 } 1118 } 1119 1120 # Check whether the text contents of the terminal match the 1121 # regular expression. Note that text styling is not considered. 1122 proc check_contents {test_name regexp} { 1123 dump_screen 1124 set contents [get_all_lines] 1125 gdb_assert {[regexp -- $regexp $contents]} $test_name 1126 } 1127 1128 # As check_contents, but check that the text contents of the terminal does 1129 # not match the regular expression. 1130 proc check_contents_not {test_name regexp} { 1131 dump_screen 1132 set contents [get_all_lines] 1133 gdb_assert {![regexp -- $regexp $contents]} $test_name 1134 } 1135 1136 # Get the region of the screen described by X, Y, WIDTH, 1137 # and HEIGHT, and separate the lines using SEP. 1138 proc get_region { x y width height sep } { 1139 variable _chars 1140 1141 # Grab the contents of the box, join each line together 1142 # using $sep. 1143 set result "" 1144 for {set yy $y} {$yy < [expr {$y + $height}]} {incr yy} { 1145 if {$yy > $y} { 1146 # Add the end of line sequence only if this isn't the 1147 # first line. 1148 append result $sep 1149 } 1150 for {set xx $x} {$xx < [expr {$x + $width}]} {incr xx} { 1151 append result [lindex $_chars($xx,$yy) 0] 1152 } 1153 } 1154 return $result 1155 } 1156 1157 # Check that the region of the screen described by X, Y, WIDTH, 1158 # and HEIGHT match REGEXP. This is like check_contents except 1159 # only part of the screen is checked. This can be used to check 1160 # the contents within a box (though check_box_contents is a better 1161 # choice for boxes with a border). Return 1 if check succeeded. 1162 proc check_region_contents_p { x y width height regexp } { 1163 variable _chars 1164 dump_box $x $y $width $height 1165 1166 # Now grab the contents of the box, join each line together 1167 # with a '\r\n' sequence and match against REGEXP. 1168 set result [get_region $x $y $width $height "\r\n"] 1169 return [regexp -- $regexp $result] 1170 } 1171 1172 # Check that the region of the screen described by X, Y, WIDTH, 1173 # and HEIGHT match REGEXP. As check_region_contents_p, but produce 1174 # a pass/fail message. 1175 proc check_region_contents { test_name x y width height regexp } { 1176 set ok [check_region_contents_p $x $y $width $height $regexp] 1177 gdb_assert {$ok} $test_name 1178 } 1179 1180 # Check the contents of a box on the screen. This is a little 1181 # like check_contents, but doens't check the whole screen 1182 # contents, only the contents of a single box. This procedure 1183 # includes (effectively) a call to check_box to ensure there is a 1184 # box where expected, if there is then the contents of the box are 1185 # matched against REGEXP. 1186 proc check_box_contents {test_name x y width height regexp} { 1187 variable _chars 1188 1189 dump_box $x $y $width $height 1190 set why [_check_box $x $y $width $height] 1191 if {$why != ""} { 1192 fail "$test_name (box check: $why)" 1193 return 1194 } 1195 1196 check_region_contents $test_name [expr {$x + 1}] [expr {$y + 1}] \ 1197 [expr {$width - 2}] [expr {$height - 2}] $regexp 1198 } 1199 1200 # A debugging function to dump the current screen, with line 1201 # numbers. If ATTRS, annotate with attributes. 1202 proc dump_screen { {attrs 0} } { 1203 variable _rows 1204 variable _cols 1205 variable _cur_row 1206 variable _cur_col 1207 1208 verbose -log "Screen Dump (size $_cols columns x $_rows rows, cursor at column $_cur_col, row $_cur_row):" 1209 1210 for {set y 0} {$y < $_rows} {incr y} { 1211 set fmt [format %5d $y] 1212 verbose -log "$fmt [get_line_1 $y "" $attrs]" 1213 } 1214 } 1215 1216 # As dump_screen, but with attributes annotation. 1217 proc dump_screen_with_attrs {} { 1218 return [dump_screen 1] 1219 } 1220 1221 # A debugging function to dump a box from the current screen, with line 1222 # numbers. 1223 proc dump_box { x y width height } { 1224 verbose -log "Box Dump ($width x $height) @ ($x, $y):" 1225 set region [get_region $x $y $width $height "\n"] 1226 set lines [split $region "\n"] 1227 set nr $y 1228 foreach line $lines { 1229 set fmt [format %5d $nr] 1230 verbose -log "$fmt $line" 1231 incr nr 1232 } 1233 } 1234 1235 # Resize the terminal. 1236 proc _do_resize {rows cols} { 1237 variable _chars 1238 variable _rows 1239 variable _cols 1240 1241 set old_rows [expr {min ($_rows, $rows)}] 1242 set old_cols [expr {min ($_cols, $cols)}] 1243 1244 # Copy locally. 1245 array set local_chars [array get _chars] 1246 unset _chars 1247 1248 set _rows $rows 1249 set _cols $cols 1250 _clear_lines 0 $_rows 1251 1252 for {set x 0} {$x < $old_cols} {incr x} { 1253 for {set y 0} {$y < $old_rows} {incr y} { 1254 set _chars($x,$y) $local_chars($x,$y) 1255 } 1256 } 1257 } 1258 1259 proc resize {rows cols {wait_for_msg 1}} { 1260 variable _rows 1261 variable _cols 1262 variable _resize_count 1263 1264 # expect handles each argument to stty separately. This means 1265 # that gdb will see SIGWINCH twice. Rather than rely on this 1266 # behavior (which, after all, could be changed), we make it 1267 # explicit here. This also simplifies waiting for the redraw. 1268 _do_resize $rows $_cols 1269 stty rows $_rows < $::gdb_tty_name 1270 if { $wait_for_msg } { 1271 wait_for "@@ resize done $_resize_count, size = ${_cols}x${rows}" 1272 } 1273 incr _resize_count 1274 _do_resize $_rows $cols 1275 stty columns $_cols < $::gdb_tty_name 1276 if { $wait_for_msg } { 1277 wait_for "@@ resize done $_resize_count, size = ${_cols}x${rows}" 1278 } 1279 incr _resize_count 1280 } 1281} 1282