1 # Copyright 2019-2023 Free Software Foundation, Inc.
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.
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.
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/>.
16 # An ANSI terminal emulator for expect.
19 # Size of the terminal.
23 # Buffer / contents of the terminal.
26 # Position of the cursor.
34 variable _resize_count
40 # Call BODY, then log WHAT along with the original and new cursor position.
41 proc _log_cur { what body } {
45 set orig_cur_row $_cur_row
46 set orig_cur_col $_cur_col
50 _log "$what, cursor: ($orig_cur_row, $orig_cur_col) -> ($_cur_row, $_cur_col)"
53 # If ARG is empty, return DEF: otherwise ARG. This is useful for
54 # defaulting arguments in CSIs.
55 proc _default {arg def} {
62 # Erase in the line Y from SX to just before EX.
63 proc _clear_in_line {sx ex y} {
66 set lattr [array get _attrs]
68 set _chars($sx,$y) [list " " $lattr]
73 # Erase the lines from SY to just before EY.
74 proc _clear_lines {sy ey} {
77 _clear_in_line 0 $_cols $sy
88 _log_cur "Backspace" {
99 _log_cur "Line feed" {
104 if {$_cur_row >= $_rows} {
112 _log_cur "Carriage return" {
121 # https://vt100.net/docs/vt510-rm/ICH.html
123 set n [_default [lindex $args 0] 1]
125 _log_cur "Insert Character ($n)" {
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)
138 # Write N blank spaces starting from the cursor.
139 _clear_in_line $_cur_col [expr $_cur_col + $n] $_cur_row
145 # https://vt100.net/docs/vt510-rm/CUU.html
147 set arg [_default [lindex $args 0] 1]
149 _log_cur "Cursor Up ($arg)" {
152 set _cur_row [expr {max ($_cur_row - $arg, 0)}]
158 # https://vt100.net/docs/vt510-rm/CUD.html
160 set arg [_default [lindex $args 0] 1]
162 _log_cur "Cursor Down ($arg)" {
166 set _cur_row [expr {min ($_cur_row + $arg, $_rows - 1)}]
172 # https://vt100.net/docs/vt510-rm/CUF.html
174 set arg [_default [lindex $args 0] 1]
176 _log_cur "Cursor Forward ($arg)" {
180 set _cur_col [expr {min ($_cur_col + $arg, $_cols - 1)}]
186 # https://vt100.net/docs/vt510-rm/CUB.html
188 set arg [_default [lindex $args 0] 1]
190 _log_cur "Cursor Backward ($arg)" {
193 set _cur_col [expr {max ($_cur_col - $arg, 0)}]
199 # https://vt100.net/docs/vt510-rm/CNL.html
201 set arg [_default [lindex $args 0] 1]
203 _log_cur "Cursor Next Line ($arg)" {
209 set _cur_row [expr {min ($_cur_row + $arg, $_rows - 1)}]
213 # Cursor Previous Line.
215 # https://vt100.net/docs/vt510-rm/CPL.html
217 set arg [_default [lindex $args 0] 1]
219 _log_cur "Cursor Previous Line ($arg)" {
225 set _cur_row [expr {max ($_cur_row - $arg, 0)}]
229 # Cursor Horizontal Absolute.
231 # https://vt100.net/docs/vt510-rm/CHA.html
233 set arg [_default [lindex $args 0] 1]
235 _log_cur "Cursor Horizontal Absolute ($arg)" {
239 set _cur_col [expr {min ($arg - 1, $_cols)}]
245 # https://vt100.net/docs/vt510-rm/CUP.html
247 set row [_default [lindex $args 0] 1]
248 set col [_default [lindex $args 1] 1]
250 _log_cur "Cursor Position ($row, $col)" {
254 set _cur_row [expr {$row - 1}]
255 set _cur_col [expr {$col - 1}]
259 # Cursor Horizontal Forward Tabulation.
261 # https://vt100.net/docs/vt510-rm/CHT.html
263 set n [_default [lindex $args 0] 1]
265 _log_cur "Cursor Horizontal Forward Tabulation ($n)" {
269 incr _cur_col [expr {$n * 8 - $_cur_col % 8}]
270 if {$_cur_col >= $_cols} {
271 set _cur_col [expr {$_cols - 1}]
278 # https://vt100.net/docs/vt510-rm/ED.html
280 set arg [_default [lindex $args 0] 0]
282 _log_cur "Erase in Display ($arg)" {
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} {
298 _clear_lines 0 $_rows
305 # https://vt100.net/docs/vt510-rm/EL.html
307 set arg [_default [lindex $args 0] 0]
309 _log_cur "Erase in Line ($arg)" {
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} {
322 _clear_in_line 0 $_cols $_cur_row
329 # https://vt100.net/docs/vt510-rm/IL.html
331 set arg [_default [lindex $args 0] 1]
333 _log_cur "Insert Line ($arg)" {
340 set y [expr $_rows - 2]
341 set next_y [expr $y + $arg]
342 while {$y >= $_cur_row} {
343 for {set x 0} {$x < $_cols} {incr x} {
344 set _chars($x,$next_y) $_chars($x,$y)
350 _clear_lines $_cur_row [expr $_cur_row + $arg]
356 # https://vt100.net/docs/vt510-rm/DL.html
358 set count [_default [lindex $args 0] 1]
360 _log_cur "Delete line ($count)" {
367 set next_y [expr {$y + $count}]
368 while {$next_y < $_rows} {
369 for {set x 0} {$x < $_cols} {incr x} {
370 set _chars($x,$y) $_chars($x,$next_y)
375 _clear_lines $y $_rows
381 # https://vt100.net/docs/vt510-rm/DCH.html
383 set count [_default [lindex $args 0] 1]
385 _log_cur "Delete character ($count)" {
391 # Move all characters right of the cursor N positions left.
392 set out_col [expr $_cur_col]
393 set in_col [expr $_cur_col + $count]
395 while {$in_col < $_cols} {
396 set _chars($out_col,$_cur_row) $_chars($in_col,$_cur_row)
401 # Clear the rest of the line.
402 _clear_in_line $out_col $_cols $_cur_row
408 # https://vt100.net/docs/vt510-rm/SU.html
410 set count [_default [lindex $args 0] 1]
412 _log_cur "Pan Down ($count)" {
419 # The following code is written without consideration for
420 # the scroll margins. At this time this comment was
421 # written the tuiterm library doesn't support the scroll
422 # margins. If/when that changes, then the following will
423 # need to be updated.
428 while {$y < $_rows} {
429 for {set x 0} {$x < $_cols} {incr x} {
430 set _chars($x,$dy) $_chars($x,$y)
436 _clear_lines $dy $_rows
442 # https://vt100.net/docs/vt510-rm/SD.html
444 set count [_default [lindex $args 0] 1]
446 _log_cur "Pan Up ($count)" {
453 # The following code is written without consideration for
454 # the scroll margins. At this time this comment was
455 # written the tuiterm library doesn't support the scroll
456 # margins. If/when that changes, then the following will
457 # need to be updated.
459 set y [expr $_rows - $count]
462 while {$dy >= $count} {
463 for {set x 0} {$x < $_cols} {incr x} {
464 set _chars($x,$dy) $_chars($x,$y)
470 _clear_lines 0 $count
476 # https://vt100.net/docs/vt510-rm/ECH.html
478 set n [_default [lindex $args 0] 1]
480 _log_cur "Erase chars ($n)" {
481 # Erase characters but don't move cursor.
487 set lattr [array get _attrs]
489 for {set i 0} {$i < $n} {incr i} {
490 set _chars($x,$_cur_row) [list " " $lattr]
496 # Cursor Backward Tabulation.
498 # https://vt100.net/docs/vt510-rm/CBT.html
500 set n [_default [lindex $args 0] 1]
502 _log_cur "Cursor Backward Tabulation ($n)" {
505 set _cur_col [expr {max (int (($_cur_col - 1) / 8) * 8 - ($n - 1) * 8, 0)}]
511 # https://www.xfree86.org/current/ctlseqs.html (See `(REP)`)
513 set n [_default [lindex $args 0] 1]
515 _log_cur "Repeat ($n)" {
518 _insert [string repeat $_last_char $n]
522 # Vertical Line Position Absolute.
524 # https://vt100.net/docs/vt510-rm/VPA.html
526 set row [_default [lindex $args 0] 1]
528 _log_cur "Vertical Line Position Absolute ($row)" {
532 set _cur_row [expr min ($row - 1, $_rows - 1)]
536 # Select Graphic Rendition.
538 # https://vt100.net/docs/vt510-rm/SGR.html
540 _log_cur "Select Graphic Rendition ([join $args {, }])" {
544 switch -exact -- $item {
546 set _attrs(intensity) normal
547 set _attrs(fg) default
548 set _attrs(bg) default
549 set _attrs(underline) 0
550 set _attrs(reverse) 0
553 set _attrs(intensity) bold
556 set _attrs(intensity) dim
559 set _attrs(underline) 1
562 set _attrs(reverse) 1
565 set _attrs(intensity) normal
568 set _attrs(underline) 0
571 set _attrs(reverse) 1
573 30 - 31 - 32 - 33 - 34 - 35 - 36 - 37 {
577 set _attrs(fg) default
579 40 - 41 - 42 - 43 - 44 - 45 - 46 - 47 {
583 set _attrs(bg) default
590 # Insert string at the cursor location.
592 _log_cur "Inserted string '$str'" {
593 _log "Inserting string '$str'"
601 set lattr [array get _attrs]
602 foreach char [split $str {}] {
603 _log_cur " Inserted char '$char'" {
604 set _chars($_cur_col,$_cur_row) [list $char $lattr]
606 if {$_cur_col >= $_cols} {
609 if {$_cur_row >= $_rows} {
618 # Move the cursor to the (0-based) COL and ROW positions.
619 proc _move_cursor { col row } {
625 if { $col < 0 || $col >= $_cols } {
626 error "_move_cursor: invalid col value: $col"
629 if { $row < 0 || $row >= $_rows } {
630 error "_move_cursor: invalid row value: $row"
639 proc _setup {rows cols} {
641 set stty_init "rows $rows columns $cols"
648 variable _resize_count
663 _clear_lines 0 $_rows
666 # Accept some output from gdb and update the screen.
667 # Return 1 if successful, or 0 if a timeout occurred.
668 proc accept_gdb_output { } {
671 -re "^\[\x07\x08\x0a\x0d\]" {
672 scan $expect_out(0,string) %c val
673 set hexval [format "%02x" $val]
674 _log "wait_for: _ctl_0x${hexval}"
677 -re "^\x1b(\[0-9a-zA-Z\])" {
678 _log "wait_for: unsupported escape"
679 error "unsupported escape"
681 -re "^\x1b\\\[(\[0-9;\]*)(\[a-zA-Z@\])" {
682 set cmd $expect_out(2,string)
683 set params [split $expect_out(1,string) ";"]
684 _log "wait_for: _csi_$cmd <<<$expect_out(1,string)>>>"
685 eval _csi_$cmd $params
687 -re "^\[^\x07\x08\x0a\x0d\x1b\]+" {
688 _insert $expect_out(0,string)
690 set _last_char [string index $expect_out(0,string) end]
694 # Assume a timeout means we somehow missed the
695 # expected result, and carry on.
703 # Accept some output from gdb and update the screen. WAIT_FOR is
704 # a regexp matching the line to wait for. Return 0 on timeout, 1
706 proc wait_for {wait_for} {
711 set prompt_wait_for "$gdb_prompt \$"
714 if { [accept_gdb_output] == 0 } {
718 # If the cursor appears just after the prompt, return. It
719 # isn't reliable to check this only after an insertion,
720 # because curses may make "unusual" redrawing decisions.
721 if {$wait_for == "$prompt_wait_for"} {
722 set prev [get_line $_cur_row $_cur_col]
724 set prev [get_line $_cur_row]
726 if {[regexp -- $wait_for $prev]} {
727 if {$wait_for == "$prompt_wait_for"} {
730 set wait_for $prompt_wait_for
737 # Accept some output from gdb and update the screen. Wait for the screen
738 # region X/Y/WIDTH/HEIGTH to matches REGEXP. Return 0 on timeout, 1 on
740 proc wait_for_region_contents {x y width height regexp} {
742 if { [accept_gdb_output] == 0 } {
746 if { [check_region_contents_p $x $y $width $height $regexp] } {
754 # Like ::clean_restart, but ensures that gdb starts in an
755 # environment where the TUI can work. ROWS and COLS are the size
756 # of the terminal. EXECUTABLE, if given, is passed to
758 proc clean_restart {rows cols {executable {}}} {
760 save_vars {env(TERM) stty_init ::GDBFLAGS} {
764 # Make GDB not print the directory names. Use this setting to
765 # remove the differences in test runs due to varying directory
767 append ::GDBFLAGS " -ex \"set filename-display basename\""
769 if {$executable == ""} {
772 ::clean_restart $executable
774 ::gdb_test_no_output "set pagination off"
778 # Setup ready for starting the tui, but don't actually start it.
779 # Returns 1 on success, 0 if TUI tests should be skipped.
780 proc prepare_for_tui {} {
781 if {[skip_tui_tests]} {
785 gdb_test_no_output "set tui border-kind ascii"
786 gdb_test_no_output "maint set tui-resize-message on"
790 # Start the TUI. Returns 1 on success, 0 if TUI tests should be
793 if {![prepare_for_tui]} {
797 command_no_prompt_prefix "tui enable"
801 # Send the command CMD to gdb, then wait for a gdb prompt to be
802 # seen in the TUI. CMD should not end with a newline -- that will
803 # be supplied by this function.
807 set str [string_to_regexp $cmd]
808 set str "^$gdb_prompt $str"
812 # As proc command, but don't wait for a initial prompt. This is used for
813 # inital terminal commands, where there's no prompt yet.
814 proc command_no_prompt_prefix {cmd} {
816 set str [string_to_regexp $cmd]
820 # Return the text of screen line N, without attributes. Lines are
821 # 0-based. If C is given, stop before column C. Columns are also
823 proc get_line {n {c ""}} {
825 # This can happen during resizing, if the cursor seems to
826 # temporarily be off-screen.
834 set c [_default $c $_cols]
837 append result [lindex $_chars($x,$n) 0]
843 # Get just the character at (X, Y).
844 proc get_char {x y} {
846 return [lindex $_chars($x,$y) 0]
849 # Get the entire screen as a string.
850 proc get_all_lines {} {
856 for {set y 0} {$y < $_rows} {incr y} {
857 for {set x 0} {$x < $_cols} {incr x} {
858 append result [lindex $_chars($x,$y) 0]
866 # Get the text just before the cursor.
867 proc get_current_line {} {
870 return [get_line $_cur_row $_cur_col]
873 # Helper function for check_box. Returns empty string if the box
874 # is found, description of why not otherwise.
875 proc _check_box {x y width height} {
876 set x2 [expr {$x + $width - 1}]
877 set y2 [expr {$y + $height - 1}]
879 verbose -log "_check_box x=$x, y=$y, x2=$x2, y2=$y2, width=$width, height=$height"
881 set c [get_char $x $y]
883 return "ul corner is $c, not +"
886 set c [get_char $x $y2]
888 return "ll corner is $c, not +"
891 set c [get_char $x2 $y]
893 return "ur corner is $c, not +"
896 set c [get_char $x2 $y2]
898 return "lr corner is $c, not +"
901 # Note we do not check the full horizonal borders of the box.
902 # The top will contain a title, and the bottom may as well, if
903 # it is overlapped by some other border. However, at most a
904 # title should appear as '+-VERY LONG TITLE-+', so we can
905 # check for the '+-' on the left, and '-+' on the right.
906 set c [get_char [expr {$x + 1}] $y]
908 return "ul title padding is $c, not -"
911 set c [get_char [expr {$x2 - 1}] $y]
913 return "ul title padding is $c, not -"
916 # Now check the vertical borders.
917 for {set i [expr {$y + 1}]} {$i < $y2 - 1} {incr i} {
918 set c [get_char $x $i]
920 return "left side $i is $c, not |"
923 set c [get_char $x2 $i]
925 return "right side $i is $c, not |"
932 # Check for a box at the given coordinates.
933 proc check_box {test_name x y width height} {
934 dump_box $x $y $width $height
935 set why [_check_box $x $y $width $height]
939 fail "$test_name ($why)"
943 # Check whether the text contents of the terminal match the
944 # regular expression. Note that text styling is not considered.
945 proc check_contents {test_name regexp} {
947 set contents [get_all_lines]
948 gdb_assert {[regexp -- $regexp $contents]} $test_name
951 # Get the region of the screen described by X, Y, WIDTH,
952 # and HEIGHT, and separate the lines using SEP.
953 proc get_region { x y width height sep } {
956 # Grab the contents of the box, join each line together
959 for {set yy $y} {$yy < [expr {$y + $height}]} {incr yy} {
961 # Add the end of line sequence only if this isn't the
965 for {set xx $x} {$xx < [expr {$x + $width}]} {incr xx} {
966 append result [lindex $_chars($xx,$yy) 0]
972 # Check that the region of the screen described by X, Y, WIDTH,
973 # and HEIGHT match REGEXP. This is like check_contents except
974 # only part of the screen is checked. This can be used to check
975 # the contents within a box (though check_box_contents is a better
976 # choice for boxes with a border). Return 1 if check succeeded.
977 proc check_region_contents_p { x y width height regexp } {
979 dump_box $x $y $width $height
981 # Now grab the contents of the box, join each line together
982 # with a '\r\n' sequence and match against REGEXP.
983 set result [get_region $x $y $width $height "\r\n"]
984 return [regexp -- $regexp $result]
987 # Check that the region of the screen described by X, Y, WIDTH,
988 # and HEIGHT match REGEXP. As check_region_contents_p, but produce
989 # a pass/fail message.
990 proc check_region_contents { test_name x y width height regexp } {
991 set ok [check_region_contents_p $x $y $width $height $regexp]
992 gdb_assert {$ok} $test_name
995 # Check the contents of a box on the screen. This is a little
996 # like check_contents, but doens't check the whole screen
997 # contents, only the contents of a single box. This procedure
998 # includes (effectively) a call to check_box to ensure there is a
999 # box where expected, if there is then the contents of the box are
1000 # matched against REGEXP.
1001 proc check_box_contents {test_name x y width height regexp} {
1004 dump_box $x $y $width $height
1005 set why [_check_box $x $y $width $height]
1007 fail "$test_name (box check: $why)"
1011 check_region_contents $test_name [expr {$x + 1}] [expr {$y + 1}] \
1012 [expr {$width - 2}] [expr {$height - 2}] $regexp
1015 # A debugging function to dump the current screen, with line
1017 proc dump_screen {} {
1023 verbose -log "Screen Dump (size $_cols columns x $_rows rows, cursor at column $_cur_col, row $_cur_row):"
1025 for {set y 0} {$y < $_rows} {incr y} {
1026 set fmt [format %5d $y]
1027 verbose -log "$fmt [get_line $y]"
1031 # A debugging function to dump a box from the current screen, with line
1033 proc dump_box { x y width height } {
1034 verbose -log "Box Dump ($width x $height) @ ($x, $y):"
1035 set region [get_region $x $y $width $height "\n"]
1036 set lines [split $region "\n"]
1038 foreach line $lines {
1039 set fmt [format %5d $nr]
1040 verbose -log "$fmt $line"
1045 # Resize the terminal.
1046 proc _do_resize {rows cols} {
1051 set old_rows [expr {min ($_rows, $rows)}]
1052 set old_cols [expr {min ($_cols, $cols)}]
1055 array set local_chars [array get _chars]
1060 _clear_lines 0 $_rows
1062 for {set x 0} {$x < $old_cols} {incr x} {
1063 for {set y 0} {$y < $old_rows} {incr y} {
1064 set _chars($x,$y) $local_chars($x,$y)
1069 proc resize {rows cols} {
1072 variable _resize_count
1074 # expect handles each argument to stty separately. This means
1075 # that gdb will see SIGWINCH twice. Rather than rely on this
1076 # behavior (which, after all, could be changed), we make it
1077 # explicit here. This also simplifies waiting for the redraw.
1078 _do_resize $rows $_cols
1079 stty rows $_rows < $::gdb_tty_name
1080 # Due to the strange column resizing behavior, and because we
1081 # don't care about this intermediate resize, we don't check
1083 wait_for "@@ resize done $_resize_count"
1085 # Somehow the number of columns transmitted to gdb is one less
1086 # than what we request from expect. We hide this weird
1087 # details from the caller.
1088 _do_resize $_rows $cols
1089 stty columns [expr {$_cols + 1}] < $::gdb_tty_name
1090 wait_for "@@ resize done $_resize_count, size = ${_cols}x${rows}"