gdb/testsuite/lib/tuiterm.exp

# Copyright 2019-2025 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

    variable _TERM
    set _TERM ""

    variable _alternate
    variable _alternate_setup
    set _alternate 0
    set _alternate_setup 0
}

proc Term::_log { what } {
    verbose "+++ $what"
}

# Call BODY, then log WHAT along with the original and new cursor position.
proc Term::_log_cur { what body } {
    variable _cur_row
    variable _cur_col

    set orig_cur_row $_cur_row
    set orig_cur_col $_cur_col

    set code [catch {uplevel $body} result]

    _log "$what, cursor: ($orig_cur_row, $orig_cur_col) -> ($_cur_row, $_cur_col)"

    if { $code == 1 } {
	global errorInfo errorCode
	return -code $code -errorinfo $errorInfo -errorcode $errorCode $result
    } else {
	return -code $code $result
    }
}

# If ARG is empty, return DEF: otherwise ARG.  This is useful for
# defaulting arguments in CSIs.
proc Term::_default {arg def} {
    if {$arg == ""} {
	return $def
    }
    return $arg
}

# Erase in the line Y from SX to just before EX.
proc Term::_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 Term::_clear_lines {sy ey} {
    variable _cols
    while {$sy < $ey} {
	_clear_in_line 0 $_cols $sy
	incr sy
    }
}

# Beep.
proc Term::_ctl_0x07 {} {
}

# Return 1 if tuiterm has the bw/auto_left_margin enabled.
proc Term::_have_bw {} {
    return [expr \
		[string equal $Term::_TERM "ansiw"] \
		|| [string equal $Term::_TERM "ansis"]]
}

# Backspace.
proc Term::_ctl_0x08 { {bw -1} } {
    if { $bw == -1 } {
	set bw [_have_bw]
    }
    _log_cur "Backspace, bw == $bw" {
	variable _cur_col
	variable _cur_row
	variable _cols

	if { $_cur_col > 0 } {
	    # No wrapping needed.
	    incr _cur_col -1
	    return
	}

	if { ! $bw } {
	    # Wrapping not enabled.
	    return
	}

	if { $_cur_row == 0 } {
	    # Can't wrap.
	    return
	}

	# Wrap to previous line.
	set _cur_col [expr $_cols - 1]
	incr _cur_row -1
    }
}

# Linefeed.
proc Term::_ctl_0x0a {} {
    _log_cur "Line feed" {
	variable _cur_row
	variable _rows
	variable _cols
	variable _chars

	incr _cur_row 1
	while {$_cur_row >= $_rows} {
	    # Scroll the display contents.  We scroll one line at
	    # a time here; as _cur_row was only increased by one,
	    # a single line scroll should be enough to put the
	    # cursor back on the screen.  But we wrap the
	    # scrolling inside a while loop just to be on the safe
	    # side.
	    for {set y 0} {$y < [expr $_rows - 1]} {incr y} {
		set next_y [expr $y + 1]
		for {set x 0} {$x < $_cols} {incr x} {
		    set _chars($x,$y) $_chars($x,$next_y)
		}
	    }

	    incr _cur_row -1
	}
    }
}

# Carriage return.
proc Term::_ctl_0x0d {} {
    _log_cur "Carriage return" {
	variable _cur_col

	set _cur_col 0
    }
}

# Designate G0 Character Set, USASCII (ESC ( B)
#
# https://invisible-island.net/xterm/ctlseqs/ctlseqs.html (see "ESC ( C", case C = B)
proc Term::_esc_0x28_B {} {
    _log "ignored: G0: USASCII"
}

# Designate G0 Character Set, DEC Special Character and Line Drawing Set (ESC ( 0)
#
# https://invisible-island.net/xterm/ctlseqs/ctlseqs.html (see "ESC ( C", case C = 0)
proc Term::_esc_0x28_0 {} {
    _log "ignored: G0: DEC Special Character and Line Drawing Set"
}

# DECKPAM (Application Keypad, ESC =)
#
# https://vt100.net/docs/vt510-rm/DECKPAM.html
proc Term::_esc_0x3d {} {
    _log "ignored: Application Keypad"
}

# DECKPNM (Normal Keypad, ESC >)
#
# https://vt100.net/docs/vt510-rm/DECKPNM.html
proc Term::_esc_0x3e {} {
    _log "ignored: Normal Keypad"
}

# Insert Character.
#
# https://vt100.net/docs/vt510-rm/ICH.html
proc Term::_csi_@ {args} {
    set n [_default [lindex $args 0] 1]

    _log_cur "Insert Character ($n)" {
	variable _cur_col
	variable _cur_row
	variable _cols
	variable _chars

	# Move characters right of the cursor right by N positions,
	# starting with the rightmost one.
	for {set in_col [expr $_cols - $n - 1]} {$in_col >= $_cur_col} {incr in_col -1} {
	    set out_col [expr $in_col + $n]
	    set _chars($out_col,$_cur_row) $_chars($in_col,$_cur_row)
	}

	# Write N blank spaces starting from the cursor.
	_clear_in_line $_cur_col [expr $_cur_col + $n] $_cur_row
    }
}

# Horizontal Position Absolute.
#
# https://vt100.net/docs/vt510-rm/HPA.html
proc Term::_csi_` {args} {
    # Same as Cursor Horizontal Absolute.
    return [Term::_csi_G {*}$args]
}

# Cursor Up.
#
# https://vt100.net/docs/vt510-rm/CUU.html
proc Term::_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 Term::_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 - 1)}]
    }
}

# Cursor Forward.
#
# https://vt100.net/docs/vt510-rm/CUF.html
proc Term::_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 - 1)}]
    }
}

# Cursor Backward.
#
# https://vt100.net/docs/vt510-rm/CUB.html
proc Term::_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 Term::_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 - 1)}]
    }
}

# Cursor Previous Line.
#
# https://vt100.net/docs/vt510-rm/CPL.html
proc Term::_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 Term::_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, $_cols)} - 1]
    }
}

# Cursor Position.
#
# https://vt100.net/docs/vt510-rm/CUP.html
proc Term::_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 Term::_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 Term::_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} {
	    # Cursor (inclusive) to end of display.
	    _clear_in_line $_cur_col $_cols $_cur_row
	    _clear_lines [expr {$_cur_row + 1}] $_rows
	} elseif {$arg == 1} {
	    # Beginning of display to cursor (inclusive).
	    _clear_lines 0 $_cur_row
	    _clear_in_line 0 [expr $_cur_col + 1] $_cur_row
	} elseif {$arg == 2} {
	    # Entire display.
	    _clear_lines 0 $_rows
	}
    }
}

# Erase in Line.
#
# https://vt100.net/docs/vt510-rm/EL.html
proc Term::_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} {
	    # Cursor (inclusive) to end of line.
	    _clear_in_line $_cur_col $_cols $_cur_row
	} elseif {$arg == 1} {
	    # Beginning of line to cursor (inclusive).
	    _clear_in_line 0 [expr $_cur_col + 1] $_cur_row
	} elseif {$arg == 2} {
	    # Entire line.
	    _clear_in_line 0 $_cols $_cur_row
	}
    }
}

# Insert Line
#
# https://vt100.net/docs/vt510-rm/IL.html
proc Term::_csi_L {args} {
    set arg [_default [lindex $args 0] 1]

    _log_cur "Insert Line ($arg)" {
	variable _cur_col
	variable _cur_row
	variable _rows
	variable _cols
	variable _chars

	set y [expr $_rows - 2]
	set next_y [expr $y + $arg]
	while {$y >= $_cur_row} {
	    for {set x 0} {$x < $_cols} {incr x} {
		set _chars($x,$next_y) $_chars($x,$y)
	    }
	    incr y -1
	    incr next_y -1
	}

	_clear_lines $_cur_row [expr $_cur_row + $arg]
    }
}

# Delete line.
#
# https://vt100.net/docs/vt510-rm/DL.html
proc Term::_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
    }
}

# Delete Character.
#
# https://vt100.net/docs/vt510-rm/DCH.html
proc Term::_csi_P {args} {
    set count [_default [lindex $args 0] 1]

    _log_cur "Delete character ($count)" {
	variable _cur_row
	variable _cur_col
	variable _chars
	variable _cols

	# Move all characters right of the cursor N positions left.
	set out_col [expr $_cur_col]
	set in_col [expr $_cur_col + $count]

	while {$in_col < $_cols} {
	    set _chars($out_col,$_cur_row) $_chars($in_col,$_cur_row)
	    incr in_col
	    incr out_col
	}

	# Clear the rest of the line.
	_clear_in_line $out_col $_cols $_cur_row
    }
}

# Pan Down
#
# https://vt100.net/docs/vt510-rm/SU.html
proc Term::_csi_S {args} {
    set count [_default [lindex $args 0] 1]

    _log_cur "Pan Down ($count)" {
	variable _cur_col
	variable _cur_row
	variable _cols
	variable _rows
	variable _chars

	# The following code is written without consideration for
	# the scroll margins.  At this time this comment was
	# written the tuiterm library doesn't support the scroll
	# margins.  If/when that changes, then the following will
	# need to be updated.

	set dy 0
	set y $count

	while {$y < $_rows} {
	    for {set x 0} {$x < $_cols} {incr x} {
		set _chars($x,$dy) $_chars($x,$y)
	    }
	    incr y 1
	    incr dy 1
	}

	_clear_lines $dy $_rows
    }
}

# Pan Up
#
# https://vt100.net/docs/vt510-rm/SD.html
proc Term::_csi_T {args} {
    set count [_default [lindex $args 0] 1]

    _log_cur "Pan Up ($count)" {
	variable _cur_col
	variable _cur_row
	variable _cols
	variable _rows
	variable _chars

	# The following code is written without consideration for
	# the scroll margins.  At this time this comment was
	# written the tuiterm library doesn't support the scroll
	# margins.  If/when that changes, then the following will
	# need to be updated.

	set y [expr $_rows - $count]
	set dy $_rows

	while {$dy >= $count} {
	    for {set x 0} {$x < $_cols} {incr x} {
		set _chars($x,$dy) $_chars($x,$y)
	    }
	    incr y -1
	    incr dy -1
	}

	_clear_lines 0 $count
    }
}

# Erase chars.
#
# https://vt100.net/docs/vt510-rm/ECH.html
proc Term::_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 Term::_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 Term::_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 Term::_csi_d {args} {
    set row [_default [lindex $args 0] 1]

    _log_cur "Vertical Line Position Absolute ($row)" {
	variable _cur_row
	variable _rows

	set _cur_row [expr min ($row - 1, $_rows - 1)]
    }
}

# Set Mode (SM, CSI h)
#
# https://invisible-island.net/xterm/ctlseqs/ctlseqs.html
proc Term::_csi_h { args } {
    foreach item $args {
	switch -exact -- $item {
	    4 {
		# Insert Mode (IRM)
		_log "ignored: insert mode"
	    }
	    default {
		error unsupported
	    }
	}
    }
}

# Reset Mode (RM, CSI l)
#
# https://invisible-island.net/xterm/ctlseqs/ctlseqs.html
proc Term::_csi_l { args } {
    foreach item $args {
	switch -exact -- $item {
	    4 {
		# Replace Mode (IRM)
		_log "ignored: replace mode"
	    }
	    default {
		error unsupported
	    }
	}
    }
}

# Set Scrolling Region (DECSTBM, CSI Ps ; Ps r)
#
# https://invisible-island.net/xterm/ctlseqs/ctlseqs.html
proc Term::_csi_r { top bottom } {
    _log "ignored: set scrolling region"
}

# Window manipulation (XTWINOPS, CSI Ps ; Ps ; Ps t)
#
# https://invisible-island.net/xterm/ctlseqs/ctlseqs.html
proc Term::_csi_t { arg1 arg2 arg3 } {
    if { $arg1 == 22 && $arg2 == 0 && $arg3 == 0 } {
	_log "ignored: Save xterm icon and window title on stack"
	return
    }

    if { $arg1 == 23 && $arg2 == 0 && $arg3 == 0 } {
	_log "ignored: Restore xterm icon and window title from stack"
	return
    }

    error unsupported
}

# DECSET (CSI ? h)
#
# https://invisible-island.net/xterm/ctlseqs/ctlseqs.html#h2-Mouse-Tracking
proc Term::_csi_0x3f_h { args } {
    foreach item $args {
	switch -exact -- $item {
	    1 {
		_log "ignored: Application Cursor Keys"
	    }
	    7 {
		_log "ignored: autowrap mode"
	    }
	    1000 {
		_log "ignored: Send Mouse X & Y on button press and release"
	    }
	    1006 {
		_log "ignored: Enable SGR Mouse Mode"
	    }
	    1049 {
		_log "switch to alternate screen"
		_set_alternate 1
	    }
	    default {
		error unsupported
	    }
	}
    }
}

# DECRST (CSI ? l)
#
# https://invisible-island.net/xterm/ctlseqs/ctlseqs.html#h2-Mouse-Tracking
proc Term::_csi_0x3f_l { args } {
    foreach item $args {
	switch -exact -- $item {
	    1 {
		_log "ignored: Normal Cursor Keys"
	    }
	    7 {
		_log "ignored: no autowrap mode"
	    }
	    1000 {
		_log "ignored: Don't send Mouse X & Y on button press and release"
	    }
	    1006 {
		_log "ignored: Disable SGR Mouse Mode"
	    }
	    1049 {
		_log "switch from alternate screen"
		_set_alternate 0
	    }
	    default {
		error "unsupported"
	    }
	}
    }
}

# Reset the attributes in attributes array UPVAR_NAME to the default values.
proc Term::_reset_attrs { upvar_name } {
    upvar $upvar_name var
    array set var {
	intensity normal
	fg default
	bg default
	underline 0
	reverse 0
	invisible 0
	blinking 0
    }
}

# Translate the color numbers as used in proc _csi_m to a name.
proc Term::_color_attr { n } {
    switch -exact -- $n {
	0 {
	    return black
	}
	1 {
	    return red
	}
	2 {
	    return green
	}
	3 {
	    return yellow
	}
	4 {
	    return blue
	}
	5 {
	    return magenta
	}
	6 {
	    return cyan
	}
	7 {
	    return white
	}
	default { error "unsupported color number: $n" }
    }
}

# Select Graphic Rendition.
#
# https://vt100.net/docs/vt510-rm/SGR.html
proc Term::_csi_m {args} {
    if { [llength $args] == 0 } {
	# Apply default.
	set args [list 0]
    }

    _log_cur "Select Graphic Rendition ([join $args {, }])" {
	variable _attrs

	foreach item $args {
	    switch -exact -- $item {
		"" - 0 {
		    _reset_attrs _attrs
		}
		1 {
		    set _attrs(intensity) bold
		}
		2 {
		    set _attrs(intensity) dim
		}
		4 {
		    set _attrs(underline) 1
		}
		5 {
		    set _attrs(blinking) 1
		}
		7 {
		    set _attrs(reverse) 1
		}
		8 {
		    set _attrs(invisible) 1
		}
		22 {
		    set _attrs(intensity) normal
		}
		24 {
		    set _attrs(underline) 0
		}
		25 {
		    set _attrs(blinking) 0
		}
		27 {
		    set _attrs(reverse) 0
		}
		28 {
		    set _attrs(invisible) 0
		}
		30 - 31 - 32 - 33 - 34 - 35 - 36 - 37 {
		    set _attrs(fg) [_color_attr [expr $item - 30]]
		}
		39 {
		    set _attrs(fg) default
		}
		40 - 41 - 42 - 43 - 44 - 45 - 46 - 47 {
		    set _attrs(bg) [_color_attr [expr $item - 40]]
		}
		49 {
		    set _attrs(bg) default
		}
	    }
	}
    }
}

# Request Terminal Parameters (DECREQTPARM)
#
# https://invisible-island.net/xterm/ctlseqs/ctlseqs.html
# https://vt100.net/docs/vt100-ug/chapter3.html
proc Term::_csi_x {} {
    # Ignore.
}

# Insert string at the cursor location.
proc Term::_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"
		    }
		}
	    }
	}

	variable _last_char
	set _last_char [string index $str end]
    }
}

# Move the cursor to the (0-based) COL and ROW positions.
proc Term::_move_cursor { col row } {
    variable _cols
    variable _rows
    variable _cur_col
    variable _cur_row

    if { $col < 0 || $col >= $_cols } {
	error "_move_cursor: invalid col value: $col"
    }

    if { $row < 0 || $row >= $_rows } {
	error "_move_cursor: invalid row value: $row"
    }


    set _cur_col $col
    set _cur_row $row
}

# Enable or disable alternate screen.
proc Term::_set_alternate { enable } {
    variable _alternate
    if { $enable == $_alternate } {
	return
    }
    set _alternate $enable

    variable _attrs
    variable _chars
    variable _cur_col
    variable _cur_row

    variable _save_attrs
    variable _save_chars
    variable _save_cur_col
    variable _save_cur_row

    variable _alternate_setup

    if { $_alternate_setup } {
	set tmp $_save_chars
    }
    set _save_chars [array get _chars]
    if { $_alternate_setup } {
	array set _chars $tmp
    }

    if { $_alternate_setup } {
	set tmp $_save_attrs
    }
    set _save_attrs [array get _attrs]
    if { $_alternate_setup } {
	array set _attrs $tmp
    }

    if { $_alternate_setup } {
	set tmp $_save_cur_col
    }
    set _save_cur_col $_cur_col
    if { $_alternate_setup } {
	set _cur_col $tmp
    }

    if { $_alternate_setup } {
	set tmp $_save_cur_row
    }
    set _save_cur_row $_cur_row
    if { $_alternate_setup } {
	set _cur_row $tmp
    }

    if { ! $_alternate_setup } {
	variable _rows
	variable _cols
	_setup $_rows $_cols
	set _alternate_setup 1
    }
}

# Initialize.
proc Term::_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
    _reset_attrs _attrs

    _clear_lines 0 $_rows
}

# Accept some output from gdb and update the screen.
# Return 1 if successful, or 0 if a timeout occurred.
proc Term::accept_gdb_output { {warn 1} } {
    global expect_out

    set ctls "\x07\x08\x0a\x0d"
    set esc "\x1b"
    set re_ctls "\[$ctls\]"
    set re_others "\[^$esc$ctls\]"
    set have_esc 0
    gdb_expect {
	-re ^$re_ctls {
	    scan $expect_out(0,string) %c val
	    set hexval [format "%02x" $val]
	    _log "wait_for: _ctl_0x${hexval}"
	    _ctl_0x${hexval}
	}
	-re "^$esc" {
	    _log "wait_for: ESC"
	    set have_esc 1
	}
	-re "^$re_others+" {
	    _insert $expect_out(0,string)
	}

	timeout {
	    # Assume a timeout means we somehow missed the
	    # expected result, and carry on.
	    warning "timeout in accept_gdb_output"
	    dump_screen
	    return 0
	}
    }

    if { !$have_esc } {
	return 1
    }

    set re_csi [string_to_regexp "\["]
    set have_csi 0
    gdb_expect {
	-re "^(\[0-9a-zA-Z\])" {
	    _log "wait_for: unsupported escape"
	    error "unsupported escape"
	}
	-re "^(\[\\(\])(\[a-zA-Z\])" {
	    scan $expect_out(1,string) %c val
	    set hexval [format "%02x" $val]
	    set cmd $expect_out(2,string)
	    eval _esc_0x${hexval}_$cmd
	}
	-re "^(\[=>\])" {
	    scan $expect_out(1,string) %c val
	    set hexval [format "%02x" $val]
	    _esc_0x$hexval
	}
	-re "^$re_csi" {
	    _log "wait_for: CSI"
	    set have_csi 1
	}

	timeout {
	    # Assume a timeout means we somehow missed the
	    # expected result, and carry on.
	    if { $warn } {
		warning "timeout in accept_gdb_output following ESC"
		dump_screen
	    }
	    _insert "^\["
	    return 0
	}
    }

    if { !$have_csi } {
	return 1
    }

    set re_csi_prefix {[?]}
    set re_csi_args {[0-9;]}
    set re_csi_cmd {[a-zA-Z@`]}
    gdb_expect {
	-re "^($re_csi_cmd)" {
	    set cmd $expect_out(1,string)
	    _log "wait_for: _csi_$cmd"
	    eval _csi_$cmd
	}
	-re "^($re_csi_args*)($re_csi_cmd)" {
	    set params [split $expect_out(1,string) ";"]
	    set cmd $expect_out(2,string)
	    _log "wait_for: _csi_$cmd <<<$params>>>"
	    eval _csi_$cmd $params
	}
	-re "^($re_csi_prefix?)($re_csi_args*)($re_csi_cmd)" {
	    set prefix $expect_out(1,string)
	    set params [split $expect_out(2,string) ";"]
	    set cmd $expect_out(3,string)
	    scan $prefix %c val
	    set hexval [format "%02x" $val]
	    _log "wait_for: _csi_0x${hexval}_$cmd <<<$expect_out(1,string)>>>"
	    eval _csi_0x${hexval}_$cmd $params
	}

	timeout {
	    # Assume a timeout means we somehow missed the
	    # expected result, and carry on.
	    if { $warn } {
		warning "timeout in accept_gdb_output following CSI"
		dump_screen
	    }
	    _insert "^\[\["
	    return 0
	}
    }

    return 1
}

# Print arg using "verbose -log" if DEBUG_TUI_MATCHING == 1.
proc Term::debug_tui_matching { arg } {
    set debug 0
    if { [info exists ::DEBUG_TUI_MATCHING] } {
	set debug $::DEBUG_TUI_MATCHING
    }

    if { ! $debug } {
	return
    }

    verbose -log "$arg"
}

# 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 Term::wait_for {wait_for} {
    global gdb_prompt
    variable _cur_col
    variable _cur_row

    set fn "wait_for"

    set prompt_wait_for "(^|\\|)$gdb_prompt \$"
    if { $wait_for == "" } {
	set wait_for $prompt_wait_for
    }

    debug_tui_matching "$fn: regexp: '$wait_for'"

    while 1 {
	if { [accept_gdb_output] == 0 } {
	    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] } {
	    debug_tui_matching "$fn: mismatch: '$prev'"
	    continue
	}

	if {$wait_for == "$prompt_wait_for"} {
	    # We've detected that the cursor is just after the prompt.
	    # Now check that there's nothing else on the line.
	    set prev [get_line $_cur_row]
	    if { ![regexp -- "(^|\\|)$gdb_prompt +($|\\||\\+)" $prev] } {
		debug_tui_matching "$fn: mismatch: '$prev'"
		continue
	    }
	}

	debug_tui_matching "$fn: match: '$prev'"

	if {$wait_for == "$prompt_wait_for"} {
	    # Matched the prompt, we're done.
	    break
	}

	# Now try to match the prompt.
	set wait_for $prompt_wait_for
	debug_tui_matching "$fn: regexp prompt: '$wait_for'"
    }

    return 1
}

# Accept some output from gdb and update the screen.  Wait for the screen
# region X/Y/WIDTH/HEIGTH to matches REGEXP.  Return 0 on timeout, 1 on
# success.
proc Term::wait_for_region_contents {x y width height regexp} {
    while 1 {
	if { [accept_gdb_output] == 0 } {
	    return 0
	}

	if { [check_region_contents_p $x $y $width $height $regexp] } {
	    break
	}
    }

    return 1
}

# Accept some output from gdb and update the screen.  Wait for the current
# screen line to match REGEXP and cursor position POS, unless POS is empty.
# Return 0 on timeout, 1 on success.
proc Term::wait_for_line { regexp {pos ""} } {
    variable _cur_row
    variable _cur_col
    variable _cols

    while 1 {
	if { [accept_gdb_output] == 0 } {
	    return 0
	}

	if { ![check_region_contents_p 0 $_cur_row $_cols 1 $regexp] } {
	    continue
	}

	if { $pos == "" || $_cur_col == $pos } {
	    break
	}
    }

    return 1
}

# In BODY, when using Term::with_tuiterm, use TERM instead of the default.

proc Term::with_term { term body } {
    save_vars { Term::_TERM } {
	set Term::_TERM $term
	uplevel $body
    }
}

# Setup the terminal with dimensions ROWSxCOLS, TERM=ansi, and execute
# BODY.
proc Term::with_tuiterm {rows cols body} {
    global env stty_init
    variable _TERM
    save_vars {env(TERM) env(NO_COLOR) stty_init} {
	if { $Term::_TERM != "" } {
	    setenv TERM $Term::_TERM
	} elseif { [ishost *-*-*bsd*] } {
	    setenv TERM ansiw
	} else {
	    setenv TERM ansi
	}
	# Save active TERM variable.
	set Term::_TERM $env(TERM)

	setenv NO_COLOR ""
	_setup $rows $cols

	uplevel $body
    }
}

# 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 Term::clean_restart {rows cols {executable {}}} {
    with_tuiterm $rows $cols {
	save_vars { ::GDBFLAGS } {
	    # Make GDB not print the directory names.  Use this setting to
	    # remove the differences in test runs due to varying directory
	    # names.
	    append ::GDBFLAGS " -ex \"set filename-display basename\""

	    if {$executable == ""} {
		::clean_restart
	    } else {
		::clean_restart $executable
	    }
	}

	::gdb_test_no_output "set pagination off"
    }
}

# Generate prompt on TUIterm.
proc Term::gen_prompt {} {
    # Generate a prompt.
    send_gdb "echo\n"

    # Drain the output before the prompt.
    gdb_expect {
	-re "echo\r\n" {
	}
    }

    # Interpret prompt using TUIterm.
    wait_for ""
}

# Setup ready for starting the tui, but don't actually start it.
# Returns 1 on success, 0 if TUI tests should be skipped.
proc Term::prepare_for_tui {} {
    if { [is_remote host] } {
	# In clean_restart, we're using "setenv TERM ansi", which has
	# effect on build.  If we have [is_remote host] == 0, so
	# build == host, then it also has effect on host.  But for
	# [is_remote host] == 1, it has no effect on host.
	return 0
    }

    if {![allow_tui_tests]} {
	return 0
    }

    gdb_test_no_output "set tui border-kind ascii"
    gdb_test_no_output "maint set tui-resize-message on"
    # When matching GDB output using Term::wait_for, the number of
    # matching attempts in wait_for can be influenced by CLI styling.
    # Disable it by default to avoid this.
    gdb_test_no_output "set style enabled off"
    return 1
}

# Start the TUI.  Returns 1 on success, 0 if TUI tests should be
# skipped.
proc Term::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 Term::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 an initial prompt.  This is used for
# initial terminal commands, where there's no prompt yet.
proc Term::command_no_prompt_prefix {cmd} {
    gen_prompt
    command $cmd
}

# Apply the attribute list in ATTRS to attributes array UPVAR_NAME.
# Return a string annotating the changed attributes.
proc Term::apply_attrs { upvar_name attrs } {
    set res ""
    upvar $upvar_name var
    foreach { attr val } $attrs {
	if { $var($attr) != $val } {
	    append res "<$attr:$val>"
	    set var($attr) $val
	}
    }

    return $res
}

# Return the text of screen line N.  Lines are 0-based.  Start at column
# X.  If C is non-empty, stop before column C.  Columns are also
# zero-based.  If ATTRS, annotate with attributes.
proc Term::get_string {n x c {attrs 0}} {
    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]
    if { $attrs } {
	_reset_attrs line_attrs
    }
    while {$x < $c} {
	if { $attrs } {
	    set char_attrs [lindex $_chars($x,$n) 1]
	    append result [apply_attrs line_attrs $char_attrs]
	}
	append result [lindex $_chars($x,$n) 0]
	incr x
    }
    if { $attrs } {
	_reset_attrs zero_attrs
	set char_attrs [array get zero_attrs]
	append result [apply_attrs line_attrs $char_attrs]
    }
    return $result
}

# Return the text of screen line N.  Lines are 0-based.  Start at column
# X.  If C is non-empty, stop before column C.  Columns are also
# zero-based. Annotate with attributes.
proc Term::get_string_with_attrs { n x c } {
    return [get_string $n $x $c 1]
}

# Return the text of screen line N.  Lines are 0-based.  If C is
# non-empty, stop before column C.  Columns are also zero-based. If
# ATTRS, annotate with attributes.
proc Term::get_line_1 {n c attrs} {
    return [get_string $n 0 $c $attrs]
}

# 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 Term::get_line {n {c ""} } {
    return [get_line_1 $n $c 0]
}

# As get_line, but annotate with attributes.
proc Term::get_line_with_attrs {n {c ""}} {
    return [get_line_1 $n $c 1]
}

# Get just the character at (X, Y).
proc Term::get_char {x y} {
    variable _chars
    return [lindex $_chars($x,$y) 0]
}

# Get the entire screen as a string.
proc Term::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 Term::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 Term::_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 Term::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)"
    }
}

# Wait until a box appears at the given coordinates.
proc Term::wait_for_box {test_name x y width height} {
    while 1 {
	if { [accept_gdb_output] == 0 } {
	    return 0
	}

	set why [_check_box $x $y $width $height]
	if {$why == ""} {
	    pass $test_name
	    break
	}
    }
}

# Check whether the text contents of the terminal match the
# regular expression.  Note that text styling is not considered.
proc Term::check_contents {test_name regexp} {
    dump_screen
    set contents [get_all_lines]
    gdb_assert {[regexp -- $regexp $contents]} $test_name
}

# As check_contents, but check that the text contents of the terminal does
# not match the regular expression.
proc Term::check_contents_not {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.  If ATTRS is true then
# include attribute information in the output.
proc Term::get_region { x y width height sep { attrs false } } {
    variable _chars

    if { $attrs } {
	_reset_attrs region_attrs
    }

    # 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} {
	    if { $attrs } {
		set char_attrs [lindex $_chars($xx,$yy) 1]
		append result [apply_attrs region_attrs $char_attrs]
	    }

	    append result [get_char $xx $yy]
	}
    }
    if { $attrs } {
	_reset_attrs zero_attrs
	set char_attrs [array get zero_attrs]
	append result [apply_attrs region_attrs $char_attrs]
    }
    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).  Return 1 if check succeeded.
proc Term::check_region_contents_p { 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"]
    return [regexp -- $regexp $result]
}

# Check that the region of the screen described by X, Y, WIDTH,
# and HEIGHT match REGEXP.  As check_region_contents_p, but produce
# a pass/fail message.
proc Term::check_region_contents { test_name x y width height regexp } {
    set ok [check_region_contents_p $x $y $width $height $regexp]
    gdb_assert {$ok} $test_name
}

# Check the contents of a box on the screen.  This is a little
# like check_contents, but doesn'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 Term::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.  If ATTRS, annotate with attributes.
proc Term::dump_screen { {attrs 0} } {
    variable _rows
    variable _cols
    variable _cur_row
    variable _cur_col

    verbose -log "Screen Dump (size $_cols columns x $_rows rows, cursor at column $_cur_col, row $_cur_row):"

    for {set y 0} {$y < $_rows} {incr y} {
	set fmt [format %5d $y]
	verbose -log "$fmt [get_line_1 $y {} $attrs]"
    }
}

# As dump_screen, but with attributes annotation.
proc Term::dump_screen_with_attrs {} {
    return [dump_screen 1]
}

# A debugging function to dump a box from the current screen, with line
# numbers.
proc Term::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 Term::_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 Term::resize {rows cols {wait_for_msg 1}} {
    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
    if { $wait_for_msg } {
	wait_for "@@ resize done $_resize_count, size = ${_cols}x${rows}"
    }
    incr _resize_count
    _do_resize $_rows $cols
    stty columns $_cols < $::gdb_tty_name
    if { $wait_for_msg } {
	wait_for "@@ resize done $_resize_count, size = ${_cols}x${rows}"
    }
    incr _resize_count
}