1 # Copyright 2019-2020 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
60 variable _resize_count
62 # If ARG is empty, return DEF: otherwise ARG. This is useful for
63 # defaulting arguments in CSIs.
64 proc _default {arg def} {
71 # Erase in the line Y from SX to just before EX.
72 proc _clear_in_line {sx ex y} {
75 set lattr [array get _attrs]
77 set _chars($sx,$y) [list " " $lattr]
82 # Erase the lines from SY to just before EY.
83 proc _clear_lines {sy ey} {
86 _clear_in_line 0 $_cols $sy
102 set _cur_x [expr {$_cols - 1}]
115 if {$_cur_y >= $_rows} {
126 # Make room for characters.
128 set n [_default [lindex $args 0] 1]
133 set out_x [expr {$_cur_x + $n}]
134 for {set i 0} {$i < $n} {incr i} {
135 set _chars($out_x,$_cur_y) $_chars($in_x,$_cur_y)
144 set arg [_default [lindex $args 0] 1]
145 set _cur_y [expr {max ($_cur_y - $arg, 0)}]
152 set arg [_default [lindex $args 0] 1]
153 set _cur_y [expr {min ($_cur_y + $arg, $_rows)}]
160 set arg [_default [lindex $args 0] 1]
161 set _cur_x [expr {min ($_cur_x + $arg, $_cols)}]
167 set arg [_default [lindex $args 0] 1]
168 set _cur_x [expr {max ($_cur_x - $arg, 0)}]
176 set arg [_default [lindex $args 0] 1]
178 set _cur_y [expr {min ($_cur_y + $arg, $_rows)}]
181 # Cursor Previous Line.
186 set arg [_default [lindex $args 0] 1]
188 set _cur_y [expr {max ($_cur_y - $arg, 0)}]
191 # Cursor Horizontal Absolute.
195 set arg [_default [lindex $args 0] 1]
196 set _cur_x [expr {min ($arg - 1, $_cols)}]
199 # Move cursor (don't know the official name of this one).
203 set _cur_y [expr {[_default [lindex $args 0] 1] - 1}]
204 set _cur_x [expr {[_default [lindex $args 1] 1] - 1}]
207 # Cursor Forward Tabulation.
209 set n [_default [lindex $args 0] 1]
212 incr _cur_x [expr {$n * 8 - $_cur_x % 8}]
213 if {$_cur_x >= $_cols} {
214 set _cur_x [expr {$_cols - 1}]
224 set arg [_default [lindex $args 0] 0]
226 _clear_in_line $_cur_x $_cols $_cur_y
227 _clear_lines [expr {$_cur_y + 1}] $_rows
228 } elseif {$arg == 1} {
229 _clear_lines 0 [expr {$_cur_y - 1}]
230 _clear_in_line 0 $_cur_x $_cur_y
231 } elseif {$arg == 2} {
232 _clear_lines 0 $_rows
241 set arg [_default [lindex $args 0] 0]
243 # From cursor to end.
244 _clear_in_line $_cur_x $_cols $_cur_y
245 } elseif {$arg == 1} {
246 _clear_in_line 0 $_cur_x $_cur_y
247 } elseif {$arg == 2} {
248 _clear_in_line 0 $_cols $_cur_y
258 set count [_default [lindex $args 0] 1]
260 set next_y [expr {$y + 1}]
261 while {$count > 0 && $next_y < $_rows} {
262 for {set x 0} {$x < $_cols} {incr x} {
263 set _chars($x,$y) $_chars($x,$next_y)
269 _clear_lines $next_y $_rows
274 set n [_default [lindex $args 0] 1]
275 # Erase characters but don't move cursor.
280 set lattr [array get _attrs]
282 for {set i 0} {$i < $n} {incr i} {
283 set _chars($x,$_cur_y) [list " " $lattr]
288 # Backward tab stops.
290 set n [_default [lindex $args 0] 1]
292 set _cur_x [expr {max (int (($_cur_x - 1) / 8) * 8 - ($n - 1) * 8, 0)}]
298 set n [_default [lindex $args 0] 1]
299 _insert [string repeat $_last_char $n]
302 # Line Position Absolute.
305 set _cur_y [expr {[_default [lindex $args 0] 1] - 1}]
308 # Select Graphic Rendition.
312 switch -exact -- $item {
314 set _attrs(intensity) normal
315 set _attrs(fg) default
316 set _attrs(bg) default
317 set _attrs(underline) 0
318 set _attrs(reverse) 0
321 set _attrs(intensity) bold
324 set _attrs(intensity) dim
327 set _attrs(underline) 1
330 set _attrs(reverse) 1
333 set _attrs(intensity) normal
336 set _attrs(underline) 0
339 set _attrs(reverse) 1
341 30 - 31 - 32 - 33 - 34 - 35 - 36 - 37 {
345 set _attrs(fg) default
347 40 - 41 - 42 - 43 - 44 - 45 - 46 - 47 {
351 set _attrs(bg) default
357 # Insert string at the cursor location.
359 verbose "INSERT <<$str>>"
366 set lattr [array get _attrs]
367 foreach char [split $str {}] {
368 set _chars($_cur_x,$_cur_y) [list $char $lattr]
370 if {$_cur_x >= $_cols} {
373 if {$_cur_y >= $_rows} {
381 proc _setup {rows cols} {
383 set stty_init "rows $rows columns $cols"
390 variable _resize_count
405 _clear_lines 0 $_rows
408 # Accept some output from gdb and update the screen. WAIT_FOR is
409 # a regexp matching the line to wait for. Return 0 on timeout, 1
411 proc wait_for {wait_for} {
417 set prompt_wait_for "$gdb_prompt \$"
421 -re "^\[\x07\x08\x0a\x0d\]" {
422 scan $expect_out(0,string) %c val
423 set hexval [format "%02x" $val]
424 verbose "+++ _ctl_0x${hexval}"
427 -re "^\x1b(\[0-9a-zA-Z\])" {
428 verbose "+++ unsupported escape"
429 error "unsupported escape"
431 -re "^\x1b\\\[(\[0-9;\]*)(\[a-zA-Z@\])" {
432 set cmd $expect_out(2,string)
433 set params [split $expect_out(1,string) ";"]
434 verbose "+++ _csi_$cmd <<<$expect_out(1,string)>>>"
435 eval _csi_$cmd $params
437 -re "^\[^\x07\x08\x0a\x0d\x1b\]+" {
438 _insert $expect_out(0,string)
440 set _last_char [string index $expect_out(0,string) end]
444 # Assume a timeout means we somehow missed the
445 # expected result, and carry on.
450 # If the cursor appears just after the prompt, return. It
451 # isn't reliable to check this only after an insertion,
452 # because curses may make "unusual" redrawing decisions.
453 if {$wait_for == "$prompt_wait_for"} {
454 set prev [get_line $_cur_y $_cur_x]
456 set prev [get_line $_cur_y]
458 if {[regexp -- $wait_for $prev]} {
459 if {$wait_for == "$prompt_wait_for"} {
462 set wait_for $prompt_wait_for
469 # Like ::clean_restart, but ensures that gdb starts in an
470 # environment where the TUI can work. ROWS and COLS are the size
471 # of the terminal. EXECUTABLE, if given, is passed to
473 proc clean_restart {rows cols {executable {}}} {
475 save_vars {env(TERM) stty_init} {
478 if {$executable == ""} {
481 ::clean_restart $executable
486 # Setup ready for starting the tui, but don't actually start it.
487 # Returns 1 on success, 0 if TUI tests should be skipped.
488 proc prepare_for_tui {} {
489 if {[skip_tui_tests]} {
493 gdb_test_no_output "set tui border-kind ascii"
494 gdb_test_no_output "maint set tui-resize-message on"
498 # Start the TUI. Returns 1 on success, 0 if TUI tests should be
501 if {![prepare_for_tui]} {
505 command_no_prompt_prefix "tui enable"
509 # Send the command CMD to gdb, then wait for a gdb prompt to be
510 # seen in the TUI. CMD should not end with a newline -- that will
511 # be supplied by this function.
515 set str [string_to_regexp $cmd]
516 set str "^$gdb_prompt $str"
520 # As proc command, but don't wait for a initial prompt. This is used for
521 # inital terminal commands, where there's no prompt yet.
522 proc command_no_prompt_prefix {cmd} {
524 set str [string_to_regexp $cmd]
528 # Return the text of screen line N, without attributes. Lines are
529 # 0-based. If C is given, stop before column C. Columns are also
531 proc get_line {n {c ""}} {
533 # This can happen during resizing, if the cursor seems to
534 # temporarily be off-screen.
542 set c [_default $c $_cols]
545 append result [lindex $_chars($x,$n) 0]
551 # Get just the character at (X, Y).
552 proc get_char {x y} {
554 return [lindex $_chars($x,$y) 0]
557 # Get the entire screen as a string.
558 proc get_all_lines {} {
564 for {set y 0} {$y < $_rows} {incr y} {
565 for {set x 0} {$x < $_cols} {incr x} {
566 append result [lindex $_chars($x,$y) 0]
574 # Get the text just before the cursor.
575 proc get_current_line {} {
578 return [get_line $_cur_y $_cur_x]
581 # Helper function for check_box. Returns empty string if the box
582 # is found, description of why not otherwise.
583 proc _check_box {x y width height} {
584 set x2 [expr {$x + $width - 1}]
585 set y2 [expr {$y + $height - 1}]
587 if {[get_char $x $y] != "+"} {
590 if {[get_char $x $y2] != "+"} {
593 if {[get_char $x2 $y] != "+"} {
596 if {[get_char $x2 $y2] != "+"} {
600 # Note we do not check the full horizonal borders of the box.
601 # The top will contain a title, and the bottom may as well, if
602 # it is overlapped by some other border. However, at most a
603 # title should appear as '+-VERY LONG TITLE-+', so we can
604 # check for the '+-' on the left, and '-+' on the right.
605 if {[get_char [expr {$x + 1}] $y] != "-"} {
606 return "ul title padding"
609 if {[get_char [expr {$x2 - 1}] $y] != "-"} {
610 return "ul title padding"
613 # Now check the vertical borders.
614 for {set i [expr {$y + 1}]} {$i < $y2 - 1} {incr i} {
615 if {[get_char $x $i] != "|"} {
616 return "left side $i"
618 if {[get_char $x2 $i] != "|"} {
619 return "right side $i"
626 # Check for a box at the given coordinates.
627 proc check_box {test_name x y width height} {
628 set why [_check_box $x $y $width $height]
633 fail "$test_name ($why)"
637 # Check whether the text contents of the terminal match the
638 # regular expression. Note that text styling is not considered.
639 proc check_contents {test_name regexp} {
640 set contents [get_all_lines]
641 if {![gdb_assert {[regexp -- $regexp $contents]} $test_name]} {
646 # Check the contents of a box on the screen. This is a little
647 # like check_contents, but doens't check the whole screen
648 # contents, only the contents of a single box. This procedure
649 # includes (effectively) a call to check_box to ensure there is a
650 # box where expected, if there is then the contents of the box are
651 # matched against REGEXP.
652 proc check_box_contents {test_name x y width height regexp} {
655 set why [_check_box $x $y $width $height]
658 fail "$test_name (box check: $why)"
662 # Now grab the contents of the box, join each line together
663 # with a newline character and match against REGEXP.
665 for {set yy [expr {$y + 1}]} {$yy < [expr {$y + $height - 1}]} {incr yy} {
666 for {set xx [expr {$x + 1}]} {$xx < [expr {$x + $width - 1}]} {incr xx} {
667 append result [lindex $_chars($xx,$yy) 0]
672 if {![gdb_assert {[regexp -- $regexp $result]} $test_name]} {
677 # A debugging function to dump the current screen, with line
679 proc dump_screen {} {
682 verbose -log "Screen Dump ($_cols x $_rows):"
683 for {set y 0} {$y < $_rows} {incr y} {
684 set fmt [format %5d $y]
685 verbose -log "$fmt [get_line $y]"
689 # Resize the terminal.
690 proc _do_resize {rows cols} {
695 set old_rows [expr {min ($_rows, $rows)}]
696 set old_cols [expr {min ($_cols, $cols)}]
699 array set local_chars [array get _chars]
704 _clear_lines 0 $_rows
706 for {set x 0} {$x < $old_cols} {incr x} {
707 for {set y 0} {$y < $old_rows} {incr y} {
708 set _chars($x,$y) $local_chars($x,$y)
713 proc resize {rows cols} {
716 variable _resize_count
718 global gdb_spawn_name
719 # expect handles each argument to stty separately. This means
720 # that gdb will see SIGWINCH twice. Rather than rely on this
721 # behavior (which, after all, could be changed), we make it
722 # explicit here. This also simplifies waiting for the redraw.
723 _do_resize $rows $_cols
724 stty rows $_rows < $gdb_spawn_name
725 # Due to the strange column resizing behavior, and because we
726 # don't care about this intermediate resize, we don't check
728 wait_for "@@ resize done $_resize_count"
730 # Somehow the number of columns transmitted to gdb is one less
731 # than what we request from expect. We hide this weird
732 # details from the caller.
733 _do_resize $_rows $cols
734 stty columns [expr {$_cols + 1}] < $gdb_spawn_name
735 wait_for "@@ resize done $_resize_count, size = ${_cols}x${rows}"