1 # Copyright 2019 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 rename spawn builtin_spawn
24 set result [uplevel builtin_spawn $args]
26 upvar spawn_out spawn_out
27 set gdb_spawn_name $spawn_out(slave,name)
43 # If ARG is empty, return DEF: otherwise ARG. This is useful for
44 # defaulting arguments in CSIs.
45 proc _default {arg def} {
52 # Erase in the line Y from SX to just before EX.
53 proc _clear_in_line {sx ex y} {
56 set lattr [array get _attrs]
58 set _chars($sx,$y) [list " " $lattr]
63 # Erase the lines from SY to just before EY.
64 proc _clear_lines {sy ey} {
67 _clear_in_line 0 $_cols $sy
83 set _cur_x [expr {$_cols - 1}]
96 if {$_cur_y >= $_rows} {
107 # Make room for characters.
109 set n [_default [lindex $args 0] 1]
114 set out_x [expr {$_cur_x + $n}]
115 for {set i 0} {$i < $n} {incr i} {
116 set _chars($out_x,$_cur_y) $_chars($in_x,$_cur_y)
125 set arg [_default [lindex $args 0] 1]
126 set _cur_y [expr {max ($_cur_y - $arg, 0)}]
133 set arg [_default [lindex $args 0] 1]
134 set _cur_y [expr {min ($_cur_y + $arg, $_rows)}]
141 set arg [_default [lindex $args 0] 1]
142 set _cur_x [expr {min ($_cur_x + $arg, $_cols)}]
148 set arg [_default [lindex $args 0] 1]
149 set _cur_x [expr {max ($_cur_x - $arg, 0)}]
157 set arg [_default [lindex $args 0] 1]
159 set _cur_y [expr {min ($_cur_y + $arg, $_rows)}]
162 # Cursor Previous Line.
167 set arg [_default [lindex $args 0] 1]
169 set _cur_y [expr {max ($_cur_y - $arg, 0)}]
172 # Cursor Horizontal Absolute.
176 set arg [_default [lindex $args 0] 1]
177 set _cur_x [expr {min ($arg - 1, $_cols)}]
180 # Move cursor (don't know the official name of this one).
184 set _cur_y [expr {[_default [lindex $args 0] 1] - 1}]
185 set _cur_x [expr {[_default [lindex $args 1] 1] - 1}]
188 # Cursor Forward Tabulation.
190 set n [_default [lindex $args 0] 1]
193 incr _cur_x [expr {$n * 8 - $_cur_x % 8}]
194 if {$_cur_x >= $_cols} {
195 set _cur_x [expr {$_cols - 1}]
205 set arg [_default [lindex $args 0] 0]
207 _clear_in_line $_cur_x $_cols $_cur_y
208 _clear_lines [expr {$_cur_y + 1}] $_rows
209 } elseif {$arg == 1} {
210 _clear_lines 0 [expr {$_cur_y - 1}]
211 _clear_in_line 0 $_cur_x $_cur_y
212 } elseif {$arg == 2} {
213 _clear_lines 0 $_rows
222 set arg [_default [lindex $args 0] 0]
224 # From cursor to end.
225 _clear_in_line $_cur_x $_cols $_cur_y
226 } elseif {$arg == 1} {
227 _clear_in_line 0 $_cur_x $_cur_y
228 } elseif {$arg == 2} {
229 _clear_in_line 0 $_cols $_cur_y
239 set count [_default [lindex $args 0] 1]
241 set next_y [expr {$y + 1}]
242 while {$count > 0 && $next_y < $_rows} {
243 for {set x 0} {$x < $_cols} {incr x} {
244 set _chars($x,$y) $_chars($x,$next_y)
250 _clear_lines $next_y $_rows
255 set n [_default [lindex $args 0] 1]
256 # Erase characters but don't move cursor.
261 set lattr [array get _attrs]
263 for {set i 0} {$i < $n} {incr i} {
264 set _chars($x,$_cur_y) [list " " $lattr]
269 # Backward tab stops.
271 set n [_default [lindex $args 0] 1]
273 set _cur_x [expr {max (int (($_cur_x - 1) / 8) * 8 - ($n - 1) * 8, 0)}]
279 set n [_default [lindex $args 0] 1]
280 _insert [string repeat $_last_char $n]
283 # Line Position Absolute.
286 set _cur_y [expr {[_default [lindex $args 0] 1] - 1}]
289 # Select Graphic Rendition.
293 switch -exact -- $item {
295 set _attrs(intensity) normal
296 set _attrs(fg) default
297 set _attrs(bg) default
298 set _attrs(underline) 0
299 set _attrs(reverse) 0
302 set _attrs(intensity) bold
305 set _attrs(intensity) dim
308 set _attrs(underline) 1
311 set _attrs(reverse) 1
314 set _attrs(intensity) normal
317 set _attrs(underline) 0
320 set _attrs(reverse) 1
322 30 - 31 - 32 - 33 - 34 - 35 - 36 - 37 {
326 set _attrs(fg) default
328 40 - 41 - 42 - 43 - 44 - 45 - 46 - 47 {
332 set _attrs(bg) default
338 # Insert string at the cursor location.
340 verbose "INSERT <<$str>>"
347 set lattr [array get _attrs]
348 foreach char [split $str {}] {
349 set _chars($_cur_x,$_cur_y) [list $char $lattr]
351 if {$_cur_x >= $_cols} {
354 if {$_cur_y >= $_rows} {
362 proc _setup {rows cols} {
364 set stty_init "rows $rows columns $cols"
384 _clear_lines 0 $_rows
387 # Accept some output from gdb and update the screen.
391 -re "^\[\x07\x08\x0a\x0d\]" {
392 scan $expect_out(0,string) %c val
393 set hexval [format "%02x" $val]
394 verbose "+++ _ctl_0x${hexval}"
398 -re "^\x1b(\[0-9a-zA-Z\])" {
399 verbose "+++ unsupported escape"
400 error "unsupported escape"
402 -re "^\x1b\\\[(\[0-9;\]*)(\[a-zA-Z@\])" {
403 set cmd $expect_out(2,string)
404 set params [split $expect_out(1,string) ";"]
405 verbose "+++ _csi_$cmd <<<$expect_out(1,string)>>>"
406 eval _csi_$cmd $params
409 -re "^\[^\x07\x08\x0a\x0d\x1b\]+" {
410 _insert $expect_out(0,string)
412 set _last_char [string index $expect_out(0,string) end]
413 # If the prompt was just inserted, return.
417 set prev [get_line $_cur_y $_cur_x]
418 if {![regexp -- "$gdb_prompt \$" $prev]} {
425 # Like ::clean_restart, but ensures that gdb starts in an
426 # environment where the TUI can work. ROWS and COLS are the size
427 # of the terminal. EXECUTABLE, if given, is passed to
429 proc clean_restart {rows cols {executable {}}} {
431 save_vars {env(TERM) stty_init} {
434 if {$executable == ""} {
437 ::clean_restart $executable
442 # Start the TUI. Returns 1 on success, 0 if TUI tests should be
445 if {[skip_tui_tests]} {
449 gdb_test_no_output "set tui border-kind ascii"
454 # Send the command CMD to gdb, then wait for a gdb prompt to be
455 # seen in the TUI. CMD should not end with a newline -- that will
456 # be supplied by this function.
462 # Return the text of screen line N, without attributes. Lines are
463 # 0-based. If C is given, stop before column C. Columns are also
465 proc get_line {n {c ""}} {
469 set c [_default $c $_cols]
472 append result [lindex $_chars($x,$n) 0]
478 # Get just the character at (X, Y).
479 proc get_char {x y} {
481 return [lindex $_chars($x,$y) 0]
484 # Get the entire screen as a string.
485 proc get_all_lines {} {
491 for {set y 0} {$y < $_rows} {incr y} {
492 for {set x 0} {$x < $_cols} {incr x} {
493 append result [lindex $_chars($x,$y) 0]
501 # Get the text just before the cursor.
502 proc get_current_line {} {
505 return [get_line $_cur_y $_cur_x]
508 # Helper function for check_box. Returns empty string if the box
509 # is found, description of why not otherwise.
510 proc _check_box {x y width height} {
511 set x2 [expr {$x + $width - 1}]
512 set y2 [expr {$y + $height - 1}]
514 if {[get_char $x $y] != "+"} {
517 if {[get_char $x $y2] != "+"} {
520 if {[get_char $x2 $y] != "+"} {
523 if {[get_char $x2 $y2] != "+"} {
527 for {set i [expr {$x + 1}]} {$i < $x2 - 1} {incr i} {
528 # Note we do not check the top border of the box, because
529 # it will contain a title.
530 if {[get_char $i $y2] != "-"} {
531 return "bottom border $i"
534 for {set i [expr {$y + 1}]} {$i < $y2 - 1} {incr i} {
535 if {[get_char $x $i] != "|"} {
536 return "left side $i"
538 if {[get_char $x2 $i] != "|"} {
539 return "right side $i"
546 # Check for a box at the given coordinates.
547 proc check_box {test_name x y width height} {
548 set why [_check_box $x $y $width $height]
553 fail "$test_name ($why)"
557 # Check whether the text contents of the terminal match the
558 # regular expression. Note that text styling is not considered.
559 proc check_contents {test_name regexp} {
560 set contents [get_all_lines]
561 if {![gdb_assert {[regexp -- $regexp $contents]} $test_name]} {
566 # A debugging function to dump the current screen, with line
568 proc dump_screen {} {
570 verbose "Screen Dump:"
571 for {set y 0} {$y < $_rows} {incr y} {
572 set fmt [format %5d $y]
573 verbose "$fmt [get_line $y]"
577 # Resize the terminal.
578 proc resize {rows cols} {
583 set old_rows [expr {min ($_rows, $rows)}]
584 set old_cols [expr {min ($_cols, $cols)}]
587 array set local_chars [array get _chars]
592 _clear_lines 0 $_rows
594 for {set x 0} {$x < $old_cols} {incr x} {
595 for {set y 0} {$y < $old_rows} {incr y} {
596 set _chars($x,$y) $local_chars($x,$y)
600 global gdb_spawn_name
601 # Somehow the number of columns transmitted to gdb is one less
602 # than what we request from expect. We hide this weird
603 # details from the caller.
604 stty rows $_rows columns [expr {$_cols + 1}] \