blob: 8ab8d07b54595a48380c2aa97fcd6b914ffcf6f3 [file] [log] [blame]
# Copyright 2019-2021 Free Software Foundation, Inc.
# This program is free software; you can redistribute it and/or modify
# it under the terms of the GNU General Public License as published by
# the Free Software Foundation; either version 3 of the License, or
# (at your option) any later version.
#
# This program is distributed in the hope that it will be useful,
# but WITHOUT ANY WARRANTY; without even the implied warranty of
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
# GNU General Public License for more details.
#
# You should have received a copy of the GNU General Public License
# along with this program. If not, see <http://www.gnu.org/licenses/>.
# An ANSI terminal emulator for expect.
namespace eval Term {
# Size of the terminal.
variable _rows
variable _cols
# Buffer / contents of the terminal.
variable _chars
# Position of the cursor.
variable _cur_col
variable _cur_row
variable _attrs
variable _last_char
variable _resize_count
proc _log { what } {
verbose "+++ $what"
}
# Call BODY, then log WHAT along with the original and new cursor position.
proc _log_cur { what body } {
variable _cur_row
variable _cur_col
set orig_cur_row $_cur_row
set orig_cur_col $_cur_col
uplevel $body
_log "$what, cursor: ($orig_cur_row, $orig_cur_col) -> ($_cur_row, $_cur_col)"
}
# If ARG is empty, return DEF: otherwise ARG. This is useful for
# defaulting arguments in CSIs.
proc _default {arg def} {
if {$arg == ""} {
return $def
}
return $arg
}
# Erase in the line Y from SX to just before EX.
proc _clear_in_line {sx ex y} {
variable _attrs
variable _chars
set lattr [array get _attrs]
while {$sx < $ex} {
set _chars($sx,$y) [list " " $lattr]
incr sx
}
}
# Erase the lines from SY to just before EY.
proc _clear_lines {sy ey} {
variable _cols
while {$sy < $ey} {
_clear_in_line 0 $_cols $sy
incr sy
}
}
# Beep.
proc _ctl_0x07 {} {
}
# Backspace.
proc _ctl_0x08 {} {
_log_cur "Backspace" {
variable _cur_col
incr _cur_col -1
if {$_cur_col < 0} {
variable _cur_row
variable _cols
set _cur_col [expr {$_cols - 1}]
incr _cur_row -1
if {$_cur_row < 0} {
set _cur_row 0
}
}
}
}
# Linefeed.
proc _ctl_0x0a {} {
_log_cur "Line feed" {
variable _cur_row
variable _rows
incr _cur_row 1
if {$_cur_row >= $_rows} {
error "FIXME scroll"
}
}
}
# Carriage return.
proc _ctl_0x0d {} {
_log_cur "Carriage return" {
variable _cur_col
set _cur_col 0
}
}
# Insert Character.
#
# https://vt100.net/docs/vt510-rm/ICH.html
proc _csi_@ {args} {
set n [_default [lindex $args 0] 1]
_log_cur "Insert Character ($n)" {
variable _cur_col
variable _cur_row
variable _chars
set in_x $_cur_col
set out_x [expr {$_cur_col + $n}]
for {set i 0} {$i < $n} {incr i} {
set _chars($out_x,$_cur_row) $_chars($in_x,$_cur_row)
incr in_x
incr out_x
}
}
}
# Cursor Up.
#
# https://vt100.net/docs/vt510-rm/CUU.html
proc _csi_A {args} {
set arg [_default [lindex $args 0] 1]
_log_cur "Cursor Up ($arg)" {
variable _cur_row
set _cur_row [expr {max ($_cur_row - $arg, 0)}]
}
}
# Cursor Down.
#
# https://vt100.net/docs/vt510-rm/CUD.html
proc _csi_B {args} {
set arg [_default [lindex $args 0] 1]
_log_cur "Cursor Down ($arg)" {
variable _cur_row
variable _rows
set _cur_row [expr {min ($_cur_row + $arg, $_rows)}]
}
}
# Cursor Forward.
#
# https://vt100.net/docs/vt510-rm/CUF.html
proc _csi_C {args} {
set arg [_default [lindex $args 0] 1]
_log_cur "Cursor Forward ($arg)" {
variable _cur_col
variable _cols
set _cur_col [expr {min ($_cur_col + $arg, $_cols)}]
}
}
# Cursor Backward.
#
# https://vt100.net/docs/vt510-rm/CUB.html
proc _csi_D {args} {
set arg [_default [lindex $args 0] 1]
_log_cur "Cursor Backward ($arg)" {
variable _cur_col
set _cur_col [expr {max ($_cur_col - $arg, 0)}]
}
}
# Cursor Next Line.
#
# https://vt100.net/docs/vt510-rm/CNL.html
proc _csi_E {args} {
set arg [_default [lindex $args 0] 1]
_log_cur "Cursor Next Line ($arg)" {
variable _cur_col
variable _cur_row
variable _rows
set _cur_col 0
set _cur_row [expr {min ($_cur_row + $arg, $_rows)}]
}
}
# Cursor Previous Line.
#
# https://vt100.net/docs/vt510-rm/CPL.html
proc _csi_F {args} {
set arg [_default [lindex $args 0] 1]
_log_cur "Cursor Previous Line ($arg)" {
variable _cur_col
variable _cur_row
variable _rows
set _cur_col 0
set _cur_row [expr {max ($_cur_row - $arg, 0)}]
}
}
# Cursor Horizontal Absolute.
#
# https://vt100.net/docs/vt510-rm/CHA.html
proc _csi_G {args} {
set arg [_default [lindex $args 0] 1]
_log_cur "Cursor Horizontal Absolute ($arg)" {
variable _cur_col
variable _cols
set _cur_col [expr {min ($arg - 1, $_cols)}]
}
}
# Cursor Position.
#
# https://vt100.net/docs/vt510-rm/CUP.html
proc _csi_H {args} {
set row [_default [lindex $args 0] 1]
set col [_default [lindex $args 1] 1]
_log_cur "Cursor Position ($row, $col)" {
variable _cur_col
variable _cur_row
set _cur_row [expr {$row - 1}]
set _cur_col [expr {$col - 1}]
}
}
# Cursor Horizontal Forward Tabulation.
#
# https://vt100.net/docs/vt510-rm/CHT.html
proc _csi_I {args} {
set n [_default [lindex $args 0] 1]
_log_cur "Cursor Horizontal Forward Tabulation ($n)" {
variable _cur_col
variable _cols
incr _cur_col [expr {$n * 8 - $_cur_col % 8}]
if {$_cur_col >= $_cols} {
set _cur_col [expr {$_cols - 1}]
}
}
}
# Erase in Display.
#
# https://vt100.net/docs/vt510-rm/ED.html
proc _csi_J {args} {
set arg [_default [lindex $args 0] 0]
_log_cur "Erase in Display ($arg)" {
variable _cur_col
variable _cur_row
variable _rows
variable _cols
if {$arg == 0} {
_clear_in_line $_cur_col $_cols $_cur_row
_clear_lines [expr {$_cur_row + 1}] $_rows
} elseif {$arg == 1} {
_clear_lines 0 [expr {$_cur_row - 1}]
_clear_in_line 0 $_cur_col $_cur_row
} elseif {$arg == 2} {
_clear_lines 0 $_rows
}
}
}
# Erase in Line.
#
# https://vt100.net/docs/vt510-rm/EL.html
proc _csi_K {args} {
set arg [_default [lindex $args 0] 0]
_log_cur "Erase in Line ($arg)" {
variable _cur_col
variable _cur_row
variable _cols
if {$arg == 0} {
# From cursor to end.
_clear_in_line $_cur_col $_cols $_cur_row
} elseif {$arg == 1} {
_clear_in_line 0 $_cur_col $_cur_row
} elseif {$arg == 2} {
_clear_in_line 0 $_cols $_cur_row
}
}
}
# Delete line.
#
# https://vt100.net/docs/vt510-rm/DL.html
proc _csi_M {args} {
set count [_default [lindex $args 0] 1]
_log_cur "Delete line ($count)" {
variable _cur_row
variable _rows
variable _cols
variable _chars
set y $_cur_row
set next_y [expr {$y + $count}]
while {$next_y < $_rows} {
for {set x 0} {$x < $_cols} {incr x} {
set _chars($x,$y) $_chars($x,$next_y)
}
incr y
incr next_y
}
_clear_lines $y $_rows
}
}
# Erase chars.
#
# https://vt100.net/docs/vt510-rm/ECH.html
proc _csi_X {args} {
set n [_default [lindex $args 0] 1]
_log_cur "Erase chars ($n)" {
# Erase characters but don't move cursor.
variable _cur_col
variable _cur_row
variable _attrs
variable _chars
set lattr [array get _attrs]
set x $_cur_col
for {set i 0} {$i < $n} {incr i} {
set _chars($x,$_cur_row) [list " " $lattr]
incr x
}
}
}
# Cursor Backward Tabulation.
#
# https://vt100.net/docs/vt510-rm/CBT.html
proc _csi_Z {args} {
set n [_default [lindex $args 0] 1]
_log_cur "Cursor Backward Tabulation ($n)" {
variable _cur_col
set _cur_col [expr {max (int (($_cur_col - 1) / 8) * 8 - ($n - 1) * 8, 0)}]
}
}
# Repeat.
#
# https://www.xfree86.org/current/ctlseqs.html (See `(REP)`)
proc _csi_b {args} {
set n [_default [lindex $args 0] 1]
_log_cur "Repeat ($n)" {
variable _last_char
_insert [string repeat $_last_char $n]
}
}
# Vertical Line Position Absolute.
#
# https://vt100.net/docs/vt510-rm/VPA.html
proc _csi_d {args} {
set row [_default [lindex $args 0] 1]
_log_cur "Vertical Line Position Absolute ($row)" {
variable _cur_row
set _cur_row [expr {$row - 1}]
}
}
# Select Graphic Rendition.
#
# https://vt100.net/docs/vt510-rm/SGR.html
proc _csi_m {args} {
_log_cur "Select Graphic Rendition ([join $args {, }])" {
variable _attrs
foreach item $args {
switch -exact -- $item {
"" - 0 {
set _attrs(intensity) normal
set _attrs(fg) default
set _attrs(bg) default
set _attrs(underline) 0
set _attrs(reverse) 0
}
1 {
set _attrs(intensity) bold
}
2 {
set _attrs(intensity) dim
}
4 {
set _attrs(underline) 1
}
7 {
set _attrs(reverse) 1
}
22 {
set _attrs(intensity) normal
}
24 {
set _attrs(underline) 0
}
27 {
set _attrs(reverse) 1
}
30 - 31 - 32 - 33 - 34 - 35 - 36 - 37 {
set _attrs(fg) $item
}
39 {
set _attrs(fg) default
}
40 - 41 - 42 - 43 - 44 - 45 - 46 - 47 {
set _attrs(bg) $item
}
49 {
set _attrs(bg) default
}
}
}
}
}
# Insert string at the cursor location.
proc _insert {str} {
_log_cur "Inserted string '$str'" {
_log "Inserting string '$str'"
variable _cur_col
variable _cur_row
variable _rows
variable _cols
variable _attrs
variable _chars
set lattr [array get _attrs]
foreach char [split $str {}] {
_log_cur " Inserted char '$char'" {
set _chars($_cur_col,$_cur_row) [list $char $lattr]
incr _cur_col
if {$_cur_col >= $_cols} {
set _cur_col 0
incr _cur_row
if {$_cur_row >= $_rows} {
error "FIXME scroll"
}
}
}
}
}
}
# Initialize.
proc _setup {rows cols} {
global stty_init
set stty_init "rows $rows columns $cols"
variable _rows
variable _cols
variable _cur_col
variable _cur_row
variable _attrs
variable _resize_count
set _rows $rows
set _cols $cols
set _cur_col 0
set _cur_row 0
set _resize_count 0
array set _attrs {
intensity normal
fg default
bg default
underline 0
reverse 0
}
_clear_lines 0 $_rows
}
# Accept some output from gdb and update the screen. WAIT_FOR is
# a regexp matching the line to wait for. Return 0 on timeout, 1
# on success.
proc wait_for {wait_for} {
global expect_out
global gdb_prompt
variable _cur_col
variable _cur_row
set prompt_wait_for "$gdb_prompt \$"
while 1 {
gdb_expect {
-re "^\[\x07\x08\x0a\x0d\]" {
scan $expect_out(0,string) %c val
set hexval [format "%02x" $val]
_log "wait_for: _ctl_0x${hexval}"
_ctl_0x${hexval}
}
-re "^\x1b(\[0-9a-zA-Z\])" {
_log "wait_for: unsupported escape"
error "unsupported escape"
}
-re "^\x1b\\\[(\[0-9;\]*)(\[a-zA-Z@\])" {
set cmd $expect_out(2,string)
set params [split $expect_out(1,string) ";"]
_log "wait_for: _csi_$cmd <<<$expect_out(1,string)>>>"
eval _csi_$cmd $params
}
-re "^\[^\x07\x08\x0a\x0d\x1b\]+" {
_insert $expect_out(0,string)
variable _last_char
set _last_char [string index $expect_out(0,string) end]
}
timeout {
# Assume a timeout means we somehow missed the
# expected result, and carry on.
return 0
}
}
# If the cursor appears just after the prompt, return. It
# isn't reliable to check this only after an insertion,
# because curses may make "unusual" redrawing decisions.
if {$wait_for == "$prompt_wait_for"} {
set prev [get_line $_cur_row $_cur_col]
} else {
set prev [get_line $_cur_row]
}
if {[regexp -- $wait_for $prev]} {
if {$wait_for == "$prompt_wait_for"} {
break
}
set wait_for $prompt_wait_for
}
}
return 1
}
# Like ::clean_restart, but ensures that gdb starts in an
# environment where the TUI can work. ROWS and COLS are the size
# of the terminal. EXECUTABLE, if given, is passed to
# clean_restart.
proc clean_restart {rows cols {executable {}}} {
global env stty_init
save_vars {env(TERM) stty_init} {
setenv TERM ansi
_setup $rows $cols
if {$executable == ""} {
::clean_restart
} else {
::clean_restart $executable
}
::gdb_test_no_output "set pagination off"
}
}
# Setup ready for starting the tui, but don't actually start it.
# Returns 1 on success, 0 if TUI tests should be skipped.
proc prepare_for_tui {} {
if {[skip_tui_tests]} {
return 0
}
gdb_test_no_output "set tui border-kind ascii"
gdb_test_no_output "maint set tui-resize-message on"
return 1
}
# Start the TUI. Returns 1 on success, 0 if TUI tests should be
# skipped.
proc enter_tui {} {
if {![prepare_for_tui]} {
return 0
}
command_no_prompt_prefix "tui enable"
return 1
}
# Send the command CMD to gdb, then wait for a gdb prompt to be
# seen in the TUI. CMD should not end with a newline -- that will
# be supplied by this function.
proc command {cmd} {
global gdb_prompt
send_gdb "$cmd\n"
set str [string_to_regexp $cmd]
set str "^$gdb_prompt $str"
wait_for $str
}
# As proc command, but don't wait for a initial prompt. This is used for
# inital terminal commands, where there's no prompt yet.
proc command_no_prompt_prefix {cmd} {
send_gdb "$cmd\n"
set str [string_to_regexp $cmd]
wait_for "^$str"
}
# Return the text of screen line N, without attributes. Lines are
# 0-based. If C is given, stop before column C. Columns are also
# zero-based.
proc get_line {n {c ""}} {
variable _rows
# This can happen during resizing, if the cursor seems to
# temporarily be off-screen.
if {$n >= $_rows} {
return ""
}
set result ""
variable _cols
variable _chars
set c [_default $c $_cols]
set x 0
while {$x < $c} {
append result [lindex $_chars($x,$n) 0]
incr x
}
return $result
}
# Get just the character at (X, Y).
proc get_char {x y} {
variable _chars
return [lindex $_chars($x,$y) 0]
}
# Get the entire screen as a string.
proc get_all_lines {} {
variable _rows
variable _cols
variable _chars
set result ""
for {set y 0} {$y < $_rows} {incr y} {
for {set x 0} {$x < $_cols} {incr x} {
append result [lindex $_chars($x,$y) 0]
}
append result "\n"
}
return $result
}
# Get the text just before the cursor.
proc get_current_line {} {
variable _cur_col
variable _cur_row
return [get_line $_cur_row $_cur_col]
}
# Helper function for check_box. Returns empty string if the box
# is found, description of why not otherwise.
proc _check_box {x y width height} {
set x2 [expr {$x + $width - 1}]
set y2 [expr {$y + $height - 1}]
verbose -log "_check_box x=$x, y=$y, x2=$x2, y2=$y2, width=$width, height=$height"
set c [get_char $x $y]
if {$c != "+"} {
return "ul corner is $c, not +"
}
set c [get_char $x $y2]
if {$c != "+"} {
return "ll corner is $c, not +"
}
set c [get_char $x2 $y]
if {$c != "+"} {
return "ur corner is $c, not +"
}
set c [get_char $x2 $y2]
if {$c != "+"} {
return "lr corner is $c, not +"
}
# Note we do not check the full horizonal borders of the box.
# The top will contain a title, and the bottom may as well, if
# it is overlapped by some other border. However, at most a
# title should appear as '+-VERY LONG TITLE-+', so we can
# check for the '+-' on the left, and '-+' on the right.
set c [get_char [expr {$x + 1}] $y]
if {$c != "-"} {
return "ul title padding is $c, not -"
}
set c [get_char [expr {$x2 - 1}] $y]
if {$c != "-"} {
return "ul title padding is $c, not -"
}
# Now check the vertical borders.
for {set i [expr {$y + 1}]} {$i < $y2 - 1} {incr i} {
set c [get_char $x $i]
if {$c != "|"} {
return "left side $i is $c, not |"
}
set c [get_char $x2 $i]
if {$c != "|"} {
return "right side $i is $c, not |"
}
}
return ""
}
# Check for a box at the given coordinates.
proc check_box {test_name x y width height} {
dump_box $x $y $width $height
set why [_check_box $x $y $width $height]
if {$why == ""} {
pass $test_name
} else {
fail "$test_name ($why)"
}
}
# Check whether the text contents of the terminal match the
# regular expression. Note that text styling is not considered.
proc check_contents {test_name regexp} {
dump_screen
set contents [get_all_lines]
gdb_assert {[regexp -- $regexp $contents]} $test_name
}
# Get the region of the screen described by X, Y, WIDTH,
# and HEIGHT, and separate the lines using SEP.
proc get_region { x y width height sep } {
variable _chars
# Grab the contents of the box, join each line together
# using $sep.
set result ""
for {set yy $y} {$yy < [expr {$y + $height}]} {incr yy} {
if {$yy > $y} {
# Add the end of line sequence only if this isn't the
# first line.
append result $sep
}
for {set xx $x} {$xx < [expr {$x + $width}]} {incr xx} {
append result [lindex $_chars($xx,$yy) 0]
}
}
return $result
}
# Check that the region of the screen described by X, Y, WIDTH,
# and HEIGHT match REGEXP. This is like check_contents except
# only part of the screen is checked. This can be used to check
# the contents within a box (though check_box_contents is a better
# choice for boxes with a border).
proc check_region_contents { test_name x y width height regexp } {
variable _chars
dump_box $x $y $width $height
# Now grab the contents of the box, join each line together
# with a '\r\n' sequence and match against REGEXP.
set result [get_region $x $y $width $height "\r\n"]
gdb_assert {[regexp -- $regexp $result]} $test_name
}
# Check the contents of a box on the screen. This is a little
# like check_contents, but doens't check the whole screen
# contents, only the contents of a single box. This procedure
# includes (effectively) a call to check_box to ensure there is a
# box where expected, if there is then the contents of the box are
# matched against REGEXP.
proc check_box_contents {test_name x y width height regexp} {
variable _chars
dump_box $x $y $width $height
set why [_check_box $x $y $width $height]
if {$why != ""} {
fail "$test_name (box check: $why)"
return
}
check_region_contents $test_name [expr {$x + 1}] [expr {$y + 1}] \
[expr {$width - 2}] [expr {$height - 2}] $regexp
}
# A debugging function to dump the current screen, with line
# numbers.
proc dump_screen {} {
variable _rows
variable _cols
verbose -log "Screen Dump ($_cols x $_rows):"
for {set y 0} {$y < $_rows} {incr y} {
set fmt [format %5d $y]
verbose -log "$fmt [get_line $y]"
}
}
# A debugging function to dump a box from the current screen, with line
# numbers.
proc dump_box { x y width height } {
verbose -log "Box Dump ($width x $height) @ ($x, $y):"
set region [get_region $x $y $width $height "\n"]
set lines [split $region "\n"]
set nr $y
foreach line $lines {
set fmt [format %5d $nr]
verbose -log "$fmt $line"
incr nr
}
}
# Resize the terminal.
proc _do_resize {rows cols} {
variable _chars
variable _rows
variable _cols
set old_rows [expr {min ($_rows, $rows)}]
set old_cols [expr {min ($_cols, $cols)}]
# Copy locally.
array set local_chars [array get _chars]
unset _chars
set _rows $rows
set _cols $cols
_clear_lines 0 $_rows
for {set x 0} {$x < $old_cols} {incr x} {
for {set y 0} {$y < $old_rows} {incr y} {
set _chars($x,$y) $local_chars($x,$y)
}
}
}
proc resize {rows cols} {
variable _rows
variable _cols
variable _resize_count
# expect handles each argument to stty separately. This means
# that gdb will see SIGWINCH twice. Rather than rely on this
# behavior (which, after all, could be changed), we make it
# explicit here. This also simplifies waiting for the redraw.
_do_resize $rows $_cols
stty rows $_rows < $::gdb_tty_name
# Due to the strange column resizing behavior, and because we
# don't care about this intermediate resize, we don't check
# the size here.
wait_for "@@ resize done $_resize_count"
incr _resize_count
# Somehow the number of columns transmitted to gdb is one less
# than what we request from expect. We hide this weird
# details from the caller.
_do_resize $_rows $cols
stty columns [expr {$_cols + 1}] < $::gdb_tty_name
wait_for "@@ resize done $_resize_count, size = ${_cols}x${rows}"
incr _resize_count
}
}