165 lines
5.4 KiB
Scheme
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 (m) ; See $chat-abort-re =>
|
|
(if cmon (cmon 'abort m)) ; abort & return the
|
|
(chat-cont m)) ; 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 "%")))
|