[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
    set gdb_spawn_name $spawn_out(slave,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.
    proc _accept {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
		}
	    }

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

    # 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 "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} {
	send_gdb "$cmd\n"
	_accept [string_to_regexp $cmd]
    }

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