OpenCores
URL https://opencores.org/ocsvn/or1k/or1k/trunk

Subversion Repositories or1k

[/] [or1k/] [trunk/] [insight/] [expect/] [example/] [virterm] - Blame information for rev 1765

Details | Compare with Previous | View Log

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

powered by: WebSVN 2.1.0

© copyright 1999-2024 OpenCores.org, equivalent to Oliscience, all rights reserved. OpenCores®, registered trademark.