Subversion Repositories or1k

#!../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 }
    }
  }
}