409 lines
13 KiB
Scheme
409 lines
13 KiB
Scheme
;;; 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.
|
|
|
|
;;; 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))
|
|
|
|
;;; 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)))
|
|
|
|
|
|
(define (tsend task fmt . args)
|
|
(apply format (task:out task) fmt args))
|
|
|
|
(define tsend/cr
|
|
(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 (expect-1* on-timeout monitor timeout echo max-size
|
|
tasks-patterns-alist)
|
|
(let ((handle-input
|
|
(lambda (task patterns input do-next)
|
|
(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)))
|
|
)))))))
|
|
(handle-eof
|
|
(lambda (task patterns do-next)
|
|
(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)))
|
|
))))))
|
|
(handle-timeout
|
|
(lambda ()
|
|
(monitor #f 'timeout)
|
|
(on-timeout))))
|
|
|
|
;; 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))))
|
|
(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)
|
|
(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))))
|
|
(handle-eof
|
|
task (cdr task-patterns)
|
|
(lambda ()
|
|
(iloop (cdr inports)
|
|
(cdr tasks-patterns-alist)
|
|
remaining)))))
|
|
(iloop (cdr inports)
|
|
(cdr tasks-patterns-alist)
|
|
(cons (car tasks-patterns-alist)
|
|
remaining)))))))))))))
|
|
|
|
;; Syntax based on procedural interface
|
|
|
|
(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 (match mvars ...) body ...) clause ...)
|
|
(cons (list 'match (lambda () pattern)
|
|
(lambda (m)
|
|
(let ((match 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 name (var-inits ...) eclause ...)
|
|
(let name (var-inits ...)
|
|
(let ((r (expect-clauses eclause ...)))
|
|
(expect* (car r) (cdr r)))))
|
|
((expect (x ...) eclause ...)
|
|
(let ((r (expect-clauses (x ...) eclause ...)))
|
|
(expect* (car r) (cdr r))))))
|