scsh-expect/scheme/expect.scm

410 lines
13 KiB
Scheme
Raw Normal View History

2004-07-15 13:34:52 -04:00
;;; 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.
;;; - A wrapper that gives a spawned process a tty with the same
;;; options as the current tty.
2004-07-15 13:34:52 -04:00
;;; 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.
;;; A task is a guy with whom we can interact.
(define-record-type task
(really-make-task process in out buf pre-match)
task?
(process task:process)
(in task:in)
(out task:out)
(buf task:buf set-task:buf!)
(pre-match task:pre-match set-task:pre-match!) ;; Everything before
;; the current match.
)
(define (make-task process in out)
(really-make-task process in out "" #f))
2004-07-15 13:34:52 -04:00
;;; Wait written for tasks.
(define (wait-task task) (wait (task:process task)))
;;; Close all ports associated with a task.
(define (close-task task)
(close (task:out task))
(close (task:in task)))
2004-07-15 13:34:52 -04:00
(define (tsend task fmt . args)
(apply format (task:out task) fmt args))
(define tsend/cr
2004-07-15 13:34:52 -04:00
(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)))
;;; 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))))
;;; expect functional interface
(define *default-timeout* 10)
(define *default-echo* #f)
(define *default-max-size* #f)
(define (in-select! rvec timeout)
(receive (in out ex)
(select! rvec '#() '#() timeout)
(not (zero? in))))
;; pattern: (match (lambda () regexp) (lambda (match) ...))
;; or (eof (lambda () ...))
;; or (test (lambda () #t/#f) (lambda (v) ...))
;; or (else (lambda () ...)) ; else
(define (expect* options . tasks-patterns-alist)
(let ((monitor (cond
((assq 'monitor options) => cdr)
(else null-monitor)))
(on-timeout (cond
((assq 'on-timeout options) => cdr)
(else (lambda () #f))))
(timeout (cond
((assq 'timeout options) => cdr)
(else *default-timeout*)))
(echo (cond
((assq 'echo options) => cdr)
(else *default-echo*)))
(max-size (cond
((assq 'max-size options) => cdr)
(else *default-max-size*))))
(expect-1* on-timeout monitor timeout echo max-size tasks-patterns-alist)))
;;; Slurp in data from port 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))))
;;; 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))))
(define (handle-input task patterns input do-next monitor)
(let ((s (task:buf task)))
(let loop ((patterns patterns))
(if (null? patterns)
(do-next)
(let ((pattern (car patterns)))
(case (car pattern)
((match)
(let ((m (string-match ((cadr pattern)) s)))
(if m
;; Log all new data up to the match.
(let* ((delta (- (string-length s)
(string-length input)))
(mend (- (match:end m 0) delta)))
(monitor task (substring input 0 mend))
(monitor task m)
;; Set the prematch buffer.
(set-prematch task s m)
((caddr pattern) m))
(loop (cdr patterns)))))
((eof) (loop (cdr patterns)))
((test)
(let ((v ((cadr pattern))))
(if v
((caddr pattern) v)
(loop (cdr patterns)))))
((else)
((cadr pattern)))
(else (error "undefined pattern type" (car pattern)))))))))
(define (handle-eof task patterns do-next monitor)
(set-task:pre-match! task (task:buf task))
(set-task:buf! task "")
(monitor task #f)
(let loop ((patterns patterns))
(if (null? patterns)
(do-next)
(let ((pattern (car patterns)))
(case (car pattern)
((eof) ((cadr pattern)))
((match test else) (loop (cdr patterns)))
(else (error "undefined pattern type" (car pattern))))))))
(define (handle-timeout monitor on-timeout)
(monitor #f 'timeout)
(on-timeout))
(define (expect-1* on-timeout monitor timeout echo max-size
tasks-patterns-alist)
;; first check existing data in the buffers
(let loop ((f-tasks-patterns-alist tasks-patterns-alist))
(if (not (null? f-tasks-patterns-alist))
(let* ((task-patterns (car f-tasks-patterns-alist))
(task (car task-patterns))
(s (task:buf task)))
(if (not (zero? (string-length s)))
(handle-input task (cdr task-patterns) s
(lambda () (loop (cdr f-tasks-patterns-alist)))
monitor)
(loop (cdr f-tasks-patterns-alist))))
;; start looking for input, handle it and throw away those
;; that got eof
(let loop ((tasks-patterns-alist tasks-patterns-alist))
(if (null? tasks-patterns-alist)
#f ;; all eof
(let ((ivec (list->vector (map (lambda (task-patterns)
(task:in (car task-patterns)))
tasks-patterns-alist))))
;; what is this (time) thing in the original?
(if (not (in-select! ivec timeout))
(handle-timeout monitor on-timeout)
(let iloop ((inports (vector->list ivec))
(tasks-patterns-alist tasks-patterns-alist)
(remaining '()))
(if (null? tasks-patterns-alist)
(loop (reverse remaining))
(if (car inports)
(let* ((task-patterns (car tasks-patterns-alist))
(task (car task-patterns))
(s (do-input task)))
(if s
(handle-input task (cdr task-patterns) s
(lambda ()
(iloop (cdr inports)
(cdr tasks-patterns-alist)
(cons task-patterns
remaining)))
monitor)
(handle-eof task (cdr task-patterns)
(lambda ()
(iloop (cdr inports)
(cdr tasks-patterns-alist)
remaining))
monitor)))
(iloop (cdr inports)
(cdr tasks-patterns-alist)
(cons (car tasks-patterns-alist)
remaining))))))))))))
;; Syntax based on procedural interface
;; TODO: better error recognition/messages
(define-syntax expect-options-clauses
(syntax-rules (on-timeout timeout echo max-size monitor)
((expect-options-clauses)
'())
((expect-options-clauses (on-timeout body ...) clause ...)
(cons (cons 'on-timeout (lambda () body ...))
(expect-options-clauses clause ...)))
((expect-options-clauses (timeout v) clause ...)
(cons (cons 'timeout v)
(expect-options-clauses clause ...)))
((expect-options-clauses (echo v) clause ...)
(cons (cons 'echo v)
(expect-options-clauses clause ...)))
((expect-options-clauses (max-size v) clause ...)
(cons (cons 'max-size v)
(expect-options-clauses clause ...)))
((expect-options-clauses (monitor proc) clause ...)
(cons (cons 'monitor proc)
(expect-options-clauses clause ...)))
((expect-options-clauses x clause ...)
(expect-options-clauses clause ...))))
(define-syntax expect-action-clauses
(syntax-rules (on-eof test => else)
((expect-action-clauses)
'())
((expect-action-clauses (on-eof body ...) clause ...)
(cons (list 'eof
(lambda () body ...))
(expect-action-clauses clause ...)))
((expect-action-clauses (test exp body ...) clause ...)
(cons (list 'test
(lambda () exp)
(lambda (_) body ...))
(expect-action-clauses clause ...)))
((expect-action-clauses (test exp => proc) clause ...)
(cons (list 'test
(lambda () exp)
(lambda (v) (proc v)))
(expect-action-clauses clause ...)))
((expect-action-clauses (pattern () body ...) clause ...)
(expect-action-clauses (pattern (ignore) body ...) clause ...))
((expect-action-clauses (pattern (m mvars ...) body ...) clause ...)
(cons (list 'match (lambda () pattern)
(lambda (m)
(let-match m (mvars ...) body ...)))
(expect-action-clauses clause ...)))
((expect-action-clauses (else body ...) clause ...)
(cons (list else (lambda () body ...))
(expect-action-clauses clause ...)))))
(define-syntax expect-clauses
(syntax-rules (option)
((expect-clauses)
(cons '() '()))
((expect-clauses (option oclause ...) clause ...)
(let ((res (expect-clauses clause ...)))
(cons (append (expect-options-clauses oclause ...) (car res))
(cdr res))))
((expect-task-clauses (task aclause ...) clause ...)
(let ((res (expect-clauses clause ...)))
(cons (car res)
(cons (cons task (expect-action-clauses aclause ...))
(cdr res)))))))
(define-syntax expect
(syntax-rules ()
((expect (x ...) eclause ...)
(let ((r (expect-clauses (x ...) eclause ...)))
(apply expect* (car r) (cdr r))))
((expect name (var-inits ...) eclause ...)
(let name (var-inits ...)
(let ((r (expect-clauses eclause ...)))
(apply expect* (car r) (cdr r)))))))