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

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

;;; 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)
	  (do-next)
	  (let ((pattern (car patterns)))
	    (case (car pattern)
	      ((match)
	       (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)))
	      ((test)
	       (let ((v ((cadr pattern))))
		 (if v
		     ((caddr pattern) v)
		     (loop (cdr patterns)))))
	      ((else)
	       ((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)
	(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))))))))

(define (handle-timeout monitor on-timeout)
  (monitor #f 'timeout)
  (on-timeout))

(define (expect-1* on-timeout monitor timeout echo max-size
		   tasks-patterns-alist)
  ;; 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)))
			    monitor)
	      (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 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
								 remaining)))
						  monitor)
				    (handle-eof task (cdr task-patterns)
						(lambda ()
						  (iloop (cdr inports)
							 (cdr tasks-patterns-alist)
							 remaining))
						monitor)))
			      (iloop (cdr inports)
				     (cdr tasks-patterns-alist)
				     (cons (car tasks-patterns-alist)
					   remaining))))))))))))

;; 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)
     '())
    ((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)
     '())
    ((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 (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 ...)))
    ((expect-action-clauses (else body ...) clause ...)
     (cons (list else (lambda () body ...))
	   (expect-action-clauses clause ...)))))

(define-syntax expect-clauses
  (syntax-rules (option)
    ((expect-clauses)
     (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)))))))