summaryrefslogtreecommitdiff
path: root/ice-9/expect.scm
diff options
context:
space:
mode:
Diffstat (limited to 'ice-9/expect.scm')
-rw-r--r--ice-9/expect.scm124
1 files changed, 124 insertions, 0 deletions
diff --git a/ice-9/expect.scm b/ice-9/expect.scm
new file mode 100644
index 000000000..9ac851f89
--- /dev/null
+++ b/ice-9/expect.scm
@@ -0,0 +1,124 @@
+;;; installed-scm-file
+
+;;;; Copyright (C) 1996 Free Software Foundation, Inc.
+;;;;
+;;;; This program is free software; you can redistribute it and/or modify
+;;;; it under the terms of the GNU General Public License as published by
+;;;; the Free Software Foundation; either version 2, or (at your option)
+;;;; any later version.
+;;;;
+;;;; This program is distributed in the hope that it will be useful,
+;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;;;; GNU General Public License for more details.
+;;;;
+;;;; You should have received a copy of the GNU General Public License
+;;;; along with this software; see the file COPYING. If not, write to
+;;;; the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
+;;;;
+
+
+;;; Expect: a macro for selecting actions based on what it reads from a port.
+;;; The idea is from Don Libes' expect based on Tcl.
+;;; This version by Gary Houston incorporating ideas from Aubrey Jaffer.
+
+
+(define expect-port #f)
+(define expect-timeout #f)
+(define expect-timeout-proc #f)
+(define expect-eof-proc #f)
+(define expect-char-proc #f)
+
+;;; expect: each test is a procedure which is applied to the accumulating
+;;; string.
+(defmacro expect clauses
+ (let ((s (gentemp))
+ (c (gentemp))
+ (port (gentemp))
+ (timeout (gentemp)))
+ `(let ((,s "")
+ (,port (or expect-port (current-input-port)))
+ (,timeout (if expect-timeout
+ (+ (* expect-timeout internal-time-units-per-second)
+ (get-internal-real-time))
+ #f)))
+ (let next-char ()
+ (if (and expect-timeout
+ (or (>= (get-internal-real-time) ,timeout)
+ (and (not (char-ready? ,port))
+ (not (expect-select ,port ,timeout)))))
+ (if expect-timeout-proc
+ (expect-timeout-proc ,s)
+ #f)
+ (let ((,c (read-char ,port)))
+ (if expect-char-proc
+ (expect-char-proc ,c))
+ (cond ((eof-object? ,c)
+ (if expect-eof-proc
+ (expect-eof-proc ,s)
+ #f))
+ (else
+ (set! ,s (string-append ,s (string ,c)))
+ (cond
+ ,@(let next-expr ((tests (map car clauses))
+ (exprs (map cdr clauses))
+ (body ()))
+ (cond
+ ((null? tests)
+ (reverse body))
+ (else
+ (next-expr
+ (cdr tests)
+ (cdr exprs)
+ (cons
+ `((,(car tests) ,s)
+ ,@(cond ((null? (car exprs))
+ ())
+ ((eq? (caar exprs) '=>)
+ (if (not (= (length (car exprs))
+ 2))
+ (scm-error 'misc-error
+ "expect"
+ "bad recipient: %S"
+ (list (car exprs))
+ #f)
+ `((apply ,(cadar exprs)
+ (,(car tests) ,s)))))
+ (else
+ (car exprs))))
+ body)))))
+ (else (next-char)))))))))))
+
+;;; the regexec front-end to expect:
+;;; each test must evaluate to a regular expression.
+(defmacro expect-strings clauses
+ `(let ,@(let next-test ((tests (map car clauses))
+ (exprs (map cdr clauses))
+ (defs ())
+ (body ()))
+ (cond ((null? tests)
+ (list (reverse defs) `(expect ,@(reverse body))))
+ (else
+ (let ((rxname (gentemp)))
+ (next-test (cdr tests)
+ (cdr exprs)
+ (cons `(,rxname (regcomp ,(car tests)
+ REG_NEWLINE))
+ defs)
+ (cons `((lambda (s)
+ (regexec ,rxname s ""))
+ ,@(car exprs))
+ body))))))))
+
+;;; simplified select: returns #t if input is waiting or #f if timed out.
+;;; timeout is absolute in terms of get-internal-real-time.
+(define (expect-select port timeout)
+ (let* ((relative (/ (- timeout (get-internal-real-time))
+ internal-time-units-per-second))
+ (relative-s (inexact->exact (floor relative)))
+ (relative-ms (inexact->exact
+ (round (* (- relative relative-s) 1000)))))
+ (and (> relative 0)
+ (pair? (car (select (list port) () ()
+ relative-s
+ relative-ms))))))