*** empty log message ***

This commit is contained in:
frese 2004-07-15 17:34:52 +00:00
parent 73b73841ba
commit 5be06d7481
9 changed files with 1078 additions and 0 deletions

COPYING Normal file
View File

@ -0,0 +1,2 @@
Designed and implemented by David Fisher and Olin Shivers.
Copyright (C) 1998 by the Scheme Underground.

README Normal file
View File

@ -0,0 +1,2 @@
Designed and implemented by David Fisher and Olin Shivers.
Copyright (C) 1998 by the Scheme Underground.

doc/chat.doc Normal file
View File

@ -0,0 +1,15 @@
(chat <task> <body> ...)
dynvars: $task $chat-cont $chat-abort-re $chat-timeout
(look-for* re [on-timeout])
(look-for re [on-timeout ...])
(send fmt arg ...)
(send/cr fmt arg ...)
logging output funs?
side-effecting option setting
(chat-abort <re>)
(chat-timeout <nsecs>)

doc/expect.doc Normal file
View File

@ -0,0 +1,166 @@
The Scheme Underground Expect package
Designed and implemented by David Fisher and Olin Shivers
(spawn* THUNK) -> task procedure
Spawn* forks a process to execute THUNK, and returns a task data-structure
that contains all of the information that expect-package elements need in
order to interact with that process.
(spawn . EPF) -> task procedure
This is syntactic sugar for (spawn* (lambda () (exec-epf EPF))).
Spawns the epf.
(ports->task INPUT-PORT OUTPUT-PORT) -> task procedure
This procedure constructs a task from a pair of ports.
(task:in TASK) -> output-port procedure
(task:out TASK) -> input-port procedure
(task:process TASK) -> process procedure
These three procedures return, in order, the input port that can be used to
get data from the task, the output port that can be used to send data to the
task, and the process that the task is running.
(task:pre-match TASK) -> string procedure
(task:buf TASK) -> string procedure
When an EXPECT pattern matches some input, the task:pre-match field is set to
the string preceding the matched data, and the task:buf field is set to the
string coming after the matched data, that is, it saves input that hasn't
yet been processed. When EXPECT starts, it first considers any data stored
in the task:buf field.
(set-task:pre-match TASK STR)
(set-task:buf TASK STR)
(EXPECT [<name> <loop-var-inits>] <eclause> ...) -> values syntax
<eclause> ::= (<task> <aclause> ...) [Task clause.]
| <option-clause>
| (ON-TIMEOUT <body> ...) [Do on timeout.]
Action clauses:
<aclause> ::= (ON-EOF <body> ...) [Do on EOF.]
| (<pattern> <matchvars> <exp> ...) [Do if pattern matches.]
| (TEST . <cond-clause>)
<matchvars> ::= () [No match info]
| (<matchvar>) [Match struct only]
| (<matchvar> <submatch-var0> ...) [...also submatch strings.]
<option-clause> ::= (OPTION <option> ...)
<option> ::= (TIMEOUT <nsecs>)
| (ECHO <bool>) ; Not supported
| (MAX-SIZE <nchars>) ; Not supported
| (MONITOR <proc>)
Expect takes a number of tasks, and waits for a number of patterns to
be output by these tasks. When expect sees a pattern for which it has been
waiting, it executes the appropriate list of commands. The two types of
expect clauses are option clauses and task-pattern clauses.
Option clauses take the form (OPTION <option> ...)
where an <option> is one of
(TIMEOUT <nsecs>) This controls how long expect waits for the patterns
before timing out. The lowest timeout clause
determines when the entire expect form will time out.
A timeout value of #f means no timeout. The default
value is ... seconds.
(MONITOR <proc>) This hook establishes a monitor procedure for the
the expect processing. A monitor is a procedure
of one argument, that is applied when various
events occur:
regexp Match occurred.
string New input arrived.
This string will not span a match.
That is, if new input arrives and
is matched, then we only report the
new input up to the end of the match.
The rest of the input is saved in the
task's push-back buffer and is not reported.
'timeout EXPECT timed out.
An action clause <aclause> can be one of
(<pattern> <matchvars> <body> ...)
If the pattern matches input read from the task, expect binds the
match vars and then executes the body forms. The value of the whole
EXPECT form is the value produced by the last body form. The match
vars list is of the form
([<match-var> [<sub-match-var0> ... <sub-match-varN>]])
<match-var> is bound to the regexp match structure. <sub-match-varI>
is bound to the string corresponding to the regexp's Ith sub-match
(where sub-match 0 is the string for the whole match). Any of these
variables may be #F instead of an identifier, meaning a "don't-care"
(on-eof EXPRESSION ...)
If EXPECT hits EOF on the task without finding a match, this clause
is triggered. If EXPECT hits EOF and there is no ON-EOF clause for
the task, nothing happens.
(test . COND-CLAUSE)
This allows for general conditionals to be placed into the
EXPECT form.
(INTERACT <task> <iclause> ...) syntax
Interact allows the user to interact with a running task, relaying the
keys pressed by the user to the task and outputting the characters
provided by the task to the user. If clauses are provided by the
programmer, interact will filter input before passing it along to the
task. A clause is either a character-clause or a filter-clause.
(<character> <continuation-variable> <body> ...)
When interact matches the character, it bind the continuation variable
to the continuation out of the interaction, then evaluates the clause
(FILTER <procedure>)
Where filter is passed two variables, the character input and the
continuation out of the interaction. In both cases, if the clause
returns true, it falls through to the next clause. If all clauses
fall through, the character is passed on to the task. However, the
continuation still needs to be called in order to break out of the
Example: (filter (lambda (c k)
(send STRING TASK) -> (undefined) procedure
Send sends the string to the task, as if a user had typed it.
(close-task TASK) -> (undefined) procedure
Close-task closes all input and output ports corresponding to the indicated
(wait-task TASK) -> (undefined) procedure
Wait-task waits for the indicated task to complete, reaping the task.
Tty-Mung Package
(modify-tty-info PROC [PORT]) procedure
Modify-tty-info applies PROC to either the tty-info of the current
input port, or the indicated PORT, changing the state of the terminal.
There are five procedures provided to use with modify-tty-info:
echo-off Turns terminal echoing off.
echo-on Turns terminal echoing on.
raw Puts the terminal into raw mode. Raw-initialize _must_
be used after raw for it to work right.
raw-initialize Initializes the min and time fields of a raw terminal.
canonical Puts the terminal into raw mode.

scheme/chat.scm Normal file
View File

@ -0,0 +1,165 @@
;;; Chat for scsh.
;;; Designed and implemented by David Fisher and Olin Shivers.
;;; Copyright (C) 1998 by the Scheme Underground.
;;; $chat-task $chat-cont $chat-abort-re $chat-timeout $chat-monitor
;;; These are the fluid vars bound by CHAT.
(define $chat-task (make-fluid #f)) ; I/O task
(define $chat-cont (make-fluid #f)) ; Continuation used to abort the CHAT
(define $chat-monitor (make-fluid #f))
;;; This is my lame approximation to a regexp that matches nothing.
;;; It will never match a non-empty string, in any event, and that's
;;; good enough for this app.
(define default-chat-abort-re (make-regexp "^$"))
;;; Regexp that causes any LOOK-FOR clause to abort out of the CHAT.
(define $chat-abort-re (make-fluid default-chat-abort-re))
(define (chat-abort re) (set-fluid! $chat-abort-re (->regexp re)))
;;; Number of seconds a LOOK-FOR clause should wait before timing out.
(define $chat-timeout (make-fluid 45))
;;; These guys override the defaults.
(define (chat-timeout nsecs) (set-fluid! $chat-timeout nsecs))
(define (chat-monitor cmon) (set-fluid! $chat-monitor cmon))
(define-syntax define-simple-syntax
(syntax-rules ()
((define-simple-syntax (name . pattern) result)
(define-syntax name (syntax-rules () ((name . pattern) result))))))
(define-simple-syntax (chat task exp ...)
(chat* task (lambda () exp ...)))
(define (chat* task thunk)
(lambda (k)
(let-fluids $chat-task task
$chat-abort-re default-chat-abort-re
$chat-cont k
$chat-timeout 45
$chat-monitor #f
(lambda ()
(with-current-output-port (task:out task)
(with-current-input-port (task:in task)
(define (look-for* re . maybe-on-timeout)
(let ((tmout (fluid $chat-timeout))
(chat-cont (fluid $chat-cont))
(task (fluid $chat-task))
(abort-re (fluid $chat-abort-re))
(cmon (fluid $chat-monitor)))
(if cmon (cmon 'looking-for re))
(expect (option (timeout tmout) ; Timeout in $chat-timeout secs.
(monitor (if cmon
(chat->expect-monitor cmon)
(lambda (task event) #f)))) ; No-op
;; Expect triggers the monitor for us on timeout.
(on-timeout (if (pair? maybe-on-timeout) ; Timeout =>
((car maybe-on-timeout)) ; Call handler or
(chat-cont 'timeout))) ; abort.
(task (re (m) ; See RE => return false.
(if cmon (cmon 'found m))
(abort-re (#f s) ; See $chat-abort-re =>
(if cmon (cmon 'abort #f)) ; abort & return the
(chat-cont s)) ; abort string.
;; EXPECT triggers the monitor for us.
(chat-cont 'eof))))))
(define-syntax look-for
(syntax-rules ()
((look-for re) (look-for* re))
((look-for re on-timeout ...)
(look-for* re (lambda () on-timeout ...)))))
;;; chat-logger monitors
;;; Monitors are called on the following events:
;;; - looking-for(re)
;;; - found(match)
;;; - new-input(text)
;;; - sending(text)
;;; - abort
;;; - eof
;;; - timeout
;;; Builds a chat monitor from an expect monitor.
;;; We do nothing with match events, because it's ambiguous --
;;; we might have matched what the user was looking for, or we might
;;; have matched the abort pattern. So chat puts the chat monitor calls
;;; directly in the EXPECT form.
(define (chat->expect-monitor cmon)
(lambda (task event)
(cond ((not event) (cmon 'eof #f))
((string? event) (cmon 'new-input event))
((regexp-match? event)) ; Do nothing
((eq? 'timeout event) (cmon 'timeout #f))
(else (error "Unknown EXPECT event" task event)))))
(define (port->chat-logger port)
(lambda (event val)
(case event
((looking-for) (format port "expect(~a)\n" val))
((found) (write-string "-- got it\n" port))
((new-input) (format port "[~a]" val))
((sending) (format port "send(~a)\n" val))
((eof) (write-string "EOF encountered.\n" port))
((timeout) (write-string "-- timed out. \n" port))
((abort) (write-string "-- aborting. \n" port))
(else (format port "Unknown chat event: ~a ~a\n" event val)))
(force-output port)))
(define (file->chat-logger fname . maybe-open-flags)
(port->chat-logger (apply open-output-file fname maybe-open-flags)))
;;; Monitor-aware I/O procedures
;;; Outputs to (CURRENT-OUTPUT-PORT)
;;; and also triggers the current chat monitor.
(define (send fmt . args)
(cond ((fluid $chat-monitor) =>
(lambda (cm)
(let ((s (apply format #f fmt args)))
(cm 'sending s)
(write-string s))))
(else (apply format (current-output-port) fmt args))))
(define (send/cr fmt . args)
(cond ((fluid $chat-monitor) =>
(lambda (cm)
(let ((s (string-append (apply format #f fmt args) "\r")))
(cm 'sending s)
(write-string s))))
(else (apply format (current-output-port) fmt args)
(write-string "\r"))))
;;; (define (dialin modem phone-num username password)
;;; (chat modem
;;; (send "ATZ\r")
;;; (look-for "OK")
;;; (send "ATDT~a\r" phone-num)
;;; (look-for "CONNECT")
;;; (look-for "ogin:"
;;; (send "\r")
;;; (look-for "ogin:"))
;;; (send/cr username)
;;; (look-for "assword:")
;;; (send/cr password)
;;; (look-for "%")))

scheme/expect-syntax.scm Normal file
View File

@ -0,0 +1,288 @@
;;; The EXPECT macro expander
(define syntax-error (structure-ref signals error))
;;; LET*, except that you can use multiple-value expressions in the binding
;;; forms. MLET = "M ultiple-value LET." I use this to keep the very long
;;; expect-expander code from drifting off the right side of the screen.
(define-syntax mlet
(syntax-rules ()
((mlet () body ...) (begin body ...))
;; Hack -- If a clause binds 0 vals, we *ignore* its return vals.
;; We don't require it to return exactly 0 vals.
((mlet ((() exp) init ...) body ...)
(begin exp (mlet (init ...) body ...)))
((mlet (((v ...) exp) init ...) body ...)
(receive (v ...) exp
(mlet (init ...) body ...)))
((mlet ((v exp) init ...) body ...)
(let ((v exp)) (mlet (init ...) body ...)))))
(define (filter pred lis)
(if (pair? lis)
(let ((x (car lis)))
(if (pred x) (cons x (filter pred (cdr lis)))
(filter pred (cdr lis))))
(define (partition pred lis)
(if (pair? lis)
(let ((x (car lis)))
(receive (ins outs) (partition pred (cdr lis))
(if (pred x)
(values (cons x ins) outs)
(values ins (cons x outs)))))
(values '() '())))
;;; This is a hairy mother. If you ever try to read it or change it, you are
;;; advised to first try expanding a couple of toy examples and looking at the
;;; output to get a feel for the basic compilation strategy.
(define (expand-expect exp r c)
(mlet (((exp-name loop-var-inits clauses) ; Parse out the loop name
(if (and (<= 3 (length exp)) ; and var inits, if any.
(not (pair? (cadr exp))))
(values (cadr exp) (caddr exp) (cdddr exp)) ; Yep.
(values #f '() (cdr exp)))) ; Nope.
;; Parse the clauses into task clauses, a list of options,
;; and 0 or 1 on-timeout clauses.
((task-clauses options timeout-clauses)
(let recur ((clauses clauses))
(if (pair? clauses)
(let ((clause (car clauses)))
(receive (t o to) (recur (cdr clauses))
(cond ((not (pair? clause))
(syntax-error "Bad EXPECT clause" clause))
((c (car clause) (r 'option))
(values t (append (cdr clause) o) to))
((c (car clause) (r 'on-timeout))
(if (null? to)
(values t o (cons (cdr clause) to))
(syntax-error "Too many ON-TIMEOUT clauses in EXPECT" exp)))
;; It's a task clause.
(else (values (cons clause t) o to)))))
(values '() '() '()))))
;; Parse each task clause into three parts: the task expression, the
;; pattern/action aclauses, and 0 or 1 ON-EOF aclauses.
((tasks pa-clauses-list eof-clauses)
(let recur ((clauses task-clauses))
(if (pair? clauses)
(let* ((clause (car clauses))
(task (car clause))
(aclauses (cdr clause)))
(receive (tasks pas eofs) (recur (cdr clauses))
(receive (this-tasks-eofs this-tasks-pas)
(partition (lambda (ac)
(if (pair? ac)
(c (car ac) (r 'on-eof))
(syntax-error "Bad action clause in EXPECT"
clause ac)))
(if (> (length this-tasks-eofs) 1)
(syntax-error "Too many ON-EOF action clauses in EXPECT"
(values (cons task tasks)
(cons this-tasks-pas pas)
(cons this-tasks-eofs eofs))))))
(values '() '() '()))))
(%vector (r 'vector)) ; Bind a mess of syntax
(%lambda (r 'lambda))
(%let (r 'let))
(%let* (r 'let*))
(%letrec (r 'letrec))
(%begin (r 'begin))
(%and (r 'and))
(%string-match (r 'string-match))
(%vector (r 'vector))
(%let-match (r 'let-match))
(%s (r 's))
(%i (r 'i))
(%m (r 'm))
(%monitor (r 'mon))
(%do-next (r 'do-next))
(%do-match-hacking (r 'do-match-hacking))
(%do-select (r 'do-select))
(%=> (r '=>))
(%test (r 'test))
(%else (r 'else))
(%cond (r 'cond))
(%try-task (r 'try-task))
(%task:buf (r 'task:buf))
(%task:in (r 'task:in))
(%set-prematch (r 'set-prematch))
(%first-try (r 'first-try))
(%time (r 'time))
(%receive (r 'receive))
(%select! (r 'select!))
(%if (r 'if))
(%- (r '-))
(%+ (r '+))
(%> (r '>))
;; Now we need a bunch of label names. Task clause #3 needs
;; try-task3, task3, try-match3, and maybe do-eof3 (if it has
;; an ON-EOF action clause)
(task-indices (let recur ((tclauses task-clauses) (i 0))
(if (pair? tclauses)
(cons i (recur (cdr tclauses) (+ i 1)))
(vari (lambda (s i)
(r (string->symbol (string-append s (number->string i))))))
(try-task-vars (map (lambda (i) (vari "try-task" i)) task-indices))
(task-vars (map (lambda (i) (vari "task" i)) task-indices))
(try-match-vars (map (lambda (i) (vari "try-match" i)) task-indices))
(do-eof-vars (map (lambda (i maybe-eof-clause)
;; #F if the tclause doesn't have an ON-EOF aclause.
(and (pair? maybe-eof-clause)
(vari "do-eof" i)))
task-indices eof-clauses))
;; do-next[i] is the proc task I should call to
;; do the next thing.
(do-nexts (append (cdr try-task-vars)
(list %do-select)))
;; Build a bunch of LET bindings.
;; First, evaluate and bind all the tasks.
(task-bindings (map list task-vars tasks))
;; Bind IVEC to the task vector.
(ivec (r 'ivec))
(ivec-binding `(,ivec (,%vector ,@(map (lambda (tv) `(,%task:in ,tv))
;; Build a bunch of LETREC bindings.
;; First, the do-eof bindings.
(do-eofs1 (map (lambda (label bodies) ; (length BODIES) < 2.
(and (pair? bodies)
`(,label (,%lambda () . ,(cdar bodies)))))
do-eof-vars eof-clauses))
(do-eofs (filter (lambda (x) x) do-eofs1))
;; Second, the try-matchI bindings.
(pa->cond-clause (lambda (pa-clause task)
(if (c (car pa-clause) %test)
(cdr pa-clause)
`((,%string-match ,(car pa-clause) ,%s) ,%=>
(,%lambda (,%m)
(,%do-match-hacking ,task ,%m ,%s ,%i ,%monitor)
(,%let-match ,%m . ,(cdr pa-clause)))))))
(try-matcher (lambda (pa-clauses task)
`(,%lambda (,%s ,%i ,%do-next)
(,%cond ,@(map (lambda (pa)
(pa->cond-clause pa task))
(,%else (,%monitor ,task ,%i)
(try-matches (map (lambda (label task pa-clauses)
`(,label ,(try-matcher pa-clauses task)))
;; Third, the try-taskI bindings
(try-tasks (map (lambda (label task i match-tryer
do-next do-eof)
`(,label (,%lambda ()
(,%try-task ,ivec ,i ,task ,match-tryer
,(or do-eof do-next)
try-task-vars task-vars task-indices
try-match-vars do-nexts do-eof-vars))
;; When EXPECT starts, there may be leftover data sitting in
;; the task buffers from a previous EXPECT execution (too bad
;; we don't have infinite push-back ports). So we have to run
;; all the pattern/action match code before doing the select
;; call, or trying to do input. This expression is the code
;; that does this. If there *isn't* any saved-up input in a
;; task's push-back buffer, we don't call the task's try-match
;; proc.
(let recur ((try-matchers try-match-vars)
(tasks task-vars))
(if (pair? try-matchers)
(let ((try-match (car try-matchers))
(try-matchers (cdr try-matchers))
(task (car tasks))
(tasks (cdr tasks)))
`(,%first-try ,task ,try-match
(,%lambda () ,(recur try-matchers tasks))))
;; Parse the options
((timeout-secs mon-exp)
(let lp ((timeout-secs 10) (mon-exp (r 'null-monitor))
(opts options))
(if (pair? opts)
(let ((opt (car opts))
(opts (cdr opts)))
(if (or (not (pair? opt))
(not (= (length opt) 2)))
(syntax-error "Illegal EXPECT option" opt))
(let ((kw (car opt)))
(cond ((c kw (r 'timeout))
(lp (cadr opt) mon-exp opts))
((c kw (r 'monitor))
(lp timeout-secs (cadr opt) opts))
(else (syntax-error "Illegal EXPECT option" opt)))))
(values timeout-secs mon-exp))))
;; Build the select code.
;; The TIME-DONE var is bound to "what time we time out",
;; not "how many seconds until we time out."
(timeout-var (and timeout-secs (r 'time-done)))
(loop-top `(,%lambda ()
(,%receive (in out ex)
(,%select! ,ivec '#() '#()
,@(if timeout-var
`((,%and ,timeout-var
(,%- ,timeout-var (,%time))))
(,%if (,%> in 0)
(,(car try-task-vars))
,(if (pair? timeout-clauses)
`(,%begin ,@(car timeout-clauses))
;; This is the core letrec -- the wait-for-input &
;; try-to-match loop.
(inner-loop `(,%letrec (,@do-eofs
(,%do-select ,loop-top))
;; This is the outer, named loop (if any).
(named-loop (if exp-name
`(,%let ,exp-name ,loop-var-inits
;; Build the final expression.
`(,%let* (,@task-bindings
(,%monitor ,mon-exp)
,@(if timeout-var
`((,timeout-var ,timeout-secs)
(,timeout-var (,%and ,timeout-var
(,%+ (,%time) ,timeout-var))))
'())) ; No timeout-var binding needed.

scheme/expect.scm Normal file
View File

@ -0,0 +1,267 @@
;;; Expect for scsh.
;;; Designed and implemented by David Fisher and Olin Shivers.
;;; Copyright (C) 1998 by the Scheme Underground.
;;; Todo:
;;; - Fairness & round-robin looping
;;; - If all tasks eof, should we detect this and bail out early?
;;; - I need a little toolkit for constructing monitors.
;;; If I had infinite-pushback ports, I could flush the "task" structure
;;; entirely. This would be better done with a transducer architecture.
;;; Interact
;;; - -nobuffer is useful for spotting stuff as it flies by.
;;; - It can handle matching in both directions.
;;; - It can handle strings and regexps.
;;; This file contains the following Scheme 48 modules:
;;; - expect-syntax-support
;;; This package must be opened in expect-package's FOR-SYNTAX package,
;;; so that the EXPECT macro-expander code can use its procedure.
;;; - expect-package
;;; This package must be opened by expect's clients.
(define error (structure-ref signals error))
(define-syntax expect expand-expect)
;;; A task is a guy with whom we can interact.
(define-record task
(buf "")
(pre-match #f)) ; Everything before the current match.
(define (tsend task fmt . args)
(apply format (task:out task) fmt args))
(define tsend-line
(let ((cr (string-ref "\r" 0))) ; Ugh
(lambda (task fmt . args)
(let ((p (task:out task)))
(apply format p fmt args)
(write-char cr p)))))
(define (user-task)
(ports->task (current-input-port) (current-output-port)))
;;; Spawn a process.
(define (spawn* thunk)
(receive (process in out tty) (fork-pty-session thunk)
(set-port-buffering in bufpol/none)
(set-port-buffering out bufpol/none)
(make-task process in out)))
(define-syntax spawn
(syntax-rules ()
((spawn . epf) (spawn* (lambda () (exec-epf . epf))))))
;;; Make a pseudo-task.
(define (ports->task input-port output-port)
(set-port-buffering input-port bufpol/none)
(set-port-buffering output-port bufpol/none)
(make-task #f input-port output-port))
(define (file->task fname)
(let* ((iport (open-file fname open/read+write))
(oport (dup->outport iport)))
(ports->task iport oport)))
(define (close-task task)
(close (task:in task))
(close (task:out task)))
;;;; Append info to a buffer without its going over the max size.
;;;; As data is moved out of the match buffer, it is moved into
;;;; the pre-match buffer.
;;;; Ack, this is not too efficient. Need to change this whole style.
;(define (buf-append task str max-size)
; (let* ((buf (task:buf task))
; (buf-size (string-length buf))
; (str-size (string-length str))
; (total-size (+ buf-size str-size)))
; (cond ((<= total-size max-size) ; BUF := all of BUF + all of STR.
; (string-append buf str))
; ;; BUF := some of BUF + all of STR.
; ((<= str-size max-size)
; (let ((i (- total-size max-size)))
; (set-task:pre-match (string-append (task:pre-match task)
; (substring buf 0 i)))
; (string-append (substring buf i buf-size)
; str)))
; ;; BUF := some of STR.
; (else (let ((i (- str-size max-size)))
; (set-task:pre-match (string-append (task:pre-match task)
; buf
; (substring str 0 i)))
; (substring str i str-size))))))
;;; We just matched M out of BUFFER.
;;; - Put everything in BUFFER *before* the match into (TASK:PRE-MATCH TASK).
;;; - Put everything in BUFFER *after* the match into (TASK:BUF TASK).
(define (set-prematch task buffer m)
(set-task:pre-match task (substring buffer 0 (match:start m)))
(set-task:buf task
(substring buffer (match:end m) (string-length buffer))))
;;; Slurp in data from port ivec[i] and add it to the task's buffer.
;;; Return the new data (not the whole buffer).
;;; If we get EOF instead, set ivec[i] to #f and return false. This is
;;; really inefficient in space and time -- every time we get a little bit
;;; of input, we copy and throw away the whole match buffer. Argh.
(define (do-input task)
(let* ((port (task:in task))
;; If the read blows up, return #f. This is how tty's indicate
;; to pty's they've been closed. Ugh.
(s (with-errno-handler ((e p) ((errno/io) #f))
(read-string/partial 256 port))))
(and s (let ((newbuf (string-append (task:buf task) s)))
(set-task:buf task newbuf)
;;; A (<task> <aclause> ...) task-clause becomes the following chunk of code
;;; that is executed after the select call on ivec[]. I is the index of
;;; <task>'s input port in the port vector ivec:
;;; If ivec[i] is non-#f
;;; -- Select says there's input available.
;;; Get input from task
;;; If EOF
;;; ivec[i] := #f (This task is now permanently out of the running.)
;;; If there's an ON-EOF clause, do it and quit.
;;; If no ON-EOF clause, go on to task i+1.
;;; else we got some data:
;;; Try out matches. On match, do the match action & we are done.
;;; If no match, go on to task i+1
;;; If ivec[i] is #f
;;; -- No input available right now.
;;; ivec[i] := taski.in (Put the input port back in the vector)
;;; go on to task i+1
;;; "go on to task i+i" means "loop back to the select call" when task i
;;; is the last one.
(define (try-task ivec i task try-match-clauses do-next do-eof monitor)
(if (vector-ref ivec i)
;; Input is available (or EOF). Read it in.
;; If we get some, try out the pattern/action clauses.
;; If we get EOF, do the EOF action (which is the ON-EOF action clause,
;; if there is one, or go on to the next task clause if there isn't).
(cond ((do-input task) =>
(lambda (i) (try-match-clauses (task:buf task) i do-next)))
(set-task:pre-match task (task:buf task))
(set-task:buf task "")
(monitor task #f) ; Signal EOF
(vector-set! ivec i #f)))
;; No input available for task i. Put it back in the select vector
;; for next time, and go on to the next thing.
(begin (vector-set! ivec i (task:in task))
;;; M is the match. S is the total string. I is the new data that just
;;; arrived -- a non-empty suffix of S.
(define (do-match-hacking task m s i monitor)
;; Log all new data up to the match.
(let* ((delta (- (string-length s) (string-length i)))
(mend (- (match:end m 0) delta)))
(monitor task (substring i 0 mend))
(monitor task m))
(set-prematch task s m)) ; Set the prematch buffer.
;;; The default monitor -- does nothing.
(define (null-monitor task event) #f)
(define (port->monitor p)
(let ((strs '())
(cr (string-ref "\r" 0))) ; Ugh.
(lambda (task event)
(format (error-output-port) "strs=~s\n" strs)
(let ((flush-trailing-line
(lambda ()
(write-string "Expect: " p)
(for-each (lambda (s) (write-string s p))
(reverse strs))
(set! strs '())))
(lambda (s) (if (> (string-length s) 0)
(set! strs (cons s strs)))))
;; Index of the last cr or nl, or false. Lame code.
(lambda (s)
(cond ((string-index-right s #\newline) =>
(lambda (last-nl)
(max last-nl (or (string-index-right s cr) -1))))
(else (string-index-right s cr))))))
(cond ;; EOF event
((not event)
(cond ((pair? strs)
(write-char #\newline p)))
(write-string "Expect: End of file\n" p))
;; New-input event
;; We write out stuff in line chunks.
((string? event)
(cond ((last-line-break event) =>
(lambda (lb)
(write-string event p 0 (+ 1 lb))
(add-line-frag (substring event
(+ lb 1)
(string-length event)))))
(else (add-line-frag event))))
;; Match event
((regexp-match? event)
(write-string "-- got it.\n" p))
;; Timeout event
((eq? event 'timeout)
(cond ((pair? strs)
(write-char #\newline p)))
(write-string "Expect: Timed out.\n" p))
(else (format p "Expect: Unknown event ~a\n" event))))
(force-output p))))
;;; When we first start the expect form, there may be saved-up data in
;;; the task's push-back buffer. If so, we need to try and match it with
;;; the task's try-match function TM. If not, we jump off to OTHERWISE.
(define (first-try task tm otherwise)
(let ((s (task:buf task)))
(if (zero? (string-length s)) (otherwise)
(tm s s otherwise))))

scheme/let-match.scm Normal file
View File

@ -0,0 +1,99 @@
;;; These are some macros to support using regexp matching.
;;; (let-match m mvars body ...)
;;; Bind the match & submatch vars, and eval the body forms.
(define-syntax let-match
(lambda (exp r c)
(if (< (length exp) 3)
(error "No match-vars list in LET-MATCH" exp))
(let ((m (cadr exp)) ; The match expression
(mvars (caddr exp)) ; The match vars
(body (cdddr exp)) ; The expression's body forms
(%begin (r 'begin))
(%match:substring (r 'match:substring))
(%let* (r 'let*)))
(cond ((null? mvars) `(,%begin ,@body))
((pair? mvars)
(let* ((msv (or (car mvars) (r 'match-val))) ; "match-struct var"
(sm-bindings (let recur ((i 0) (vars (cdr mvars)))
(if (pair? vars)
(let ((var (car vars))
(bindings (recur (+ i 1) (cdr vars))))
(if var
(cons `(,var (,%match:substring ,msv ,i))
`(,%let* ((,msv ,m) ,@sm-bindings) ,@body)))
(else (error "Illegal match-vars list in LET-MATCH" mvars exp))))))
(define-syntax if-match
(syntax-rules ()
((if-match match-exp mvars on-match no-match)
(cond (match-exp => (lambda (m) (let-match m mvars on-match)))
(else no-match)))))
;;; (MATCH-COND (<match-exp> <match-vars> <body> ...)
;;; (TEST <exp> <body> ...)
;;; (TEST <exp> => <proc>)
;;; (ELSE <body> ...))
;;; The first clause is as-in IF-MATCH; the next three clauses are as-in COND.
;;; It would be slicker if we could *add* extra clauses to the syntax
;;; of COND, but Scheme macros aren't extensible this way.
(define-syntax match-cond
(syntax-rules (else test =>)
((match-cond (else body ...) clause2 ...) (begin body ...))
((match-cond) (cond))
((match-cond (TEST exp => proc) clause2 ...)
(let ((v exp)) (if v (proc v) (match-cond clause2 ...))))
((match-cond (TEST exp body ...) clause2 ...)
(if exp (begin body ...) (match-cond clause2 ...)))
((match-cond (TEST exp) clause2 ...)
(or exp (match-cond clause2 ...)))
((match-cond (match-exp mvars body ...) clause2 ...)
(if-match match-exp mvars (begin body ...)
(match-cond clause2 ...)))))
(define-syntax match-cond
(syntax-rules ()
((match-cond clause ...) (match-cond-aux () clause ...))))
(define-syntax match-cond-aux
(syntax-rules (test else)
;; No more clauses.
((match-cond-aux (cond-clause ...))
(cond cond-clause ...))
;; (TEST . <cond-clause>)
((match-cond-aux (cond-clause ...)
(test . another-cond-clause) clause2 ...)
(match-cond-aux (cond-clause ... another-cond-clause)
clause2 ...))
;; (ELSE <body> ...)
((match-cond-aux (cond-clause ...)
(else body ...) clause2 ...)
(match-cond-aux (cond-clause ... (else body ...))))
;; (<match-exp> <mvars> <body> ...)
((match-cond-aux (cond-clause ...)
(match-exp mvars body ...) clause2 ...)
(match-cond-aux (cond-clause ... (match-exp => (lambda (m)
(let-match m mvars
body ...))))
clause2 ...))))

scheme/packages.scm Normal file
View File

@ -0,0 +1,74 @@
(define-structure tty-utils
(export modify-tty echo-off echo-on raw raw-initialize)
(open scsh let-opt scheme)
(files tty-utils))
(define-structure let-match-package
(export (let-match :syntax)
(if-match :syntax)
(match-cond :syntax))
(for-syntax (open scheme
signals)) ; For ERROR
(open scsh scheme)
(access signals) ; for ERROR
(files let-match))
(define-structure expect-syntax-support
(export expand-expect)
(open scheme structure-refs
receiving) ; for making alien containers.
(access signals) ; for ERROR
(files expect-syntax))
(define-structure expect-package
(export task? make-task copy-task
task:process set-task:process modify-task:process
task:in set-task:in modify-task:in
task:out set-task:out modify-task:out
task:buf set-task:buf modify-task:buf
task:pre-match set-task:pre-match modify-task:pre-match
user-task file->task ports->task close-task
spawn* (spawn :syntax)
tsend tsend-line
(expect :syntax))
(for-syntax (open expect-syntax-support scheme))
(open scsh formats structure-refs let-match-package
receiving defrec-package scheme srfi-13)
(access signals) ; for ERROR
(files expect))
(define-structure chat-package
(export chat-abort chat-timeout chat-monitor
port->chat-logger file->chat-logger
(look-for :syntax)
(chat :syntax)
send send/cr)
(open scsh expect-package fluids scheme)
(files chat))
(define-structure printf-package
(export printf sprintf display/cr display/nl)
(open scsh formats scheme)
(define (printf fmt . args) (apply format (current-output-port) fmt args))
(define (sprintf fmt . args) (apply format #f fmt args))
(define (display/cr str . maybe-port)
(apply display str maybe-port)
(apply write-string "\r" maybe-port))
(define (display/nl str . maybe-port)
(apply display str maybe-port)
(apply write-string "\n" maybe-port))