1 # Copyright 2019-2021 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.
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]
25 upvar spawn_out spawn_out
26 if { [info exists spawn_out] } {
27 set gdb_spawn_name $spawn_out(slave,name)
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
41 # Finalize tuiterm.exp environment.
42 proc tuiterm_env_finish { } {
44 rename spawn tuiterm_spawn
45 rename builtin_spawn spawn
49 # Size of the terminal.
53 # Buffer / contents of the terminal.
56 # Position of the cursor.
64 variable _resize_count
67 verbose -log "+++ $what"
70 # Call BODY, then log WHAT along with the original and new cursor position.
71 proc _log_cur { what body } {
75 set orig_cur_row $_cur_row
76 set orig_cur_col $_cur_col
80 _log "$what, cursor: ($orig_cur_row, $orig_cur_col) -> ($_cur_row, $_cur_col)"
83 # If ARG is empty, return DEF: otherwise ARG. This is useful for
84 # defaulting arguments in CSIs.
85 proc _default {arg def} {
92 # Erase in the line Y from SX to just before EX.
93 proc _clear_in_line {sx ex y} {
96 set lattr [array get _attrs]
98 set _chars($sx,$y) [list " " $lattr]
103 # Erase the lines from SY to just before EY.
104 proc _clear_lines {sy ey} {
107 _clear_in_line 0 $_cols $sy
118 _log_cur "Backspace" {
126 set _cur_col [expr {$_cols - 1}]
137 _log_cur "Line feed" {
142 if {$_cur_row >= $_rows} {
150 _log_cur "Carriage return" {
159 # https://vt100.net/docs/vt510-rm/ICH.html
161 set n [_default [lindex $args 0] 1]
163 _log_cur "Insert Character ($n)" {
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)
180 # https://vt100.net/docs/vt510-rm/CUU.html
182 set arg [_default [lindex $args 0] 1]
184 _log_cur "Cursor Up ($arg)" {
187 set _cur_row [expr {max ($_cur_row - $arg, 0)}]
193 # https://vt100.net/docs/vt510-rm/CUD.html
195 set arg [_default [lindex $args 0] 1]
197 _log_cur "Cursor Down ($arg)" {
201 set _cur_row [expr {min ($_cur_row + $arg, $_rows)}]
207 # https://vt100.net/docs/vt510-rm/CUF.html
209 set arg [_default [lindex $args 0] 1]
211 _log_cur "Cursor Forward ($arg)" {
215 set _cur_col [expr {min ($_cur_col + $arg, $_cols)}]
221 # https://vt100.net/docs/vt510-rm/CUB.html
223 set arg [_default [lindex $args 0] 1]
225 _log_cur "Cursor Backward ($arg)" {
228 set _cur_col [expr {max ($_cur_col - $arg, 0)}]
234 # https://vt100.net/docs/vt510-rm/CNL.html
236 set arg [_default [lindex $args 0] 1]
238 _log_cur "Cursor Next Line ($arg)" {
244 set _cur_row [expr {min ($_cur_row + $arg, $_rows)}]
248 # Cursor Previous Line.
250 # https://vt100.net/docs/vt510-rm/CPL.html
252 set arg [_default [lindex $args 0] 1]
254 _log_cur "Cursor Previous Line ($arg)" {
260 set _cur_row [expr {max ($_cur_row - $arg, 0)}]
264 # Cursor Horizontal Absolute.
266 # https://vt100.net/docs/vt510-rm/CHA.html
268 set arg [_default [lindex $args 0] 1]
270 _log_cur "Cursor Horizontal Absolute ($arg)" {
274 set _cur_col [expr {min ($arg - 1, $_cols)}]
280 # https://vt100.net/docs/vt510-rm/CUP.html
282 set row [_default [lindex $args 0] 1]
283 set col [_default [lindex $args 1] 1]
285 _log_cur "Cursor Position ($row, $col)" {
289 set _cur_row [expr {$row - 1}]
290 set _cur_col [expr {$col - 1}]
294 # Cursor Horizontal Forward Tabulation.
296 # https://vt100.net/docs/vt510-rm/CHT.html
298 set n [_default [lindex $args 0] 1]
300 _log_cur "Cursor Horizontal Forward Tabulation ($n)" {
304 incr _cur_col [expr {$n * 8 - $_cur_col % 8}]
305 if {$_cur_col >= $_cols} {
306 set _cur_col [expr {$_cols - 1}]
313 # https://vt100.net/docs/vt510-rm/ED.html
315 set arg [_default [lindex $args 0] 0]
317 _log_cur "Erase in Display ($arg)" {
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
337 # https://vt100.net/docs/vt510-rm/EL.html
339 set arg [_default [lindex $args 0] 0]
341 _log_cur "Erase in Line ($arg)" {
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
359 # https://vt100.net/docs/vt510-rm/DL.html
361 set count [_default [lindex $args 0] 1]
363 _log_cur "Delete line ($count)" {
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)
378 _clear_lines $y $_rows
384 # https://vt100.net/docs/vt510-rm/ECH.html
386 set n [_default [lindex $args 0] 1]
388 _log_cur "Erase chars ($n)" {
389 # Erase characters but don't move cursor.
395 set lattr [array get _attrs]
397 for {set i 0} {$i < $n} {incr i} {
398 set _chars($x,$_cur_row) [list " " $lattr]
404 # Cursor Backward Tabulation.
406 # https://vt100.net/docs/vt510-rm/CBT.html
408 set n [_default [lindex $args 0] 1]
410 _log_cur "Cursor Backward Tabulation ($n)" {
413 set _cur_col [expr {max (int (($_cur_col - 1) / 8) * 8 - ($n - 1) * 8, 0)}]
419 # https://www.xfree86.org/current/ctlseqs.html (See `(REP)`)
421 set n [_default [lindex $args 0] 1]
423 _log_cur "Repeat ($n)" {
426 _insert [string repeat $_last_char $n]
430 # Vertical Line Position Absolute.
432 # https://vt100.net/docs/vt510-rm/VPA.html
434 set row [_default [lindex $args 0] 1]
436 _log_cur "Vertical Line Position Absolute ($row)" {
439 set _cur_row [expr {$row - 1}]
443 # Select Graphic Rendition.
445 # https://vt100.net/docs/vt510-rm/SGR.html
447 _log_cur "Select Graphic Rendition ([join $args {, }])" {
451 switch -exact -- $item {
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
460 set _attrs(intensity) bold
463 set _attrs(intensity) dim
466 set _attrs(underline) 1
469 set _attrs(reverse) 1
472 set _attrs(intensity) normal
475 set _attrs(underline) 0
478 set _attrs(reverse) 1
480 30 - 31 - 32 - 33 - 34 - 35 - 36 - 37 {
484 set _attrs(fg) default
486 40 - 41 - 42 - 43 - 44 - 45 - 46 - 47 {
490 set _attrs(bg) default
497 # Insert string at the cursor location.
499 _log_cur "Inserted string '$str'" {
500 _log "Inserting string '$str'"
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]
513 if {$_cur_col >= $_cols} {
516 if {$_cur_row >= $_rows} {
526 proc _setup {rows cols} {
528 set stty_init "rows $rows columns $cols"
535 variable _resize_count
550 _clear_lines 0 $_rows
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
556 proc wait_for {wait_for} {
562 set prompt_wait_for "$gdb_prompt \$"
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}"
572 -re "^\x1b(\[0-9a-zA-Z\])" {
573 _log "wait_for: unsupported escape"
574 error "unsupported escape"
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
582 -re "^\[^\x07\x08\x0a\x0d\x1b\]+" {
583 _insert $expect_out(0,string)
585 set _last_char [string index $expect_out(0,string) end]
589 # Assume a timeout means we somehow missed the
590 # expected result, and carry on.
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]
601 set prev [get_line $_cur_row]
603 if {[regexp -- $wait_for $prev]} {
604 if {$wait_for == "$prompt_wait_for"} {
607 set wait_for $prompt_wait_for
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
618 proc clean_restart {rows cols {executable {}}} {
620 save_vars {env(TERM) stty_init} {
623 if {$executable == ""} {
626 ::clean_restart $executable
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]} {
638 gdb_test_no_output "set tui border-kind ascii"
639 gdb_test_no_output "maint set tui-resize-message on"
643 # Start the TUI. Returns 1 on success, 0 if TUI tests should be
646 if {![prepare_for_tui]} {
650 command_no_prompt_prefix "tui enable"
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.
660 set str [string_to_regexp $cmd]
661 set str "^$gdb_prompt $str"
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} {
669 set str [string_to_regexp $cmd]
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
676 proc get_line {n {c ""}} {
678 # This can happen during resizing, if the cursor seems to
679 # temporarily be off-screen.
687 set c [_default $c $_cols]
690 append result [lindex $_chars($x,$n) 0]
696 # Get just the character at (X, Y).
697 proc get_char {x y} {
699 return [lindex $_chars($x,$y) 0]
702 # Get the entire screen as a string.
703 proc get_all_lines {} {
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]
719 # Get the text just before the cursor.
720 proc get_current_line {} {
723 return [get_line $_cur_row $_cur_col]
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}]
732 verbose -log "_check_box x=$x, y=$y, x2=$x2, y2=$y2, width=$width, height=$height"
734 set c [get_char $x $y]
736 return "ul corner is $c, not +"
739 set c [get_char $x $y2]
741 return "ll corner is $c, not +"
744 set c [get_char $x2 $y]
746 return "ur corner is $c, not +"
749 set c [get_char $x2 $y2]
751 return "lr corner is $c, not +"
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]
761 return "ul title padding is $c, not -"
764 set c [get_char [expr {$x2 - 1}] $y]
766 return "ul title padding is $c, not -"
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]
773 return "left side $i is $c, not |"
776 set c [get_char $x2 $i]
778 return "right side $i is $c, not |"
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]
792 fail "$test_name ($why)"
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]} {
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 } {
813 # Now grab the contents of the box, join each line together
814 # with a '\r\n' sequence and match against REGEXP.
816 for {set yy $y} {$yy < [expr {$y + $height}]} {incr yy} {
818 # Add the end of line sequence only if this isn't the
822 for {set xx $x} {$xx < [expr {$x + $width}]} {incr xx} {
823 append result [lindex $_chars($xx,$yy) 0]
827 if {![gdb_assert {[regexp -- $regexp $result]} $test_name]} {
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} {
841 set why [_check_box $x $y $width $height]
844 fail "$test_name (box check: $why)"
848 check_region_contents $test_name [expr {$x + 1}] [expr {$y + 1}] \
849 [expr {$width - 2}] [expr {$height - 2}] $regexp
852 # A debugging function to dump the current screen, with line
854 proc dump_screen {} {
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]"
864 # Resize the terminal.
865 proc _do_resize {rows cols} {
870 set old_rows [expr {min ($_rows, $rows)}]
871 set old_cols [expr {min ($_cols, $cols)}]
874 array set local_chars [array get _chars]
879 _clear_lines 0 $_rows
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)
888 proc resize {rows cols} {
891 variable _resize_count
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
903 wait_for "@@ resize done $_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}"