288 lines
8.9 KiB
Scheme
288 lines
8.9 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.
|
|
|
|
(define error (structure-ref signals error))
|
|
|
|
(define-syntax expect expand-expect)
|
|
|
|
;;; 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)))
|
|
|
|
;;;; 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))))
|