*** empty log message ***
This commit is contained in:
frese
parent
73b73841ba
commit
5be06d7481
|
|
@ -0,0 +1,2 @@
|
|||
Designed and implemented by David Fisher and Olin Shivers.
|
||||
Copyright (C) 1998 by the Scheme Underground.
|
||||
|
|
@ -0,0 +1,2 @@
|
|||
Designed and implemented by David Fisher and Olin Shivers.
|
||||
Copyright (C) 1998 by the Scheme Underground.
|
||||
|
|
@ -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>)
|
||||
|
|
@ -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:
|
||||
#F EOF
|
||||
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"
|
||||
binding.
|
||||
|
||||
(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
|
||||
body.
|
||||
|
||||
(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
|
||||
interaction.
|
||||
|
||||
Example: (filter (lambda (c k)
|
||||
(if
|
||||
|
||||
(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
|
||||
task.
|
||||
|
||||
(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.
|
||||
|
||||
|
||||
|
|
@ -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)
|
||||
(call-with-current-continuation
|
||||
(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)
|
||||
(thunk))))))))
|
||||
|
||||
(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))
|
||||
#f)
|
||||
(abort-re (#f s) ; See $chat-abort-re =>
|
||||
(if cmon (cmon 'abort #f)) ; abort & return the
|
||||
(chat-cont s)) ; abort string.
|
||||
|
||||
(on-eof
|
||||
;; 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
|
||||
;;; (abort-pattern "BUSY|NO CARRIER|NO DIALTONE|ERROR")
|
||||
;;; (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 "%")))
|
||||
|
|
@ -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)))
|
||||
aclauses)
|
||||
(if (> (length this-tasks-eofs) 1)
|
||||
(syntax-error "Too many ON-EOF action clauses in EXPECT"
|
||||
clause)
|
||||
(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))
|
||||
task-vars))))
|
||||
|
||||
;; 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))
|
||||
pa-clauses)
|
||||
(,%else (,%monitor ,task ,%i)
|
||||
(,%do-next))))))
|
||||
|
||||
(try-matches (map (lambda (label task pa-clauses)
|
||||
`(,label ,(try-matcher pa-clauses task)))
|
||||
try-match-vars
|
||||
task-vars
|
||||
pa-clauses-list))
|
||||
|
||||
;; 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
|
||||
,do-next
|
||||
,(or do-eof do-next)
|
||||
,%monitor))))
|
||||
|
||||
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.
|
||||
(initial-trymatch
|
||||
(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))))
|
||||
`(,%do-select))))
|
||||
|
||||
;; 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))
|
||||
''timeout)))))
|
||||
|
||||
;; This is the core letrec -- the wait-for-input &
|
||||
;; try-to-match loop.
|
||||
(inner-loop `(,%letrec (,@do-eofs
|
||||
,@try-matches
|
||||
,@try-tasks
|
||||
(,%do-select ,loop-top))
|
||||
,initial-trymatch))
|
||||
|
||||
;; This is the outer, named loop (if any).
|
||||
(named-loop (if exp-name
|
||||
`(,%let ,exp-name ,loop-var-inits
|
||||
,inner-loop)
|
||||
inner-loop)))
|
||||
|
||||
;; Build the final expression.
|
||||
`(,%let* (,@task-bindings
|
||||
,ivec-binding
|
||||
(,%monitor ,mon-exp)
|
||||
,@(if timeout-var
|
||||
`((,timeout-var ,timeout-secs)
|
||||
(,timeout-var (,%and ,timeout-var
|
||||
(,%+ (,%time) ,timeout-var))))
|
||||
'())) ; No timeout-var binding needed.
|
||||
,named-loop)))
|
||||
|
|
@ -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
|
||||
process
|
||||
in
|
||||
out
|
||||
(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)
|
||||
s))))
|
||||
|
||||
;;; 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)))
|
||||
(else
|
||||
(set-task:pre-match task (task:buf task))
|
||||
(set-task:buf task "")
|
||||
(monitor task #f) ; Signal EOF
|
||||
(do-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))
|
||||
(do-next))))
|
||||
|
||||
|
||||
;;; 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 '())))
|
||||
|
||||
(add-line-frag
|
||||
(lambda (s) (if (> (string-length s) 0)
|
||||
(set! strs (cons s strs)))))
|
||||
|
||||
;; Index of the last cr or nl, or false. Lame code.
|
||||
(last-line-break
|
||||
(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)
|
||||
(flush-trailing-line)
|
||||
(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)
|
||||
(flush-trailing-line)
|
||||
(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)
|
||||
(flush-trailing-line)
|
||||
(write-string "-- got it.\n" p))
|
||||
|
||||
;; Timeout event
|
||||
((eq? event 'timeout)
|
||||
(cond ((pair? strs)
|
||||
(flush-trailing-line)
|
||||
(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))))
|
||||
|
|
@ -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))
|
||||
bindings)
|
||||
bindings))
|
||||
'()))))
|
||||
`(,%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 ...))))
|
||||
|
|
@ -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
|
||||
|
||||
port->monitor
|
||||
|
||||
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)
|
||||
|
||||
(begin
|
||||
|
||||
(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))
|
||||
))
|
||||
Loading…
Reference in New Issue