diff options
Diffstat (limited to 'expect/example/virterm')
| -rwxr-xr-x | expect/example/virterm | 634 |
1 files changed, 634 insertions, 0 deletions
diff --git a/expect/example/virterm b/expect/example/virterm new file mode 100755 index 00000000000..a703081b37d --- /dev/null +++ b/expect/example/virterm @@ -0,0 +1,634 @@ +#!../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: puts "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 } + } + } +} + + + + + + |