[deliverable/binutils-gdb.git] / gdb / testsuite / lib / tuiterm.exp

# Copyright 2019-2020 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.

# The expect "spawn" function puts the tty name into the spawn_out
# array; but dejagnu doesn't export this globally.  So, we have to
# wrap spawn with our own function, so that we can capture this value.
# The value is later used in calls to stty.
rename spawn builtin_spawn
proc spawn {args} {
    set result [uplevel builtin_spawn $args]
    global gdb_spawn_name
    upvar spawn_out spawn_out
    if { [info exists spawn_out] } {
	set gdb_spawn_name $spawn_out(slave,name)
    } else {
	unset gdb_spawn_name
    }
    return $result
}

namespace eval Term {
    variable _rows
    variable _cols
    variable _chars

    variable _cur_x
    variable _cur_y

    variable _attrs

    variable _last_char

    variable _resize_count

    # 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 {} {
	variable _cur_x
	incr _cur_x -1
	if {$_cur_x < 0} {
	    variable _cur_y
	    variable _cols
	    set _cur_x [expr {$_cols - 1}]
	    incr _cur_y -1
	    if {$_cur_y < 0} {
		set _cur_y 0
	    }
	}
    }

    # Linefeed.
    proc _ctl_0x0a {} {
	variable _cur_y
	variable _rows
	incr _cur_y 1
	if {$_cur_y >= $_rows} {
	    error "FIXME scroll"
	}
    }

    # Carriage return.
    proc _ctl_0x0d {} {
	variable _cur_x
	set _cur_x 0
    }

    # Make room for characters.
    proc _csi_@ {args} {
	set n [_default [lindex $args 0] 1]
	variable _cur_x
	variable _cur_y
	variable _chars
	set in_x $_cur_x
	set out_x [expr {$_cur_x + $n}]
	for {set i 0} {$i < $n} {incr i} {
	    set _chars($out_x,$_cur_y) $_chars($in_x,$_cur_y)
	    incr in_x
	    incr out_x
	}
    }

    # Cursor Up.
    proc _csi_A {args} {
	variable _cur_y
	set arg [_default [lindex $args 0] 1]
	set _cur_y [expr {max ($_cur_y - $arg, 0)}]
    }

    # Cursor Down.
    proc _csi_B {args} {
	variable _cur_y
	variable _rows
	set arg [_default [lindex $args 0] 1]
	set _cur_y [expr {min ($_cur_y + $arg, $_rows)}]
    }

    # Cursor Forward.
    proc _csi_C {args} {
	variable _cur_x
	variable _cols
	set arg [_default [lindex $args 0] 1]
	set _cur_x [expr {min ($_cur_x + $arg, $_cols)}]
    }

    # Cursor Back.
    proc _csi_D {args} {
	variable _cur_x
	set arg [_default [lindex $args 0] 1]
	set _cur_x [expr {max ($_cur_x - $arg, 0)}]
    }

    # Cursor Next Line.
    proc _csi_E {args} {
	variable _cur_x
	variable _cur_y
	variable _rows
	set arg [_default [lindex $args 0] 1]
	set _cur_x 0
	set _cur_y [expr {min ($_cur_y + $arg, $_rows)}]
    }

    # Cursor Previous Line.
    proc _csi_F {args} {
	variable _cur_x
	variable _cur_y
	variable _rows
	set arg [_default [lindex $args 0] 1]
	set _cur_x 0
	set _cur_y [expr {max ($_cur_y - $arg, 0)}]
    }

    # Cursor Horizontal Absolute.
    proc _csi_G {args} {
	variable _cur_x
	variable _cols
	set arg [_default [lindex $args 0] 1]
	set _cur_x [expr {min ($arg - 1, $_cols)}]
    }

    # Move cursor (don't know the official name of this one).
    proc _csi_H {args} {
	variable _cur_x
	variable _cur_y
	set _cur_y [expr {[_default [lindex $args 0] 1] - 1}]
	set _cur_x [expr {[_default [lindex $args 1] 1] - 1}]
    }

    # Cursor Forward Tabulation.
    proc _csi_I {args} {
	set n [_default [lindex $args 0] 1]
	variable _cur_x
	variable _cols
	incr _cur_x [expr {$n * 8 - $_cur_x % 8}]
	if {$_cur_x >= $_cols} {
	    set _cur_x [expr {$_cols - 1}]
	}
    }

    # Erase.
    proc _csi_J {args} {
	variable _cur_x
	variable _cur_y
	variable _rows
	variable _cols
	set arg [_default [lindex $args 0] 0]
	if {$arg == 0} {
	    _clear_in_line $_cur_x $_cols $_cur_y
	    _clear_lines [expr {$_cur_y + 1}] $_rows
	} elseif {$arg == 1} {
	    _clear_lines 0 [expr {$_cur_y - 1}]
	    _clear_in_line 0 $_cur_x $_cur_y
	} elseif {$arg == 2} {
	    _clear_lines 0 $_rows
	}
    }

    # Erase Line.
    proc _csi_K {args} {
	variable _cur_x
	variable _cur_y
	variable _cols
	set arg [_default [lindex $args 0] 0]
	if {$arg == 0} {
	    # From cursor to end.
	    _clear_in_line $_cur_x $_cols $_cur_y
	} elseif {$arg == 1} {
	    _clear_in_line 0 $_cur_x $_cur_y
	} elseif {$arg == 2} {
	    _clear_in_line 0 $_cols $_cur_y
	}
    }

    # Delete lines.
    proc _csi_M {args} {
	variable _cur_y
	variable _rows
	variable _cols
	variable _chars
	set count [_default [lindex $args 0] 1]
	set y $_cur_y
	set next_y [expr {$y + 1}]
	while {$count > 0 && $next_y < $_rows} {
	    for {set x 0} {$x < $_cols} {incr x} {
		set _chars($x,$y) $_chars($x,$next_y)
	    }
	    incr y
	    incr next_y
	    incr count -1
	}
	_clear_lines $next_y $_rows
    }

    # Erase chars.
    proc _csi_X {args} {
	set n [_default [lindex $args 0] 1]
	# Erase characters but don't move cursor.
	variable _cur_x
	variable _cur_y
	variable _attrs
	variable _chars
	set lattr [array get _attrs]
	set x $_cur_x
	for {set i 0} {$i < $n} {incr i} {
	    set _chars($x,$_cur_y) [list " " $lattr]
	    incr x
	}
    }

    # Backward tab stops.
    proc _csi_Z {args} {
	set n [_default [lindex $args 0] 1]
	variable _cur_x
	set _cur_x [expr {max (int (($_cur_x - 1) / 8) * 8 - ($n - 1) * 8, 0)}]
    }

    # Repeat.
    proc _csi_b {args} {
	variable _last_char
	set n [_default [lindex $args 0] 1]
	_insert [string repeat $_last_char $n]
    }

    # Line Position Absolute.
    proc _csi_d {args} {
	variable _cur_y
	set _cur_y [expr {[_default [lindex $args 0] 1] - 1}]
    }

    # Select Graphic Rendition.
    proc _csi_m {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} {
	verbose "INSERT <<$str>>"
	variable _cur_x
	variable _cur_y
	variable _rows
	variable _cols
	variable _attrs
	variable _chars
	set lattr [array get _attrs]
	foreach char [split $str {}] {
	    set _chars($_cur_x,$_cur_y) [list $char $lattr]
	    incr _cur_x
	    if {$_cur_x >= $_cols} {
		set _cur_x 0
		incr _cur_y
		if {$_cur_y >= $_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_x
	variable _cur_y
	variable _attrs
	variable _resize_count

	set _rows $rows
	set _cols $cols
	set _cur_x 0
	set _cur_y 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_x
	variable _cur_y

	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]
		    verbose "+++ _ctl_0x${hexval}"
		    _ctl_0x${hexval}
		}
		-re "^\x1b(\[0-9a-zA-Z\])" {
		    verbose "+++ 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) ";"]
		    verbose "+++ _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_y $_cur_x]
	    } else {
		set prev [get_line $_cur_y]
	    }
	    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
	    }
	}
    }

    # 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_x
	variable _cur_y
	return [get_line $_cur_y $_cur_x]
    }

    # 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}]

	if {[get_char $x $y] != "+"} {
	    return "ul corner"
	}
	if {[get_char $x $y2] != "+"} {
	    return "ll corner"
	}
	if {[get_char $x2 $y] != "+"} {
	    return "ur corner"
	}
	if {[get_char $x2 $y2] != "+"} {
	    return "lr corner"
	}

	# 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.
	if {[get_char [expr {$x + 1}] $y] != "-"} {
	    return "ul title padding"
	}

	if {[get_char [expr {$x2 - 1}] $y] != "-"} {
	    return "ul title padding"
	}

	# Now check the vertical borders.
	for {set i [expr {$y + 1}]} {$i < $y2 - 1} {incr i} {
	    if {[get_char $x $i] != "|"} {
		return "left side $i"
	    }
	    if {[get_char $x2 $i] != "|"} {
		return "right side $i"
	    }
	}

	return ""
    }

    # Check for a box at the given coordinates.
    proc check_box {test_name x y width height} {
	set why [_check_box $x $y $width $height]
	if {$why == ""} {
	    pass $test_name
	} else {
	    dump_screen
	    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} {
	set contents [get_all_lines]
	if {![gdb_assert {[regexp -- $regexp $contents]} $test_name]} {
	    dump_screen
	}
    }

    # 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

	set why [_check_box $x $y $width $height]
	if {$why != ""} {
	    dump_screen
	    fail "$test_name (box check: $why)"
	    return
	}

	# Now grab the contents of the box, join each line together
	# with a newline character and match against REGEXP.
	set result ""
	for {set yy [expr {$y + 1}]} {$yy < [expr {$y + $height - 1}]} {incr yy} {
	    for {set xx [expr {$x + 1}]} {$xx < [expr {$x + $width - 1}]} {incr xx} {
		append result [lindex $_chars($xx,$yy) 0]
	    }
	    append result "\n"
	}

	if {![gdb_assert {[regexp -- $regexp $result]} $test_name]} {
	    dump_screen
	}
    }

    # 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]"
	}
    }

    # 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

	global gdb_spawn_name
	# 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_spawn_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_spawn_name
	wait_for "@@ resize done $_resize_count, size = ${_cols}x${rows}"
	incr _resize_count
    }
}
Commit	Line	Data
b811d2c2	1	# Copyright 2019-2020 Free Software Foundation, Inc.
c3786b3a TT	2
	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.
	7	#
	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.
	12	#
	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/>.
	15
	16	# An ANSI terminal emulator for expect.
	17
ded631d5 TT	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
	23	proc spawn {args} {
	24	set result [uplevel builtin_spawn $args]
	25	global gdb_spawn_name
	26	upvar spawn_out spawn_out
c8d4f6df TV	27	if { [info exists spawn_out] } {
	28	set gdb_spawn_name $spawn_out(slave,name)
	29	} else {
	30	unset gdb_spawn_name
	31	}
ded631d5 TT	32	return $result
	33	}
	34
c3786b3a TT	35	namespace eval Term {
	36	variable _rows
	37	variable _cols
	38	variable _chars
	39
	40	variable _cur_x
	41	variable _cur_y
	42
	43	variable _attrs
	44
	45	variable _last_char
	46
45e42163 TT	47	variable _resize_count
45e42163 TT	48
c3786b3a TT	49	# If ARG is empty, return DEF: otherwise ARG. This is useful for
	50	# defaulting arguments in CSIs.
	51	proc _default {arg def} {
	52	if {$arg == ""} {
	53	return $def
	54	}
	55	return $arg
	56	}
	57
	58	# Erase in the line Y from SX to just before EX.
	59	proc _clear_in_line {sx ex y} {
	60	variable _attrs
	61	variable _chars
	62	set lattr [array get _attrs]
	63	while {$sx < $ex} {
	64	set _chars($sx,$y) [list " " $lattr]
	65	incr sx
	66	}
	67	}
	68
	69	# Erase the lines from SY to just before EY.
	70	proc _clear_lines {sy ey} {
	71	variable _cols
	72	while {$sy < $ey} {
	73	_clear_in_line 0 $_cols $sy
	74	incr sy
	75	}
	76	}
	77
	78	# Beep.
	79	proc _ctl_0x07 {} {
	80	}
	81
	82	# Backspace.
	83	proc _ctl_0x08 {} {
	84	variable _cur_x
	85	incr _cur_x -1
	86	if {$_cur_x < 0} {
	87	variable _cur_y
	88	variable _cols
	89	set _cur_x [expr {$_cols - 1}]
	90	incr _cur_y -1
	91	if {$_cur_y < 0} {
	92	set _cur_y 0
	93	}
	94	}
	95	}
	96
	97	# Linefeed.
	98	proc _ctl_0x0a {} {
	99	variable _cur_y
	100	variable _rows
	101	incr _cur_y 1
	102	if {$_cur_y >= $_rows} {
	103	error "FIXME scroll"
	104	}
	105	}
	106
	107	# Carriage return.
	108	proc _ctl_0x0d {} {
	109	variable _cur_x
	110	set _cur_x 0
	111	}
	112
3d235706 TT	113	# Make room for characters.
	114	proc _csi_@ {args} {
	115	set n [_default [lindex $args 0] 1]
	116	variable _cur_x
	117	variable _cur_y
	118	variable _chars
	119	set in_x $_cur_x
	120	set out_x [expr {$_cur_x + $n}]
	121	for {set i 0} {$i < $n} {incr i} {
	122	set _chars($out_x,$_cur_y) $_chars($in_x,$_cur_y)
	123	incr in_x
	124	incr out_x
	125	}
	126	}
	127
c3786b3a TT	128	# Cursor Up.
	129	proc _csi_A {args} {
	130	variable _cur_y
	131	set arg [_default [lindex $args 0] 1]
	132	set _cur_y [expr {max ($_cur_y - $arg, 0)}]
	133	}
	134
	135	# Cursor Down.
	136	proc _csi_B {args} {
	137	variable _cur_y
	138	variable _rows
	139	set arg [_default [lindex $args 0] 1]
	140	set _cur_y [expr {min ($_cur_y + $arg, $_rows)}]
	141	}
	142
	143	# Cursor Forward.
	144	proc _csi_C {args} {
	145	variable _cur_x
	146	variable _cols
	147	set arg [_default [lindex $args 0] 1]
	148	set _cur_x [expr {min ($_cur_x + $arg, $_cols)}]
	149	}
	150
	151	# Cursor Back.
	152	proc _csi_D {args} {
	153	variable _cur_x
	154	set arg [_default [lindex $args 0] 1]
	155	set _cur_x [expr {max ($_cur_x - $arg, 0)}]
	156	}
	157
	158	# Cursor Next Line.
	159	proc _csi_E {args} {
	160	variable _cur_x
	161	variable _cur_y
	162	variable _rows
	163	set arg [_default [lindex $args 0] 1]
	164	set _cur_x 0
	165	set _cur_y [expr {min ($_cur_y + $arg, $_rows)}]
	166	}
	167
	168	# Cursor Previous Line.
	169	proc _csi_F {args} {
	170	variable _cur_x
	171	variable _cur_y
	172	variable _rows
	173	set arg [_default [lindex $args 0] 1]
	174	set _cur_x 0
	175	set _cur_y [expr {max ($_cur_y - $arg, 0)}]
	176	}
	177
	178	# Cursor Horizontal Absolute.
	179	proc _csi_G {args} {
	180	variable _cur_x
	181	variable _cols
	182	set arg [_default [lindex $args 0] 1]
	183	set _cur_x [expr {min ($arg - 1, $_cols)}]
	184	}
	185
	186	# Move cursor (don't know the official name of this one).
	187	proc _csi_H {args} {
	188	variable _cur_x
	189	variable _cur_y
	190	set _cur_y [expr {[_default [lindex $args 0] 1] - 1}]
	191	set _cur_x [expr {[_default [lindex $args 1] 1] - 1}]
192	}
193
194	# Cursor Forward Tabulation.
195	proc _csi_I {args} {
196	set n [_default [lindex $args 0] 1]
197	variable _cur_x
198	variable _cols
199	incr _cur_x [expr {$n * 8 - $_cur_x % 8}]
200	if {$_cur_x >= $_cols} {
201	set _cur_x [expr {$_cols - 1}]
202	}
203	}
204
205	# Erase.
206	proc _csi_J {args} {
207	variable _cur_x
208	variable _cur_y
209	variable _rows
210	variable _cols
211	set arg [_default [lindex $args 0] 0]
212	if {$arg == 0} {
213	_clear_in_line $_cur_x $_cols $_cur_y
214	_clear_lines [expr {$_cur_y + 1}] $_rows
215	} elseif {$arg == 1} {
216	_clear_lines 0 [expr {$_cur_y - 1}]
217	_clear_in_line 0 $_cur_x $_cur_y
218	} elseif {$arg == 2} {
219	_clear_lines 0 $_rows
220	}
221	}
222
223	# Erase Line.
224	proc _csi_K {args} {
225	variable _cur_x
226	variable _cur_y
227	variable _cols
228	set arg [_default [lindex $args 0] 0]
229	if {$arg == 0} {
230	# From cursor to end.
231	_clear_in_line $_cur_x $_cols $_cur_y
232	} elseif {$arg == 1} {
233	_clear_in_line 0 $_cur_x $_cur_y
234	} elseif {$arg == 2} {
235	_clear_in_line 0 $_cols $_cur_y
236	}
237	}
238
239	# Delete lines.
240	proc _csi_M {args} {
241	variable _cur_y
242	variable _rows
243	variable _cols
244	variable _chars
245	set count [_default [lindex $args 0] 1]
246	set y $_cur_y
247	set next_y [expr {$y + 1}]
248	while {$count > 0 && $next_y < $_rows} {
249	for {set x 0} {$x < $_cols} {incr x} {
250	set _chars($x,$y) $_chars($x,$next_y)
251	}
252	incr y
253	incr next_y
254	incr count -1
255	}
256	_clear_lines $next_y $_rows
257	}
258
259	# Erase chars.
260	proc _csi_X {args} {
261	set n [_default [lindex $args 0] 1]
3d235706 TT	262	# Erase characters but don't move cursor.
	263	variable _cur_x
	264	variable _cur_y
	265	variable _attrs
	266	variable _chars
	267	set lattr [array get _attrs]
	268	set x $_cur_x
	269	for {set i 0} {$i < $n} {incr i} {
	270	set _chars($x,$_cur_y) [list " " $lattr]
	271	incr x
	272	}
c3786b3a TT	273	}
c3786b3a TT	274
398fdd60 TT	275	# Backward tab stops.
	276	proc _csi_Z {args} {
	277	set n [_default [lindex $args 0] 1]
	278	variable _cur_x
	279	set _cur_x [expr {max (int (($_cur_x - 1) / 8) * 8 - ($n - 1) * 8, 0)}]
	280	}
	281
c3786b3a TT	282	# Repeat.
	283	proc _csi_b {args} {
	284	variable _last_char
	285	set n [_default [lindex $args 0] 1]
	286	_insert [string repeat $_last_char $n]
	287	}
	288
	289	# Line Position Absolute.
	290	proc _csi_d {args} {
	291	variable _cur_y
	292	set _cur_y [expr {[_default [lindex $args 0] 1] - 1}]
	293	}
	294
	295	# Select Graphic Rendition.
	296	proc _csi_m {args} {
	297	variable _attrs
	298	foreach item $args {
	299	switch -exact -- $item {
	300	"" - 0 {
	301	set _attrs(intensity) normal
	302	set _attrs(fg) default
	303	set _attrs(bg) default
	304	set _attrs(underline) 0
	305	set _attrs(reverse) 0
	306	}
	307	1 {
	308	set _attrs(intensity) bold
	309	}
	310	2 {
	311	set _attrs(intensity) dim
	312	}
	313	4 {
	314	set _attrs(underline) 1
	315	}
	316	7 {
	317	set _attrs(reverse) 1
	318	}
	319	22 {
	320	set _attrs(intensity) normal
	321	}
	322	24 {
	323	set _attrs(underline) 0
	324	}
	325	27 {
	326	set _attrs(reverse) 1
	327	}
	328	30 - 31 - 32 - 33 - 34 - 35 - 36 - 37 {
	329	set _attrs(fg) $item
	330	}
	331	39 {
	332	set _attrs(fg) default
	333	}
	334	40 - 41 - 42 - 43 - 44 - 45 - 46 - 47 {
	335	set _attrs(bg) $item
	336	}
	337	49 {
	338	set _attrs(bg) default
	339	}
	340	}
	341	}
	342	}
	343
	344	# Insert string at the cursor location.
	345	proc _insert {str} {
346	verbose "INSERT <<$str>>"
347	variable _cur_x
348	variable _cur_y
349	variable _rows
350	variable _cols
351	variable _attrs
352	variable _chars
353	set lattr [array get _attrs]
354	foreach char [split $str {}] {
355	set _chars($_cur_x,$_cur_y) [list $char $lattr]
356	incr _cur_x
357	if {$_cur_x >= $_cols} {
358	set _cur_x 0
359	incr _cur_y
360	if {$_cur_y >= $_rows} {
361	error "FIXME scroll"
362	}
363	}
364	}
365	}
366
367	# Initialize.
368	proc _setup {rows cols} {
369	global stty_init
370	set stty_init "rows $rows columns $cols"
371
372	variable _rows
373	variable _cols
374	variable _cur_x
375	variable _cur_y
376	variable _attrs
45e42163	377	variable _resize_count
c3786b3a TT	378
	379	set _rows $rows
	380	set _cols $cols
	381	set _cur_x 0
	382	set _cur_y 0
45e42163	383	set _resize_count 0
c3786b3a TT	384	array set _attrs {
	385	intensity normal
	386	fg default
	387	bg default
	388	underline 0
	389	reverse 0
	390	}
	391
	392	_clear_lines 0 $_rows
	393	}
	394
9ae6bf64 TT	395	# Accept some output from gdb and update the screen. WAIT_FOR is
	396	# a regexp matching the line to wait for. Return 0 on timeout, 1
	397	# on success.
	398	proc wait_for {wait_for} {
c3786b3a	399	global expect_out
45e42163 TT	400	global gdb_prompt
	401	variable _cur_x
	402	variable _cur_y
	403
	404	set prompt_wait_for "$gdb_prompt \$"
	405
	406	while 1 {
	407	gdb_expect {
	408	-re "^\[\x07\x08\x0a\x0d\]" {
	409	scan $expect_out(0,string) %c val
	410	set hexval [format "%02x" $val]
	411	verbose "+++ _ctl_0x${hexval}"
	412	_ctl_0x${hexval}
	413	}
	414	-re "^\x1b(\[0-9a-zA-Z\])" {
	415	verbose "+++ unsupported escape"
	416	error "unsupported escape"
	417	}
	418	-re "^\x1b\\\[(\[0-9;\]*)(\[a-zA-Z@\])" {
	419	set cmd $expect_out(2,string)
	420	set params [split $expect_out(1,string) ";"]
	421	verbose "+++ _csi_$cmd <<<$expect_out(1,string)>>>"
	422	eval _csi_$cmd $params
	423	}
	424	-re "^\[^\x07\x08\x0a\x0d\x1b\]+" {
	425	_insert $expect_out(0,string)
	426	variable _last_char
	427	set _last_char [string index $expect_out(0,string) end]
	428	}
	429
	430	timeout {
	431	# Assume a timeout means we somehow missed the
	432	# expected result, and carry on.
9ae6bf64	433	return 0
45e42163	434	}
c3786b3a	435	}
45e42163 TT	436
	437	# If the cursor appears just after the prompt, return. It
	438	# isn't reliable to check this only after an insertion,
	439	# because curses may make "unusual" redrawing decisions.
	440	if {$wait_for == "$prompt_wait_for"} {
c3786b3a	441	set prev [get_line $_cur_y $_cur_x]
45e42163 TT	442	} else {
	443	set prev [get_line $_cur_y]
	444	}
	445	if {[regexp -- $wait_for $prev]} {
	446	if {$wait_for == "$prompt_wait_for"} {
	447	break
c3786b3a	448	}
45e42163	449	set wait_for $prompt_wait_for
c3786b3a TT	450	}
c3786b3a TT	451	}
9ae6bf64 TT	452
9ae6bf64 TT	453	return 1
c3786b3a TT	454	}
	455
	456	# Like ::clean_restart, but ensures that gdb starts in an
	457	# environment where the TUI can work. ROWS and COLS are the size
2b1d00c2 TT	458	# of the terminal. EXECUTABLE, if given, is passed to
	459	# clean_restart.
	460	proc clean_restart {rows cols {executable {}}} {
c3786b3a TT	461	global env stty_init
	462	save_vars {env(TERM) stty_init} {
	463	setenv TERM ansi
	464	_setup $rows $cols
2b1d00c2 TT	465	if {$executable == ""} {
	466	::clean_restart
	467	} else {
	468	::clean_restart $executable
	469	}
c3786b3a TT	470	}
	471	}
	472
b40aa28f AB	473	# Setup ready for starting the tui, but don't actually start it.
	474	# Returns 1 on success, 0 if TUI tests should be skipped.
	475	proc prepare_for_tui {} {
c3786b3a TT	476	if {[skip_tui_tests]} {
	477	return 0
	478	}
	479
	480	gdb_test_no_output "set tui border-kind ascii"
45e42163	481	gdb_test_no_output "maint set tui-resize-message on"
b40aa28f AB	482	return 1
	483	}
	484
	485	# Start the TUI. Returns 1 on success, 0 if TUI tests should be
	486	# skipped.
	487	proc enter_tui {} {
	488	if {![prepare_for_tui]} {
	489	return 0
	490	}
	491
301b21e0	492	command_no_prompt_prefix "tui enable"
c3786b3a TT	493	return 1
	494	}
	495
	496	# Send the command CMD to gdb, then wait for a gdb prompt to be
	497	# seen in the TUI. CMD should not end with a newline -- that will
	498	# be supplied by this function.
	499	proc command {cmd} {
301b21e0 TV	500	global gdb_prompt
	501	send_gdb "$cmd\n"
	502	set str [string_to_regexp $cmd]
	503	set str "^$gdb_prompt $str"
	504	wait_for $str
	505	}
	506
	507	# As proc command, but don't wait for a initial prompt. This is used for
	508	# inital terminal commands, where there's no prompt yet.
	509	proc command_no_prompt_prefix {cmd} {
c3786b3a	510	send_gdb "$cmd\n"
301b21e0 TV	511	set str [string_to_regexp $cmd]
301b21e0 TV	512	wait_for "^$str"
c3786b3a TT	513	}
	514
	515	# Return the text of screen line N, without attributes. Lines are
	516	# 0-based. If C is given, stop before column C. Columns are also
	517	# zero-based.
	518	proc get_line {n {c ""}} {
45e42163 TT	519	variable _rows
	520	# This can happen during resizing, if the cursor seems to
	521	# temporarily be off-screen.
	522	if {$n >= $_rows} {
	523	return ""
	524	}
	525
c3786b3a TT	526	set result ""
	527	variable _cols
	528	variable _chars
	529	set c [_default $c $_cols]
	530	set x 0
	531	while {$x < $c} {
	532	append result [lindex $_chars($x,$n) 0]
	533	incr x
	534	}
	535	return $result
	536	}
	537
	538	# Get just the character at (X, Y).
	539	proc get_char {x y} {
	540	variable _chars
	541	return [lindex $_chars($x,$y) 0]
	542	}
	543
	544	# Get the entire screen as a string.
	545	proc get_all_lines {} {
	546	variable _rows
	547	variable _cols
	548	variable _chars
	549
	550	set result ""
	551	for {set y 0} {$y < $_rows} {incr y} {
	552	for {set x 0} {$x < $_cols} {incr x} {
	553	append result [lindex $_chars($x,$y) 0]
	554	}
	555	append result "\n"
	556	}
	557
	558	return $result
	559	}
	560
	561	# Get the text just before the cursor.
	562	proc get_current_line {} {
	563	variable _cur_x
	564	variable _cur_y
	565	return [get_line $_cur_y $_cur_x]
	566	}
	567
	568	# Helper function for check_box. Returns empty string if the box
	569	# is found, description of why not otherwise.
	570	proc _check_box {x y width height} {
	571	set x2 [expr {$x + $width - 1}]
	572	set y2 [expr {$y + $height - 1}]
	573
	574	if {[get_char $x $y] != "+"} {
	575	return "ul corner"
	576	}
	577	if {[get_char $x $y2] != "+"} {
	578	return "ll corner"
	579	}
	580	if {[get_char $x2 $y] != "+"} {
	581	return "ur corner"
	582	}
	583	if {[get_char $x2 $y2] != "+"} {
	584	return "lr corner"
	585	}
	586
9a6d629c AB	587	# Note we do not check the full horizonal borders of the box.
	588	# The top will contain a title, and the bottom may as well, if
	589	# it is overlapped by some other border. However, at most a
	590	# title should appear as '+-VERY LONG TITLE-+', so we can
	591	# check for the '+-' on the left, and '-+' on the right.
	592	if {[get_char [expr {$x + 1}] $y] != "-"} {
	593	return "ul title padding"
	594	}
	595
	596	if {[get_char [expr {$x2 - 1}] $y] != "-"} {
	597	return "ul title padding"
	598	}
	599
	600	# Now check the vertical borders.
c3786b3a TT	601	for {set i [expr {$y + 1}]} {$i < $y2 - 1} {incr i} {
	602	if {[get_char $x $i] != "\|"} {
	603	return "left side $i"
	604	}
	605	if {[get_char $x2 $i] != "\|"} {
	606	return "right side $i"
	607	}
	608	}
	609
	610	return ""
	611	}
	612
	613	# Check for a box at the given coordinates.
	614	proc check_box {test_name x y width height} {
	615	set why [_check_box $x $y $width $height]
	616	if {$why == ""} {
	617	pass $test_name
	618	} else {
	619	dump_screen
	620	fail "$test_name ($why)"
	621	}
	622	}
	623
	624	# Check whether the text contents of the terminal match the
	625	# regular expression. Note that text styling is not considered.
	626	proc check_contents {test_name regexp} {
	627	set contents [get_all_lines]
	628	if {![gdb_assert {[regexp -- $regexp $contents]} $test_name]} {
	629	dump_screen
	630	}
	631	}
	632
3804da7e AB	633	# Check the contents of a box on the screen. This is a little
	634	# like check_contents, but doens't check the whole screen
	635	# contents, only the contents of a single box. This procedure
	636	# includes (effectively) a call to check_box to ensure there is a
	637	# box where expected, if there is then the contents of the box are
	638	# matched against REGEXP.
	639	proc check_box_contents {test_name x y width height regexp} {
	640	variable _chars
	641
	642	set why [_check_box $x $y $width $height]
	643	if {$why != ""} {
	644	dump_screen
	645	fail "$test_name (box check: $why)"
	646	return
	647	}
	648
	649	# Now grab the contents of the box, join each line together
	650	# with a newline character and match against REGEXP.
	651	set result ""
	652	for {set yy [expr {$y + 1}]} {$yy < [expr {$y + $height - 1}]} {incr yy} {
	653	for {set xx [expr {$x + 1}]} {$xx < [expr {$x + $width - 1}]} {incr xx} {
	654	append result [lindex $_chars($xx,$yy) 0]
	655	}
	656	append result "\n"
	657	}
	658
	659	if {![gdb_assert {[regexp -- $regexp $result]} $test_name]} {
	660	dump_screen
	661	}
	662	}
	663
c3786b3a TT	664	# A debugging function to dump the current screen, with line
	665	# numbers.
	666	proc dump_screen {} {
	667	variable _rows
45e42163	668	variable _cols
63ffd7c9	669	verbose -log "Screen Dump ($_cols x $_rows):"
c3786b3a TT	670	for {set y 0} {$y < $_rows} {incr y} {
c3786b3a TT	671	set fmt [format %5d $y]
63ffd7c9	672	verbose -log "$fmt [get_line $y]"
c3786b3a TT	673	}
c3786b3a TT	674	}
ded631d5 TT	675
ded631d5 TT	676	# Resize the terminal.
45e42163	677	proc _do_resize {rows cols} {
ded631d5 TT	678	variable _chars
	679	variable _rows
	680	variable _cols
	681
	682	set old_rows [expr {min ($_rows, $rows)}]
	683	set old_cols [expr {min ($_cols, $cols)}]
	684
	685	# Copy locally.
	686	array set local_chars [array get _chars]
	687	unset _chars
	688
	689	set _rows $rows
	690	set _cols $cols
	691	_clear_lines 0 $_rows
	692
	693	for {set x 0} {$x < $old_cols} {incr x} {
	694	for {set y 0} {$y < $old_rows} {incr y} {
	695	set _chars($x,$y) $local_chars($x,$y)
	696	}
	697	}
45e42163 TT	698	}
	699
	700	proc resize {rows cols} {
	701	variable _rows
	702	variable _cols
	703	variable _resize_count
ded631d5 TT	704
ded631d5 TT	705	global gdb_spawn_name
45e42163 TT	706	# expect handles each argument to stty separately. This means
	707	# that gdb will see SIGWINCH twice. Rather than rely on this
	708	# behavior (which, after all, could be changed), we make it
	709	# explicit here. This also simplifies waiting for the redraw.
	710	_do_resize $rows $_cols
	711	stty rows $_rows < $gdb_spawn_name
	712	# Due to the strange column resizing behavior, and because we
	713	# don't care about this intermediate resize, we don't check
	714	# the size here.
9ae6bf64	715	wait_for "@@ resize done $_resize_count"
45e42163	716	incr _resize_count
ded631d5 TT	717	# Somehow the number of columns transmitted to gdb is one less
	718	# than what we request from expect. We hide this weird
	719	# details from the caller.
45e42163 TT	720	_do_resize $_rows $cols
45e42163 TT	721	stty columns [expr {$_cols + 1}] < $gdb_spawn_name
9ae6bf64	722	wait_for "@@ resize done $_resize_count, size = ${_cols}x${rows}"
45e42163	723	incr _resize_count
ded631d5	724	}
c3786b3a	725	}