scsh-expect/scheme/expect.scm

275 lines
8.6 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.
;;; 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))
2004-07-15 13:34:52 -04:00
(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)
2004-07-15 13:34:52 -04:00
; (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)
2004-07-15 13:34:52 -04:00
; 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))))
2004-07-15 13:34:52 -04:00
;;; 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)
2004-07-15 13:34:52 -04:00
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 "")
2004-07-15 13:34:52 -04:00
(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))))