402 lines
12 KiB

;;; 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 strings and regexps.
;;; A task is a guy with whom we can interact.
(define-record-type task
(really-make-task process in out buf pre-match)
(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 '())))
(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))))
;;; 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)
;;; 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)
(let ((pattern (car patterns)))
(case (car pattern)
(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)))
(let ((v ((cadr pattern))))
(if v
((caddr pattern) v)
(loop (cdr patterns)))))
((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)
(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)
(define (expect-1* on-timeout monitor timeout echo max-size
;; 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)))
;; 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
(handle-eof task (cdr task-patterns)
(lambda ()
(iloop (cdr inports)
(cdr tasks-patterns-alist)
(iloop (cdr inports)
(cdr tasks-patterns-alist)
(cons (car tasks-patterns-alist)
;; 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 (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 (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 (else body ...) clause ...)
(cons (list 'else (lambda () body ...))
(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 ...)))))
(define-syntax expect-clauses
(syntax-rules (option)
(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)))))))