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.

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

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