1#!/bin/sh
2# -*- tcl -*-
3# The next line is executed by /bin/sh, but not tcl \
4exec tclsh "$0" ${1+"$@"}
5
6package require Expect
7
8# Name: virterm - terminal emulator using Expect, v1.0, December, 1994
9# Author: Adrian Mariano <adrian@cam.cornell.edu>
10#
11# Derived from Done Libes' tkterm
12
13# This is a program for interacting with applications that use terminal
14# control sequences.  It is a subset of Don Libes' tkterm emulator
15# with a compatible interface so that programs can be written to work
16# under both.
17#
18# Internally, it uses arrays instead of the Tk widget.  Nonetheless, this
19# code is not as fast as it should be.  I need an Expect profiler to go
20# any further.
21#
22# standout mode is not supported like it is in tkterm.
23# the only terminal widget operation that is supported for the user
24# is the "get" operation.
25###############################################
26# Variables that must be initialized before using this:
27#############################################
28set rows 24		;# number of rows in term
29set cols 80		;# number of columns in term
30set term myterm		;# name of text widget used by term
31set termcap 1		;# if your applications use termcap
32set terminfo 0		;# if your applications use terminfo
33			;# (you can use both, but note that
34			;# starting terminfo is slow)
35set term_shell $env(SHELL) ;# program to run in term
36
37#############################################
38# Readable variables of interest
39#############################################
40# cur_row		;# current row where insert marker is
41# cur_col		;# current col where insert marker is
42# term_spawn_id		;# spawn id of term
43
44#############################################
45# Procs you may want to initialize before using this:
46#############################################
47
48# term_exit is called if the associated proc exits
49proc term_exit {} {
50	exit
51}
52
53# term_chars_changed is called after every change to the displayed chars
54# You can use if you want matches to occur in the background (a la bind)
55# If you want to test synchronously, then just do so - you don't need to
56# redefine this procedure.
57proc term_chars_changed {} {
58}
59
60# term_cursor_changed is called after the cursor is moved
61proc term_cursor_changed {} {
62}
63
64# Example tests you can make
65#
66# Test if cursor is at some specific location
67# if {$cur_row == 1 && $cur_col == 0} ...
68#
69# Test if "foo" exists anywhere in line 4
70# if {[string match *foo* [$term get 4.0 4.end]]}
71#
72# Test if "foo" exists at line 4 col 7
73# if {[string match foo* [$term get 4.7 4.end]]}
74#
75# Return contents of screen
76# $term get 1.0 end
77
78#############################################
79# End of things of interest
80#############################################
81
82set blankline ""
83set env(LINES) $rows
84set env(COLUMNS) $cols
85
86set env(TERM) "tt"
87if {$termcap} {
88    set env(TERMCAP) {tt:
89	:cm=\E[%d;%dH:
90	:up=\E[A:
91	:cl=\E[H\E[J:
92	:do=^J:
93	:so=\E[7m:
94	:se=\E[m:
95	:nd=\E[C:
96    }
97}
98
99if {$terminfo} {
100    set env(TERMINFO) /tmp
101    set ttsrc "/tmp/tt.src"
102    set file [open $ttsrc w]
103
104    puts $file {tt|textterm|Don Libes' tk text widget terminal emulator,
105	cup=\E[%p1%d;%p2%dH,
106	cuu1=\E[A,
107	cuf1=\E[C,
108	clear=\E[H\E[J,
109	ind=\n,
110	cr=\r,
111	smso=\E[7m,
112	rmso=\E[m,
113    }
114    close $file
115
116    set oldpath $env(PATH)
117    set env(PATH) "/usr/5bin:/usr/lib/terminfo"
118    if {1==[catch {exec tic $ttsrc} msg]} {
119	puts "WARNING: tic failed - if you don't have terminfo support on"
120	puts "your system, change \"set terminfo 1\" to \"set terminfo 0\"."
121	puts "Here is the original error from running tic:"
122	puts $msg
123    }
124    set env(PATH) $oldpath
125
126    exec rm $ttsrc
127}
128
129log_user 0
130
131# start a shell and text widget for its output
132set stty_init "-tabs"
133eval spawn $term_shell
134stty rows $rows columns $cols < $spawn_out(slave,name)
135set term_spawn_id $spawn_id
136
137proc term_replace {reprow repcol text} {
138  global termdata
139  set middle $termdata($reprow)
140  set termdata($reprow) \
141     [string range $middle 0 [expr $repcol-1]]$text[string \
142       range $middle [expr $repcol+[string length $text]] end]
143}
144
145
146proc parseloc {input row col} {
147  upvar $row r $col c
148  global rows
149  switch -glob -- $input \
150    end { set r $rows; set c end } \
151    *.* { regexp (.*)\\.(.*) $input dummy r c
152           if {$r == "end"} { set r $rows }
153        }
154}
155
156proc myterm {command first second args} {
157  global termdata
158  if {[string compare get $command]} {
159    send_error "Unknown terminal command: $command\r"
160  } else {
161    parseloc $first startrow startcol
162    parseloc $second endrow endcol
163    if {$endcol != "end"} {incr endcol -1}
164    if {$startrow == $endrow} {
165      set data [string range $termdata($startrow) $startcol $endcol]
166    } else {
167      set data [string range $termdata($startrow) $startcol end]
168      for {set i [expr $startrow + 1]} {$i < $endrow} {incr i} {
169        append data $termdata($i)
170      }
171      append data [string range $termdata($endrow) 0 $endcol]
172    }
173    return $data
174  }
175}
176
177
178proc scrollup {} {
179  global termdata blankline
180  for {set i 1} {$i < $rows} {incr i} {
181    set termdata($i) $termdata([expr $i+1])
182  }
183  set termdata($rows) $blankline
184}
185
186
187proc term_init {} {
188	global rows cols cur_row cur_col term termdata blankline
189
190	# initialize it with blanks to make insertions later more easily
191	set blankline [format %*s $cols ""]\n
192	for {set i 1} {$i <= $rows} {incr i} {
193             set termdata($i) "$blankline"
194	}
195
196	set cur_row 1
197	set cur_col 0
198}
199
200
201proc term_down {} {
202	global cur_row rows cols term
203
204	if {$cur_row < $rows} {
205		incr cur_row
206	} else {
207                scrollup
208	}
209}
210
211
212proc term_insert {s} {
213	global cols cur_col cur_row term
214
215	set chars_rem_to_write [string length $s]
216	set space_rem_on_line [expr $cols - $cur_col]
217
218	##################
219	# write first line
220	##################
221
222	if {$chars_rem_to_write <= $space_rem_on_line} {
223           term_replace $cur_row $cur_col \
224              [string range $s 0 [expr $space_rem_on_line-1]]
225           incr cur_col $chars_rem_to_write
226           term_chars_changed
227           return
228        }
229
230	set chars_to_write $space_rem_on_line
231	set newline 1
232
233        term_replace $cur_row $cur_col\
234            [string range $s 0 [expr $space_rem_on_line-1]]
235
236	# discard first line already written
237	incr chars_rem_to_write -$chars_to_write
238	set s [string range $s $chars_to_write end]
239
240	# update cur_col
241	incr cur_col $chars_to_write
242	# update cur_row
243	if {$newline} {
244		term_down
245	}
246
247	##################
248	# write full lines
249	##################
250	while {$chars_rem_to_write >= $cols} {
251                term_replace $cur_row 0 [string range $s 0 [expr $cols-1]]
252
253		# discard line from buffer
254		set s [string range $s $cols end]
255		incr chars_rem_to_write -$cols
256
257		set cur_col 0
258		term_down
259	}
260
261	#################
262	# write last line
263	#################
264
265	if {$chars_rem_to_write} {
266                term_replace $cur_row 0 $s
267		set cur_col $chars_rem_to_write
268	}
269
270	term_chars_changed
271}
272
273term_init
274
275expect_before {
276	-i $term_spawn_id
277	-re "^\[^\x01-\x1f]+" {
278		# Text
279		term_insert $expect_out(0,string)
280		term_cursor_changed
281	} "^\r" {
282		# (cr,) Go to to beginning of line
283		set cur_col 0
284		term_cursor_changed
285	} "^\n" {
286		# (ind,do) Move cursor down one line
287		term_down
288		term_cursor_changed
289	} "^\b" {
290		# Backspace nondestructively
291		incr cur_col -1
292		term_cursor_changed
293	} "^\a" {
294		# Bell, pass back to user
295		send_user "\a"
296	} "^\t" {
297		# Tab, shouldn't happen
298		send_error "got a tab!?"
299	} eof {
300		term_exit
301	} "^\x1b\\\[A" {
302		# (cuu1,up) Move cursor up one line
303		incr cur_row -1
304		term_cursor_changed
305	} "^\x1b\\\[C" {
306		# (cuf1,nd) Nondestructive space
307		incr cur_col
308		term_cursor_changed
309	} -re "^\x1b\\\[(\[0-9]*);(\[0-9]*)H" {
310		# (cup,cm) Move to row y col x
311		set cur_row [expr $expect_out(1,string)+1]
312		set cur_col $expect_out(2,string)
313		term_cursor_changed
314	} "^\x1b\\\[H\x1b\\\[J" {
315		# (clear,cl) Clear screen
316		term_init
317		term_cursor_changed
318	} "^\x1b\\\[7m" { # unsupported
319		# (smso,so) Begin standout mode
320		# set term_standout 1
321	} "^\x1b\\\[m" {  # unsupported
322		# (rmso,se) End standout mode
323		# set term_standout 0
324	}
325}
326
327
328proc term_expect {args} {
329        global cur_row cur_col  # used by expect_background actions
330
331	set desired_timeout [
332	    uplevel {
333		if {[info exists timeout]} {
334			set timeout
335		} else {
336			uplevel #0 {
337				if {[info exists timeout]} {
338					set timeout
339				} else {
340					expr 10
341				}
342			}
343		}
344	    }
345	]
346
347        set timeout $desired_timeout
348
349        set timeout_act {}
350
351	set argc [llength $args]
352	if {$argc%2 == 1} {
353		lappend args {}
354		incr argc
355	}
356
357	for {set i 0} {$i<$argc} {incr i 2} {
358		set act_index [expr $i+1]
359		if {[string compare timeout [lindex $args $i]] == 0} {
360			set timeout_act [lindex $args $act_index]
361			set args [lreplace $args $i $act_index]
362			incr argc -2
363			break
364		}
365	}
366
367        set got_timeout 0
368
369        set start_time [timestamp]
370
371	while {![info exists act]} {
372                expect timeout {set got_timeout 1}
373                set timeout [expr $desired_timeout - [timestamp] + $start_time]
374                if {! $got_timeout} \
375                {
376			for {set i 0} {$i<$argc} {incr i 2} {
377				if {[uplevel [lindex $args $i]]} {
378					set act [lindex $args [incr i]]
379					break
380				}
381			}
382		} else { set act $timeout_act }
383
384                if {![info exists act]} {
385
386                }
387	}
388
389	set code [catch {uplevel $act} string]
390	if {$code >  4} {return -code $code $string}
391	if {$code == 4} {return -code continue}
392	if {$code == 3} {return -code break}
393	if {$code == 2} {return -code return}
394	if {$code == 1} {return -code error -errorinfo $errorInfo \
395				-errorcode $errorCode $string}
396	return $string
397}
398
399
400# ======= end of terminal emulator ========
401
402# The following is a program to interact with the Cornell Library catalog
403
404
405proc waitfornext {} {
406  global cur_row cur_col term
407  term_expect {expr {$cur_col==15 && $cur_row == 24 &&
408                         " NEXT COMMAND:  " == [$term get 24.0 24.16]}} {}
409}
410
411proc sendcommand {command} {
412  global cur_col
413  exp_send $command
414  term_expect {expr {$cur_col == 79}} {}
415}
416
417proc removespaces {intext} {
418  regsub -all " *\n" $intext \n intext
419  regsub "\n+$" $intext \n intext
420  return $intext
421}
422
423proc output {text} {
424  exp_send_user $text
425}
426
427
428
429proc connect {} {
430  global term
431  term_expect {regexp {.*[>%]} [$term get 1.0 3.end]}
432  exp_send "tn3270 notis.library.cornell.edu\r"
433  term_expect {regexp "desk" [$term get 19.0 19.end]} {
434                  exp_send "\r"
435  	}
436  waitfornext
437  exp_send_error "connected.\n\n"
438}
439
440
441proc dosearch {search} {
442  global term
443  exp_send_error "Searching for '$search'..."
444  if {[string match ?=* "$search"]} {set typ ""} else {set typ "k="}
445  sendcommand "$typ$search\r"
446  waitfornext
447  set countstr [$term get 2.17 2.35]
448  if {![regsub { Entries Found *} $countstr "" number]} {
449    set number 1
450    exp_send_error "one entry found.\n\n"
451    return 1
452  }
453  if {$number == 0} {
454    exp_send_error "no matches.\n\n"
455    return 0
456  }
457  exp_send_error "$number entries found.\n"
458  if {$number > 250} {
459    exp_send_error "(only the first 250 can be displayed)\n"
460  }
461  exp_send_error "\n"
462  return $number
463}
464
465
466proc getshort {count} {
467  global term
468  output [removespaces [$term get 5.0 19.0]]
469  while {[regexp "CONTINUED on next page" [$term get 19.0 19.end]]} {
470    sendcommand "for\r"
471    waitfornext
472    output [removespaces [$term get 5.0 19.0]]
473  }
474}
475
476proc getonecitation {} {
477  global term
478  output [removespaces [$term get 4.0 19.0]]
479  while {[regexp "FORward page" [$term get 20.0 20.end]]} {
480    sendcommand "for\r"
481    waitfornext
482    output [removespaces [$term get 5.0 19.0]]
483  }
484}
485
486
487proc getcitlist {} {
488  global term
489  getonecitation
490  set citcount 1
491  while {[regexp "NEXt record" [$term get 20.0 21.end]]} {
492    sendcommand "nex\r"
493    waitfornext
494    getonecitation
495    incr citcount
496    if {$citcount % 10 == 0} {exp_send_error "$citcount.."}
497  }
498}
499
500proc getlong {count} {
501  if {$count != 1} {
502    sendcommand "1\r"
503    waitfornext
504  }
505  sendcommand "lon\r"
506  waitfornext
507  getcitlist
508}
509
510proc getmed {count} {
511  if {$count != 1} {
512    sendcommand "1\r"
513    waitfornext
514  }
515  sendcommand "bri\r"
516  waitfornext
517  getcitlist
518}
519
520#################################################################
521#
522set help {
523libsearch version 1.0 by Adrian Mariano (adrian@cam.cornell.edu)
524
525Invocation: libsearch [options] search text
526
527 -i      : interactive
528 -s      : short listing
529 -l      : long listing
530 -o file : output file (default stdout)
531 -h      : print out list of options and version number
532 -H      : print terse keyword search help
533
534The search will be a keyword search.
535Example:  libsearch -i sound and arabic
536
537}
538
539#################################################################
540
541proc searchhelp {} {
542  send_error {
543? truncation wildcard            default operator is AND
544
545AND - both words appear in record
546OR  - one of the words appears
547NOT - first word appears, second words does not
548ADJ - words are adjacent
549SAME- words appear in the same field (any order)
550
551.su. - subject   b.fmt. - books    eng.lng. - English
552.ti. - title     m.fmt. - music    spa.lng. - Spanish
553.au. - author    s.fmt. - serials  fre.lng. - French
554
555.dt. or .dt1. -- limits to a specific publication year.  E.g., 1990.dt.
556
557}
558}
559
560proc promptuser {prompt} {
561  exp_send_error "$prompt"
562  expect_user -re "(.*)\n"
563  return "$expect_out(1,string)"
564}
565
566
567set searchtype 1
568set outfile ""
569set search ""
570set interactive 0
571
572while {[llength $argv]>0} {
573  set flag [lindex $argv 0]
574  switch -glob -- $flag \
575   "-i" { set interactive 1; set argv [lrange $argv 1 end]} \
576   "-s" { set searchtype 0; set argv [lrange $argv 1 end] } \
577   "-l" { set searchtype 2; set argv [lrange $argv 1 end] } \
578   "-o" { set outfile [lindex $argv 1]; set argv [lrange $argv 2 end] } \
579   "-H" { searchhelp; exit } \
580   "-h" { send_error "$help"; exit } \
581   "-*" { send_error "\nUnknown option: $flag\n$help";exit }\
582   default { set search [join $argv]; set argv {};}
583}
584if { "$search" == "" } {
585  send_error "No search specified\n$help"
586  exit
587}
588
589exp_send_error "Connecting to the library..."
590
591set timeout 200
592
593trap { log_user 1;exp_send "\003";
594       expect_before
595       expect tn3270 {exp_send "quit\r"}
596       expect "Connection closed." {exp_send "exit\r"}
597       expect eof ; send_error "\n";
598       exit} SIGINT
599
600
601connect
602
603set result [dosearch $search]
604
605if {$interactive} {
606  set quit 0
607  while {!$quit} {
608    if {!$result} {
609      switch "[promptuser {(h)elp (n)ewsearch (q)uit? }]" {
610        n { }
611        h { searchhelp }
612        q { set quit 1}
613      }
614    } else {
615   switch "[promptuser {(s)hort (m)ed (l)ong (h)elp (n)ewsearch (q)uit? }]" {
616        s { getshort $result; ;}
617        l { getlong $result; ;}
618        m { getmed $result; ; }
619        n { research; }
620        h { searchhelp }
621        q { set quit 1; }
622      }
623    }
624  }
625} else {
626  if {$result} {
627    switch $searchtype {
628      0 { getshort $result}
629      1 { getmed $result  }
630      2 { getlong $result }
631    }
632  }
633}
634
635
636
637
638
639
640