scsh-expect/scheme/chat.scm

;;; Chat for scsh.
;;; Designed and implemented by David Fisher and Olin Shivers.
;;; Copyright (C) 1998 by the Scheme Underground.

;;; $chat-task $chat-cont $chat-abort-re $chat-timeout $chat-monitor
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; These are the fluid vars bound by CHAT.

(define $chat-task (make-fluid #f))	; I/O task 

(define $chat-cont (make-fluid #f))	; Continuation used to abort the CHAT

(define $chat-monitor (make-fluid #f))

;;; This is my lame approximation to a regexp that matches nothing.
;;; It will never match a non-empty string, in any event, and that's
;;; good enough for this app.
(define default-chat-abort-re (make-regexp "^$"))

;;; Regexp that causes any LOOK-FOR clause to abort out of the CHAT.
(define $chat-abort-re (make-fluid default-chat-abort-re))

(define (chat-abort re)      (set-fluid! $chat-abort-re (->regexp re)))

;;; Number of seconds a LOOK-FOR clause should wait before timing out.
(define $chat-timeout (make-fluid 45))

;;; These guys override the defaults.
(define (chat-timeout nsecs) (set-fluid! $chat-timeout nsecs))
(define (chat-monitor cmon) (set-fluid! $chat-monitor cmon))

(define-syntax define-simple-syntax
  (syntax-rules ()
    ((define-simple-syntax (name . pattern) result)
     (define-syntax name (syntax-rules () ((name . pattern) result))))))

(define-simple-syntax (chat task exp ...)
  (chat* task (lambda () exp ...)))

(define (chat* task thunk)
  (call-with-current-continuation
    (lambda (k)
      (let-fluids $chat-task       task
		  $chat-abort-re   default-chat-abort-re
		  $chat-cont       k
		  $chat-timeout	   45
		  $chat-monitor	   #f
        (lambda ()
	  (with-current-output-port (task:out task)
	    (with-current-input-port (task:in task)
              (thunk))))))))

(define (look-for* re . maybe-on-timeout)
  (let ((tmout     (fluid $chat-timeout))
	(chat-cont (fluid $chat-cont))
	(task      (fluid $chat-task))
	(abort-re  (fluid $chat-abort-re))
	(cmon  (fluid $chat-monitor)))
    (if cmon (cmon 'looking-for re))
    (expect (option (timeout tmout)	; Timeout in $chat-timeout secs.
		    (monitor (if cmon
				 (chat->expect-monitor cmon)
				 (lambda (task event) #f))))	; No-op

	    ;; Expect triggers the monitor for us on timeout.
	    (on-timeout (if (pair? maybe-on-timeout)	; Timeout =>
			    ((car maybe-on-timeout))	;   Call handler or
			    (chat-cont 'timeout))) 	;   abort.

	    (task (re (m) 			; See RE => return false.
		    (if cmon (cmon 'found m))
		    #f)
		  (abort-re (s)		        ; See $chat-abort-re =>
		    (if cmon (cmon 'abort s))	;   abort & return the
		    (chat-cont s))		;   abort string.

		  (on-eof
		   ;; EXPECT triggers the monitor for us.
		   (chat-cont 'eof))))))

(define-syntax look-for
  (syntax-rules ()
    ((look-for re) (look-for* re))
    ((look-for re on-timeout ...)
     (look-for* re (lambda () on-timeout ...)))))

;;; chat-logger monitors
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Monitors are called on the following events:
;;; - looking-for(re)
;;; - found(match)
;;; - new-input(text)
;;; - sending(text)
;;; - abort(text)
;;; - eof
;;; - timeout

;;; Builds a chat monitor from an expect monitor.
;;; We do nothing with match events, because it's ambiguous --
;;; we might have matched what the user was looking for, or we might
;;; have matched the abort pattern. So chat puts the chat monitor calls
;;; directly in the EXPECT form.
(define (chat->expect-monitor cmon)
  (lambda (task event)
    (cond ((not event)		 (cmon 'eof #f))
	  ((string? event)	 (cmon 'new-input event))
	  ((regexp-match? event))	; Do nothing
	  ((eq? 'timeout event)  (cmon 'timeout #f))
	  (else (error "Unknown EXPECT event" task event)))))

(define (port->chat-logger port)
  (lambda (event val)
    (case event
      ((looking-for)	(format port "expect(~a)\n" val))
      ((found)		(write-string "-- got it\n" port))
      ((new-input)	(format port "[~a]" val))
      ((sending)	(format port "send(~a)\n" val))
      ((eof)		(write-string "EOF encountered.\n" port))
      ((timeout)	(write-string "-- timed out. \n" port))
      ((abort)		(format port "-- aborting(~a). \n" val))
      (else		(format port "Unknown chat event: ~a ~a\n" event val)))
    (force-output port)))


(define (file->chat-logger fname . maybe-open-flags)
  (port->chat-logger (apply open-output-file fname maybe-open-flags)))

;;; Monitor-aware I/O procedures
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

;;; Outputs to (CURRENT-OUTPUT-PORT) 
;;; and also triggers the current chat monitor.

(define (send fmt . args)
  (cond ((fluid $chat-monitor) =>
	 (lambda (cm)
	   (let ((s (apply format #f fmt args)))
	     (cm 'sending s)
	     (write-string s))))
	(else (apply format (current-output-port) fmt args))))

(define (send/cr fmt . args)
  (cond ((fluid $chat-monitor) =>
	 (lambda (cm)
	   (let ((s (string-append (apply format #f fmt args) "\r")))
	     (cm 'sending s)
	     (write-string s))))
	(else (apply format (current-output-port) fmt args)
	      (write-string "\r"))))


;;;   (define (dialin modem phone-num username password)
;;;     (chat modem
;;;       (abort-pattern "BUSY|NO CARRIER|NO DIALTONE|ERROR")
;;;       (send		"ATZ\r")	
;;;       (look-for	"OK")
;;;	  (send		"ATDT~a\r" phone-num)
;;;       (look-for	"CONNECT")
;;;       (look-for	"ogin:"
;;;	      (send "\r")
;;;	      (look-for "ogin:"))
;;;	  (send/cr	username)
;;;       (look-for	"assword:")
;;;	  (send/cr	password)
;;;       (look-for	"%")))