123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899100101102103104105106107108109110111112113114115116117118119120121122123124125126127128129130131132133134135136137138139140141142143144145146147148149150151152153154155156157158159160161162163164165166167168169170171172 |
- ;;;; Copyright (C) 1996, 1998, 1999, 2001, 2006 Free Software Foundation, Inc.
- ;;;;
- ;;;; This library is free software; you can redistribute it and/or
- ;;;; modify it under the terms of the GNU Lesser General Public
- ;;;; License as published by the Free Software Foundation; either
- ;;;; version 3 of the License, or (at your option) any later version.
- ;;;;
- ;;;; This library 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
- ;;;; Lesser General Public License for more details.
- ;;;;
- ;;;; You should have received a copy of the GNU Lesser General Public
- ;;;; License along with this library; if not, write to the Free Software
- ;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
- ;;;;
- ;;; Commentary:
- ;; This module is documented in the Guile Reference Manual.
- ;; Briefly, these are exported:
- ;; procedures: expect-select, expect-regexec
- ;; variables: expect-port, expect-timeout, expect-timeout-proc,
- ;; expect-eof-proc, expect-char-proc,
- ;; expect-strings-compile-flags, expect-strings-exec-flags,
- ;; macros: expect, expect-strings
- ;;; Code:
- (define-module (ice-9 expect)
- :use-module (ice-9 regex)
- :export-syntax (expect expect-strings)
- :export (expect-port expect-timeout expect-timeout-proc
- expect-eof-proc expect-char-proc expect-strings-compile-flags
- expect-strings-exec-flags expect-select expect-regexec))
- ;;; 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 (gensym))
- (c (gensym))
- (port (gensym))
- (timeout (gensym)))
- `(let ((,s "")
- (,port (or expect-port (current-input-port)))
- ;; when timeout occurs, in floating point seconds.
- (,timeout (if expect-timeout
- (let* ((secs-usecs (gettimeofday)))
- (+ (car secs-usecs)
- expect-timeout
- (/ (cdr secs-usecs)
- 1000000))) ; one million.
- #f)))
- (let next-char ()
- (if (and expect-timeout
- (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))
- (if (not (eof-object? ,c))
- (set! ,s (string-append ,s (string ,c))))
- (cond
- ;; this expands to clauses where the car invokes the
- ;; match proc and the cdr is the return value from expect
- ;; if the proc matched.
- ,@(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 (eof-object? ,c))
- ,@(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 ,port)))))
- (else
- (car exprs))))
- body)))))
- ;; if none of the clauses matched the current string.
- (else (cond ((eof-object? ,c)
- (if expect-eof-proc
- (expect-eof-proc ,s)
- #f))
- (else
- (next-char)))))))))))
- (define expect-strings-compile-flags regexp/newline)
- (define expect-strings-exec-flags regexp/noteol)
- ;;; 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 (gensym)))
- (next-test (cdr tests)
- (cdr exprs)
- (cons `(,rxname (make-regexp
- ,(car tests)
- expect-strings-compile-flags))
- defs)
- (cons `((lambda (s eof?)
- (expect-regexec ,rxname s eof?))
- ,@(car exprs))
- body))))))))
- ;;; simplified select: returns #t if input is waiting or #f if timed out or
- ;;; select was interrupted by a signal.
- ;;; timeout is an absolute time in floating point seconds.
- (define (expect-select port timeout)
- (let* ((secs-usecs (gettimeofday))
- (relative (- timeout
- (car secs-usecs)
- (/ (cdr secs-usecs)
- 1000000)))) ; one million.
- (and (> relative 0)
- (pair? (car (select (list port) '() '()
- relative))))))
- ;;; match a string against a regexp, returning a list of strings (required
- ;;; by the => syntax) or #f. called once each time a character is added
- ;;; to s (eof? will be #f), and once when eof is reached (with eof? #t).
- (define (expect-regexec rx s eof?)
- ;; if expect-strings-exec-flags contains regexp/noteol,
- ;; remove it for the eof test.
- (let* ((flags (if (and eof?
- (logand expect-strings-exec-flags regexp/noteol))
- (logxor expect-strings-exec-flags regexp/noteol)
- expect-strings-exec-flags))
- (match (regexp-exec rx s 0 flags)))
- (if match
- (do ((i (- (match:count match) 1) (- i 1))
- (result '() (cons (match:substring match i) result)))
- ((< i 0) result))
- #f)))
- ;;; expect.scm ends here
|