scsh-expect/scheme/chat.scm

165 lines
5.4 KiB
Scheme

;;; 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
;; Timeout => Call handler or abort.
(on-timeout (if (pair? maybe-on-timeout)
((car maybe-on-timeout))
(chat-cont 'timeout))))
(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 "%")))