summaryrefslogtreecommitdiff
path: root/example/virterm
diff options
context:
space:
mode:
Diffstat (limited to 'example/virterm')
-rwxr-xr-xexample/virterm639
1 files changed, 639 insertions, 0 deletions
diff --git a/example/virterm b/example/virterm
new file mode 100755
index 0000000..bab254b
--- /dev/null
+++ b/example/virterm
@@ -0,0 +1,639 @@
+#!/bin/sh
+# -*- tcl -*-
+# The next line is executed by /bin/sh, but not tcl \
+exec tclsh "$0" ${1+"$@"}
+
+package require Expect
+
+# Name: virterm - terminal emulator using Expect, v1.0, December, 1994
+# Author: Adrian Mariano <adrian@cam.cornell.edu>
+#
+# Derived from Done Libes' tkterm
+
+# This is a program for interacting with applications that use terminal
+# control sequences. It is a subset of Don Libes' tkterm emulator
+# with a compatible interface so that programs can be written to work
+# under both.
+#
+# Internally, it uses arrays instead of the Tk widget. Nonetheless, this
+# code is not as fast as it should be. I need an Expect profiler to go
+# any further.
+#
+# standout mode is not supported like it is in tkterm.
+# the only terminal widget operation that is supported for the user
+# is the "get" operation.
+###############################################
+# 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 myterm ;# name of text widget used by term
+set termcap 1 ;# if your applications use termcap
+set terminfo 0 ;# 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 associated proc 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]]}
+#
+# Return contents of screen
+# $term get 1.0 end
+
+#############################################
+# End of things of interest
+#############################################
+
+set blankline ""
+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:
+ :cl=\E[H\E[J:
+ :do=^J:
+ :so=\E[7m:
+ :se=\E[m:
+ :nd=\E[C:
+ }
+}
+
+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,
+ }
+ 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
+}
+
+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
+
+proc term_replace {reprow repcol text} {
+ global termdata
+ set middle $termdata($reprow)
+ set termdata($reprow) \
+ [string range $middle 0 [expr $repcol-1]]$text[string \
+ range $middle [expr $repcol+[string length $text]] end]
+}
+
+
+proc parseloc {input row col} {
+ upvar $row r $col c
+ global rows
+ switch -glob -- $input \
+ end { set r $rows; set c end } \
+ *.* { regexp (.*)\\.(.*) $input dummy r c
+ if {$r == "end"} { set r $rows }
+ }
+}
+
+proc myterm {command first second args} {
+ global termdata
+ if {[string compare get $command]} {
+ send_error "Unknown terminal command: $command\r"
+ } else {
+ parseloc $first startrow startcol
+ parseloc $second endrow endcol
+ if {$endcol != "end"} {incr endcol -1}
+ if {$startrow == $endrow} {
+ set data [string range $termdata($startrow) $startcol $endcol]
+ } else {
+ set data [string range $termdata($startrow) $startcol end]
+ for {set i [expr $startrow + 1]} {$i < $endrow} {incr i} {
+ append data $termdata($i)
+ }
+ append data [string range $termdata($endrow) 0 $endcol]
+ }
+ return $data
+ }
+}
+
+
+proc scrollup {} {
+ global termdata blankline
+ for {set i 1} {$i < $rows} {incr i} {
+ set termdata($i) $termdata([expr $i+1])
+ }
+ set termdata($rows) $blankline
+}
+
+
+proc term_init {} {
+ global rows cols cur_row cur_col term termdata blankline
+
+ # initialize it with blanks to make insertions later more easily
+ set blankline [format %*s $cols ""]\n
+ for {set i 1} {$i <= $rows} {incr i} {
+ set termdata($i) "$blankline"
+ }
+
+ set cur_row 1
+ set cur_col 0
+}
+
+
+proc term_down {} {
+ global cur_row rows cols term
+
+ if {$cur_row < $rows} {
+ incr cur_row
+ } else {
+ scrollup
+ }
+}
+
+
+proc term_insert {s} {
+ global cols cur_col cur_row term
+
+ set chars_rem_to_write [string length $s]
+ set space_rem_on_line [expr $cols - $cur_col]
+
+ ##################
+ # write first line
+ ##################
+
+ if {$chars_rem_to_write <= $space_rem_on_line} {
+ term_replace $cur_row $cur_col \
+ [string range $s 0 [expr $space_rem_on_line-1]]
+ incr cur_col $chars_rem_to_write
+ term_chars_changed
+ return
+ }
+
+ set chars_to_write $space_rem_on_line
+ set newline 1
+
+ term_replace $cur_row $cur_col\
+ [string range $s 0 [expr $space_rem_on_line-1]]
+
+ # 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_replace $cur_row 0 [string range $s 0 [expr $cols-1]]
+
+ # 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_replace $cur_row 0 $s
+ set cur_col $chars_rem_to_write
+ }
+
+ term_chars_changed
+}
+
+term_init
+
+expect_before {
+ -i $term_spawn_id
+ -re "^\[^\x01-\x1f]+" {
+ # Text
+ term_insert $expect_out(0,string)
+ term_cursor_changed
+ } "^\r" {
+ # (cr,) Go to to beginning of line
+ set cur_col 0
+ term_cursor_changed
+ } "^\n" {
+ # (ind,do) Move cursor down one line
+ term_down
+ term_cursor_changed
+ } "^\b" {
+ # Backspace nondestructively
+ incr cur_col -1
+ term_cursor_changed
+ } "^\a" {
+ # Bell, pass back to user
+ send_user "\a"
+ } "^\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_cursor_changed
+ } "^\x1b\\\[C" {
+ # (cuf1,nd) Nondestructive space
+ incr cur_col
+ term_cursor_changed
+ } -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_cursor_changed
+ } "^\x1b\\\[H\x1b\\\[J" {
+ # (clear,cl) Clear screen
+ term_init
+ term_cursor_changed
+ } "^\x1b\\\[7m" { # unsupported
+ # (smso,so) Begin standout mode
+ # set term_standout 1
+ } "^\x1b\\\[m" { # unsupported
+ # (rmso,se) End standout mode
+ # set term_standout 0
+ }
+}
+
+
+proc term_expect {args} {
+ global cur_row cur_col # used by expect_background actions
+
+ set desired_timeout [
+ uplevel {
+ if {[info exists timeout]} {
+ set timeout
+ } else {
+ uplevel #0 {
+ if {[info exists timeout]} {
+ set timeout
+ } else {
+ expr 10
+ }
+ }
+ }
+ }
+ ]
+
+ set timeout $desired_timeout
+
+ 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
+ }
+ }
+
+ set got_timeout 0
+
+ set start_time [timestamp]
+
+ while {![info exists act]} {
+ expect timeout {set got_timeout 1}
+ set timeout [expr $desired_timeout - [timestamp] + $start_time]
+ if {! $got_timeout} \
+ {
+ for {set i 0} {$i<$argc} {incr i 2} {
+ if {[uplevel [lindex $args $i]]} {
+ set act [lindex $args [incr i]]
+ break
+ }
+ }
+ } else { set act $timeout_act }
+
+ if {![info exists act]} {
+
+ }
+ }
+
+ 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
+}
+
+
+# ======= end of terminal emulator ========
+
+# The following is a program to interact with the Cornell Library catalog
+
+
+proc waitfornext {} {
+ global cur_row cur_col term
+ term_expect {expr {$cur_col==15 && $cur_row == 24 &&
+ " NEXT COMMAND: " == [$term get 24.0 24.16]}} {}
+}
+
+proc sendcommand {command} {
+ global cur_col
+ exp_send $command
+ term_expect {expr {$cur_col == 79}} {}
+}
+
+proc removespaces {intext} {
+ regsub -all " *\n" $intext \n intext
+ regsub "\n+$" $intext \n intext
+ return $intext
+}
+
+proc output {text} {
+ exp_send_user $text
+}
+
+
+
+proc connect {} {
+ global term
+ term_expect {regexp {.*[>%]} [$term get 1.0 3.end]}
+ exp_send "tn3270 notis.library.cornell.edu\r"
+ term_expect {regexp "desk" [$term get 19.0 19.end]} {
+ exp_send "\r"
+ }
+ waitfornext
+ exp_send_error "connected.\n\n"
+}
+
+
+proc dosearch {search} {
+ global term
+ exp_send_error "Searching for '$search'..."
+ if {[string match ?=* "$search"]} {set typ ""} else {set typ "k="}
+ sendcommand "$typ$search\r"
+ waitfornext
+ set countstr [$term get 2.17 2.35]
+ if {![regsub { Entries Found *} $countstr "" number]} {
+ set number 1
+ exp_send_error "one entry found.\n\n"
+ return 1
+ }
+ if {$number == 0} {
+ exp_send_error "no matches.\n\n"
+ return 0
+ }
+ exp_send_error "$number entries found.\n"
+ if {$number > 250} {
+ exp_send_error "(only the first 250 can be displayed)\n"
+ }
+ exp_send_error "\n"
+ return $number
+}
+
+
+proc getshort {count} {
+ global term
+ output [removespaces [$term get 5.0 19.0]]
+ while {[regexp "CONTINUED on next page" [$term get 19.0 19.end]]} {
+ sendcommand "for\r"
+ waitfornext
+ output [removespaces [$term get 5.0 19.0]]
+ }
+}
+
+proc getonecitation {} {
+ global term
+ output [removespaces [$term get 4.0 19.0]]
+ while {[regexp "FORward page" [$term get 20.0 20.end]]} {
+ sendcommand "for\r"
+ waitfornext
+ output [removespaces [$term get 5.0 19.0]]
+ }
+}
+
+
+proc getcitlist {} {
+ global term
+ getonecitation
+ set citcount 1
+ while {[regexp "NEXt record" [$term get 20.0 21.end]]} {
+ sendcommand "nex\r"
+ waitfornext
+ getonecitation
+ incr citcount
+ if {$citcount % 10 == 0} {exp_send_error "$citcount.."}
+ }
+}
+
+proc getlong {count} {
+ if {$count != 1} {
+ sendcommand "1\r"
+ waitfornext
+ }
+ sendcommand "lon\r"
+ waitfornext
+ getcitlist
+}
+
+proc getmed {count} {
+ if {$count != 1} {
+ sendcommand "1\r"
+ waitfornext
+ }
+ sendcommand "bri\r"
+ waitfornext
+ getcitlist
+}
+
+#################################################################
+#
+set help {
+libsearch version 1.0 by Adrian Mariano (adrian@cam.cornell.edu)
+
+Invocation: libsearch [options] search text
+
+ -i : interactive
+ -s : short listing
+ -l : long listing
+ -o file : output file (default stdout)
+ -h : print out list of options and version number
+ -H : print terse keyword search help
+
+The search will be a keyword search.
+Example: libsearch -i sound and arabic
+
+}
+
+#################################################################
+
+proc searchhelp {} {
+ send_error {
+? truncation wildcard default operator is AND
+
+AND - both words appear in record
+OR - one of the words appears
+NOT - first word appears, second words does not
+ADJ - words are adjacent
+SAME- words appear in the same field (any order)
+
+.su. - subject b.fmt. - books eng.lng. - English
+.ti. - title m.fmt. - music spa.lng. - Spanish
+.au. - author s.fmt. - serials fre.lng. - French
+
+.dt. or .dt1. -- limits to a specific publication year. E.g., 1990.dt.
+
+}
+}
+
+proc promptuser {prompt} {
+ exp_send_error "$prompt"
+ expect_user -re "(.*)\n"
+ return "$expect_out(1,string)"
+}
+
+
+set searchtype 1
+set outfile ""
+set search ""
+set interactive 0
+
+while {[llength $argv]>0} {
+ set flag [lindex $argv 0]
+ switch -glob -- $flag \
+ "-i" { set interactive 1; set argv [lrange $argv 1 end]} \
+ "-s" { set searchtype 0; set argv [lrange $argv 1 end] } \
+ "-l" { set searchtype 2; set argv [lrange $argv 1 end] } \
+ "-o" { set outfile [lindex $argv 1]; set argv [lrange $argv 2 end] } \
+ "-H" { searchhelp; exit } \
+ "-h" { send_error "$help"; exit } \
+ "-*" { send_error "\nUnknown option: $flag\n$help";exit }\
+ default { set search [join $argv]; set argv {};}
+}
+if { "$search" == "" } {
+ send_error "No search specified\n$help"
+ exit
+}
+
+exp_send_error "Connecting to the library..."
+
+set timeout 200
+
+trap { log_user 1;exp_send "\003";
+ expect_before
+ expect tn3270 {exp_send "quit\r"}
+ expect "Connection closed." {exp_send "exit\r"}
+ expect eof ; send_error "\n";
+ exit} SIGINT
+
+
+connect
+
+set result [dosearch $search]
+
+if {$interactive} {
+ set quit 0
+ while {!$quit} {
+ if {!$result} {
+ switch "[promptuser {(h)elp (n)ewsearch (q)uit? }]" {
+ n { }
+ h { searchhelp }
+ q { set quit 1}
+ }
+ } else {
+ switch "[promptuser {(s)hort (m)ed (l)ong (h)elp (n)ewsearch (q)uit? }]" {
+ s { getshort $result; ;}
+ l { getlong $result; ;}
+ m { getmed $result; ; }
+ n { research; }
+ h { searchhelp }
+ q { set quit 1; }
+ }
+ }
+ }
+} else {
+ if {$result} {
+ switch $searchtype {
+ 0 { getshort $result}
+ 1 { getmed $result }
+ 2 { getlong $result }
+ }
+ }
+}
+
+
+
+
+
+