scsh-expect/scheme/expect.scm

;;; 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)))

;;;; 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))))


;;; expect functional interface

(define *default-timeout* 10)
(define *default-echo* #f)
(define *default-max-size* #f)

(define-record-type :eof-pattern
  (make-eof-pattern)
  eof-pattern?)

(define eof-pattern (make-eof-pattern))

(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)))

(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
			      (begin
				(do-match-hacking task m s input monitor)
				(monitor task 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 loop)
     '())
    ((expect-action-clauses loop (on-eof body ...) clause ...)
     (cons (list 'eof
		 (lambda () body ...))
	   (expect-action-clauses loop clause ...)))
    ((expect-action-clauses loop (test exp body ...) clause ...)
     (cons (list 'test
		 (lambda () exp)
		 (lambda (_) body ...))
	   (expect-action-clauses loop clause ...)))
    ((expect-action-clauses loop (test exp => proc) clause ...)
     (cons (list 'test
		 (lambda () exp)
		 (lambda (v) (proc v)))
	   (expect-action-clauses loop clause ...)))
    ((expect-action-clauses loop (pattern (mvars ...) body ...) clause ...)
     (cons (list 'match (lambda () pattern)
		 (lambda (m)
		   (let-match m (mvars ...) body ...)))
	   (expect-action-clauses loop clause ...)))
    ((expect-action-clauses loop (else body ...) clause ...)
     (cons (list else (lambda () body ...))
	   (expect-action-clauses loop clause ...)))))

(define-syntax expect-task-clauses
  (syntax-rules ()
    ((expect-task-clauses loop)
     '())
    ((expect-task-clauses loop (task aclause ...) clause ...)
     (append (cons task (expect-action-clauses loop aclause ...))
	     (expect-task-clauses loop clause ...)))))

(define-syntax expect
  (syntax-rules ()
    ((expect name (var-inits ...) eclause ...)
     (let name (var-inits ...)
       (expect* (expect-options-clauses eclause ...)
		(expect-task-clauses name eclause ...))))
    ((expect (x ...) eclause ...)
     (let loop ()
       (expect* (expect-options-clauses loop (x ...) eclause ...)
		(expect-task-clauses loop (x ...) eclause ...))))))