path: root/expect/example/tkterm

#!../expectk -f

# Name: tkterm - terminal emulator using Expect and Tk text widget, v1.0
# Author: Don Libes, July '94

# This is primarily for regression testing character-graphic applications.
# You can certainly use it as a terminal emulator - however many features
# in a real terminal emulator are not supported (although I'll probably
# add some of them later).

# A paper on the implementation: Libes, D., Automation and Testing of
# Interactive Character Graphic Programs", Software - Practice &
# Experience, John Wiley & Sons, West Sussex, England, Vol. 27(2),
# p. 123-137, February 1997.

###############################
# Quick overview of this emulator
###############################
# Very good attributes:
#   Understands both termcap and terminfo   
#   Understands meta-key (zsh, emacs, etc work)
#   Is fast
#   Understands X selections
#   Looks best with fixed-width font but doesn't require it
# Good-enough-for-starters attributes:
#   Understands one kind of standout mode (reverse video)
# Should-be-fixed-soon attributes:
#   Does not support scrollbar or resize
# Probably-wont-be-fixed-soon attributes:
#   Assumes only one terminal exists

###############################################
# To try out this package, just run it.  Using it in
# your scripts is simple.  Here are directions:
###############################################
# 0) make sure Expect is linked into your Tk-based program (or vice versa)
# 1) modify the variables/procedures below these comments appropriately
# 2) source this file
# 3) pack the text widget ($term) if you have so configured it (see
#    "term_alone" below).  As distributed, it packs into . automatically.

#############################################
# Variables that must be initialized before using this:
#############################################
set rows 24		;# number of rows in term
set cols 80		;# number of columns in term
set term .t		;# name of text widget used by term
set term_alone 1	;# if 1, directly pack term into .
			;# else you must pack
set termcap 1		;# if your applications use termcap
set terminfo 1		;# if your applications use terminfo
			;# (you can use both, but note that
			;# starting terminfo is slow)
set term_shell $env(SHELL) ;# program to run in term

#############################################
# Readable variables of interest
#############################################
# cur_row		;# current row where insert marker is
# cur_col		;# current col where insert marker is
# term_spawn_id		;# spawn id of term

#############################################
# Procs you may want to initialize before using this:
#############################################

# term_exit is called if the spawned process exits
proc term_exit {} {
	exit
}

# term_chars_changed is called after every change to the displayed chars
# You can use if you want matches to occur in the background (a la bind)
# If you want to test synchronously, then just do so - you don't need to
# redefine this procedure.
proc term_chars_changed {} {
}

# term_cursor_changed is called after the cursor is moved
proc term_cursor_changed {} {
}

# Example tests you can make
#
# Test if cursor is at some specific location
# if {$cur_row == 1 && $cur_col == 0} ...
#
# Test if "foo" exists anywhere in line 4
# if {[string match *foo* [$term get 4.0 4.end]]}
#
# Test if "foo" exists at line 4 col 7
# if {[string match foo* [$term get 4.7 4.end]]}
#
# Test if a specific character at row 4 col 5 is in standout
# if {-1 != [lsearch [$term tag names 4.5] standout]} ...
#
# Return contents of screen
# $term get 1.0 end
#
# Return indices of first string on lines 4 to 6 that is in standout mode
# $term tag nextrange standout 4.0 6.end
#
# Replace all occurrences of "foo" with "bar" on screen
# for {set i 1} {$i<=$rows} {incr i} {
#	regsub -all "foo" [$term get $i.0 $i.end] "bar" x
#	$term delete $i.0 $i.end
#	$term insert $i.0 $x
# }

#############################################
# End of things of interest
#############################################


unset env(DISPLAY)
set env(LINES) $rows
set env(COLUMNS) $cols

set env(TERM) "tt"
if $termcap {
    set env(TERMCAP) {tt:
	:cm=\E[%d;%dH:
	:up=\E[A:
	:nd=\E[C:
	:cl=\E[H\E[J:
	:do=^J:
	:so=\E[7m:
	:se=\E[m:
	:k1=\EOP:
	:k2=\EOQ:
	:k3=\EOR:
	:k4=\EOS:
	:k5=\EOT:
	:k6=\EOU:
	:k7=\EOV:
	:k8=\EOW:
	:k9=\EOX:
    }
}

if $terminfo {
    set env(TERMINFO) /tmp
    set ttsrc "/tmp/tt.src"
    set file [open $ttsrc w]

    puts $file {tt|textterm|Don Libes' tk text widget terminal emulator,
	cup=\E[%p1%d;%p2%dH,
	cuu1=\E[A,
	cuf1=\E[C,
	clear=\E[H\E[J,
	ind=\n,
	cr=\r,
	smso=\E[7m,
	rmso=\E[m,
	kf1=\EOP,
	kf2=\EOQ,
	kf3=\EOR,
	kf4=\EOS,
	kf5=\EOT,
	kf6=\EOU,
	kf7=\EOV,
	kf8=\EOW,
	kf9=\EOX,
    }
    close $file

    set oldpath $env(PATH)
    set env(PATH) "/usr/5bin:/usr/lib/terminfo"
    if 1==[catch {exec tic $ttsrc} msg] {
	puts "WARNING: tic failed - if you don't have terminfo support on"
	puts "your system, change \"set terminfo 1\" to \"set terminfo 0\"."
	puts "Here is the original error from running tic:"
	puts $msg
    }
    set env(PATH) $oldpath

    exec rm $ttsrc
}

set term_standout 0	;# if in standout mode or not

log_user 0

# start a shell and text widget for its output
set stty_init "-tabs"
eval spawn $term_shell
stty rows $rows columns $cols < $spawn_out(slave,name)
set term_spawn_id $spawn_id

# this shouldn't be needed if Ousterhout fixes text bug
text $term -relief sunken -bd 1 -width $cols -height $rows -wrap none

if {$term_alone} {
	pack $term
}

$term tag configure standout -background  black -foreground white

proc term_clear {} {
	global term

	$term delete 1.0 end
	term_init
}

proc term_init {} {
	global rows cols cur_row cur_col term

	# initialize it with blanks to make insertions later more easily
	set blankline [format %*s $cols ""]\n
	for {set i 1} {$i <= $rows} {incr i} {
		$term insert $i.0 $blankline
	}

	set cur_row 1
	set cur_col 0

	$term mark set insert $cur_row.$cur_col
}

proc term_down {} {
	global cur_row rows cols term

	if {$cur_row < $rows} {
		incr cur_row
	} else {
		# already at last line of term, so scroll screen up
		$term delete 1.0 "1.end + 1 chars"

		# recreate line at end
		$term insert end [format %*s $cols ""]\n
	}
}

proc term_insert {s} {
	global cols cur_col cur_row
	global term term_standout

	set chars_rem_to_write [string length $s]
	set space_rem_on_line [expr $cols - $cur_col]

	if {$term_standout} {
		set tag_action "add"
	} else {
		set tag_action "remove"
	}

	##################
	# write first line
	##################

	if {$chars_rem_to_write > $space_rem_on_line} {
		set chars_to_write $space_rem_on_line
		set newline 1
	} else {
		set chars_to_write $chars_rem_to_write
		set newline 0
	}

	$term delete $cur_row.$cur_col $cur_row.[expr $cur_col + $chars_to_write]
	$term insert $cur_row.$cur_col [
		string range $s 0 [expr $space_rem_on_line-1]
	]

	$term tag $tag_action standout $cur_row.$cur_col $cur_row.[expr $cur_col + $chars_to_write]

	# discard first line already written
	incr chars_rem_to_write -$chars_to_write
	set s [string range $s $chars_to_write end]
	
	# update cur_col
	incr cur_col $chars_to_write
	# update cur_row
	if $newline {
		term_down
	}

	##################
	# write full lines
	##################
	while {$chars_rem_to_write >= $cols} {
		$term delete $cur_row.0 $cur_row.end
		$term insert $cur_row.0 [string range $s 0 [expr $cols-1]]
		$term tag $tag_action standout $cur_row.0 $cur_row.end

		# discard line from buffer
		set s [string range $s $cols end]
		incr chars_rem_to_write -$cols

		set cur_col 0
		term_down
	}

	#################
	# write last line
	#################

	if {$chars_rem_to_write} {
		$term delete $cur_row.0 $cur_row.$chars_rem_to_write
		$term insert $cur_row.0 $s
		$term tag $tag_action standout $cur_row.0 $cur_row.$chars_rem_to_write
		set cur_col $chars_rem_to_write
	}

	term_chars_changed
}

proc term_update_cursor {} {
	global cur_row cur_col term

	$term mark set insert $cur_row.$cur_col

	term_cursor_changed
}

term_init

set flush 0
proc screen_flush {} {
	global flush
	incr flush
	if {$flush == 24} {
		update idletasks
		set flush 0
	}
#	update idletasks
#	after 1000 a
}



expect_background {
	-i $term_spawn_id
	-re "^\[^\x01-\x1f]+" {
		# Text
		term_insert $expect_out(0,string)
		term_update_cursor
	} "^\r" {
		# (cr,) Go to beginning of line
		screen_flush
		set cur_col 0
		term_update_cursor
	} "^\n" {
		# (ind,do) Move cursor down one line
		term_down
		term_update_cursor
	} "^\b" {
		# Backspace nondestructively
		incr cur_col -1
		term_update_cursor
	} "^\a" {
		bell
	} "^\t" {
		# Tab, shouldn't happen
		send_error "got a tab!?"
	} eof {
		term_exit
	} "^\x1b\\\[A" {
		# (cuu1,up) Move cursor up one line
		incr cur_row -1
		term_update_cursor
	} "^\x1b\\\[C" {
		# (cuf1,nd) Non-destructive space
		incr cur_col
		term_update_cursor
	} -re "^\x1b\\\[(\[0-9]*);(\[0-9]*)H" {
		# (cup,cm) Move to row y col x
		set cur_row [expr $expect_out(1,string)+1]
		set cur_col $expect_out(2,string)
		term_update_cursor
	} "^\x1b\\\[H\x1b\\\[J" {
		# (clear,cl) Clear screen
		term_clear
		term_update_cursor
	} "^\x1b\\\[7m" {
		# (smso,so) Begin standout mode
		set term_standout 1
	} "^\x1b\\\[m" {
		# (rmso,se) End standout mode
		set term_standout 0
	}
}

bind $term <Any-Enter> {
	focus %W
}
bind $term <Meta-KeyPress> {
	if {"%A" != ""} {
		exp_send -i $term_spawn_id "\033%A"
	}
}

bind $term <KeyPress> {
	exp_send -i $term_spawn_id -- %A
	break
}

bind $term <Control-space>	{exp_send -null}
bind $term <Control-at>		{exp_send -null}

bind $term <F1> {exp_send -i $term_spawn_id "\033OP"}
bind $term <F2> {exp_send -i $term_spawn_id "\033OQ"}
bind $term <F3> {exp_send -i $term_spawn_id "\033OR"}
bind $term <F4> {exp_send -i $term_spawn_id "\033OS"}
bind $term <F5> {exp_send -i $term_spawn_id "\033OT"}
bind $term <F6> {exp_send -i $term_spawn_id "\033OU"}
bind $term <F7> {exp_send -i $term_spawn_id "\033OV"}
bind $term <F8> {exp_send -i $term_spawn_id "\033OW"}
bind $term <F9> {exp_send -i $term_spawn_id "\033OX"}