#!/bin/sh
# -*- tcl -*-
# The next line is executed by /bin/sh, but not tcl \
exec wish "$0" ${1+"$@"}

package require Expect

# Name: tkterm - terminal emulator using Expect and Tk text widget, v3.0
# Author: Don Libes, July '94
# Last updated: Mar '04

# 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
#   Supports scrollbars
# Good-enough-for-starters attributes:
#   Understands one kind of standout mode (reverse video)
# Should-be-fixed-soon attributes:
#   Does not support 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 rowsDumb $rows	;# number of rows in term when in dumb mode - this can
			;# increase during runtime
set cols 80		;# number of columns in term
set term .t		;# name of text widget used by term
set sb   .sb		;# name of scrollbar used by term in dumb mode
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
#############################################

# Terminal definitions are provided in both termcap and terminfo
# styles because we cannot be sure which a system might have.  The
# definitions generally follow that of xterm which in turn follows
# that of vt100.  This is useful for the most common archaic software
# which has vt100 definitions hardcoded.

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

if {$termcap} {
    set env(TERM) "tt"
    set env(TERMCAP) {tt:
	:ks=\E[?1h\E:
	:ke=\E[?1l\E>:
	:cm=\E[%d;%dH:
	:up=\E[A:
	:nd=\E[C:
	:cl=\E[H\E[J:
	:ce=\E[K:
	: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} {
    # ncurses ignores 2-char term names so use a longer name here
    set env(TERM) "tkterm"
    set env(TERMINFO) /tmp
    set ttsrc "/tmp/tt.src"
    set file [open $ttsrc w]

    puts $file {tkterm|Don Libes' tk text widget terminal emulator,
	smkx=\E[?1h\E,
	rmkx=\E[?1l\E>,
	cup=\E[%p1%d;%p2%dH,
	cuu1=\E[A,
	cuf1=\E[C,
	clear=\E[H\E[J,
	el=\E[K,
	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) "$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 \
     -yscroll "$sb set" \
     -relief sunken -bd 1 -width $cols -height $rows -wrap none -setgrid 1

# define scrollbars
scrollbar .sb -command "$term yview"

proc graphicsGet {} {return $::graphics(mode)}
proc graphicsSet {mode} {
    set ::graphics(mode) $mode

    if {$mode} {
	# in graphics mode, no scroll bars
	grid forget $::sb
    } else {
	grid $::sb -column 0 -row 0 -sticky ns
    }
}

if {$term_alone} {
    grid $term -column 1 -row 0 -sticky nsew
    # let text box only expand
    grid rowconfigure . 0 -weight 1
    grid columnconfigure . 1 -weight 1
}

$term tag configure standout -background  black -foreground white

proc term_clear {} {
	global term

	$term delete 1.0 end
	term_init
}

# pine is the only program I know that requires clear_to_eol, sigh
proc term_clear_to_eol {} {
	global cols cur_col cur_row
	
	# save current col/row
	set col $cur_col
	set row $cur_row

	set space_rem_on_line [expr $cols - $cur_col]
	term_insert [format %[set space_rem_on_line]s ""]

	# restore current col/row
	set cur_col $col
	set cur_row $row
}

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

    set ::rowsDumb $rows
}

proc term_down {} {
    global cur_row rows cols term

    if {$cur_row < $rows} {
	incr cur_row
    } else {
	if {[graphicsGet]} {
	    # in graphics mode

	    # 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
	} else {
	    # in dumb mode
	    incr cur_row

	    if {$cur_row > $::rowsDumb} {
		set ::rowsDumb $cur_row
	    }

	    $term insert $cur_row.0 [format %*s $cols ""]\n
	    $term see $cur_row.0
	}
    }
}

proc term_up {} {
    global cur_row rows cols term

    set cur_rowOld $cur_row
    incr cur_row -1

    if {($cur_rowOld > $rows) && ($cur_rowOld == $::rowsDumb)} {
	if {[regexp "^ *$" [$::term get $cur_rowOld.0 $cur_rowOld.end]]} {
	    # delete line
	    $::term delete $cur_rowOld.0 end
	}
	incr ::rowsDumb -1
    }
}

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
graphicsSet 0

set flush 0
proc screen_flush {} {
    global flush
    incr flush
    if {$flush == 24} {
	update idletasks
	set flush 0
    }
}

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
	term_up
	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\\\[K" {
	# (el,ce) Clear to end of line
	term_clear_to_eol
	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
    } "^\x1b\\\[?1h\x1b" {
	# (smkx,ks) start keyboard-transmit mode
	# terminfo invokes these when going in/out of graphics mode
	graphicsSet 1
    } "^\x1b\\\[?1l\x1b>" {
	# (rmkx,ke) end keyboard-transmit mode
	graphicsSet 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"}

set term_counter 0
proc term_expect {args} {
	upvar timeout localTimeout
	upvar #0 timeout globalTimeout
	set timeout 10
	catch {set timeout $globalTimeout}
	catch {set timeout $localTimeout}

	global term_counter
	incr term_counter
	global [set strobe _data_[set term_counter]]
	global [set tstrobe _timer_[set term_counter]]

	proc term_chars_changed {} "uplevel #0 set $strobe 1"

	set $strobe 1
	set $tstrobe 0

	if {$timeout >= 0} {
		set mstimeout [expr 1000*$timeout]
		after $mstimeout "set $strobe 1; set $tstrobe 1"
		set timeout_act {}
	}

	set argc [llength $args]
	if {$argc%2 == 1} {
		lappend args {}
		incr argc
	}

	for {set i 0} {$i<$argc} {incr i 2} {
		set act_index [expr $i+1]
		if {[string compare timeout [lindex $args $i]] == 0} {
			set timeout_act [lindex $args $act_index]
			set args [lreplace $args $i $act_index]
			incr argc -2
			break
		}
	}

	while {![info exists act]} {
		if {![set $strobe]} {
			tkwait var $strobe
		}
		set $strobe 0

		if {[set $tstrobe]} {
			set act $timeout_act
		} else {
			for {set i 0} {$i<$argc} {incr i 2} {
				if {[uplevel [lindex $args $i]]} {
					set act [lindex $args [incr i]]
					break
				}
			}
		}
	}

	proc term_chars_changed {} {}

	if {$timeout >= 0} {
		after $mstimeout unset $strobe $tstrobe
	} else {
		unset $strobe $tstrobe
	}

	set code [catch {uplevel $act} string]
	if {$code >  4} {return -code $code $string}
	if {$code == 4} {return -code continue}
	if {$code == 3} {return -code break}
	if {$code == 2} {return -code return}
	if {$code == 1} {return -code error -errorinfo $errorInfo \
				-errorcode $errorCode $string}
	return $string
}	

##################################################
# user-supplied code goes below here
##################################################

set timeout 200

# for example, wait for a shell prompt
term_expect {regexp "%" [$term get 1.0 3.end]}

# invoke game of rogue
exp_send "myrogue\r"

# wait for strength of 18
term_expect \
	{regexp "Str: 18" [$term get 24.0 24.end]} {
		# do something
	} {timeout} {
		puts "ulp...timed out!"
	} {regexp "Str: 16" [$term get 24.0 24.end]}

# and so on...