Cross Reference: /macosx-10.10/tcl-105/tcl_ext/expect/expect/example/tkterm

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

package require Expect
package require Tk

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

# NOT YET COMPLETE!
proc term_resize {rowsNew colsNew} {
    global rows cols term

    foreach {set r 1} {$r < $rows} {incr r} {
	if {$colsNew > $cols} {
	    # add columns
	    $term insert $i.$column $blanks
	} elseif {$colsNew < $cols} {
	    # remove columns
	    # ?
	}
    }

    if {$rowsNew > $rows} {
	# add rows
    } elseis {$rowsNew < $rows} {
	# remove 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
    }
}

# New and incomplete!
bind $term <Configure> {
    scan [wm geometry .] "%dx%dx" rows cols
    stty rows $rows columns $cols < $spawn_out(slave,name)

    # when this is working, uncomment ...
    # term_resize $rows $cols
}

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