ice-9/expect.scm

   1 ;;; installed-scm-file
   2
   3 ;;;;    Copyright (C) 1996, 1998 Free Software Foundation, Inc.
   4 ;;;;
   5 ;;;; This program is free software; you can redistribute it and/or modify
   6 ;;;; it under the terms of the GNU General Public License as published by
   7 ;;;; the Free Software Foundation; either version 2, or (at your option)
   8 ;;;; any later version.
   9 ;;;;
  10 ;;;; This program is distributed in the hope that it will be useful,
  11 ;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  12 ;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  13 ;;;; GNU General Public License for more details.
  14 ;;;;
  15 ;;;; You should have received a copy of the GNU General Public License
  16 ;;;; along with this software; see the file COPYING.  If not, write to
  17 ;;;; the Free Software Foundation, Inc., 59 Temple Place, Suite 330,
  18 ;;;; Boston, MA 02111-1307 USA
  19 ;;;;
  20 \f
  21
  22 (define-module (ice-9 expect) :use-module (ice-9 regex))
  23
  24 ;;; Expect: a macro for selecting actions based on what it reads from a port.
  25 ;;; The idea is from Don Libes' expect based on Tcl.
  26 ;;; This version by Gary Houston incorporating ideas from Aubrey Jaffer.
  27 \f
  28
  29 (define-public expect-port #f)
  30 (define-public expect-timeout #f)
  31 (define-public expect-timeout-proc #f)
  32 (define-public expect-eof-proc #f)
  33 (define-public expect-char-proc #f)
  34
  35 ;;; expect: each test is a procedure which is applied to the accumulating
  36 ;;; string.
  37 (defmacro-public expect clauses
  38   (let ((s (gentemp))
  39         (c (gentemp))
  40         (port (gentemp))
  41         (timeout (gentemp)))
  42     `(let ((,s "")
  43            (,port (or expect-port (current-input-port)))
  44            ;; when timeout occurs, in floating point seconds.
  45            (,timeout (if expect-timeout
  46                          (let* ((secs-usecs (gettimeofday)))
  47                            (+ (car secs-usecs)
  48                               expect-timeout
  49                               (/ (cdr secs-usecs)
  50                                  1000000))) ; one million.
  51                          #f)))
  52        (let next-char ()
  53          (if (and expect-timeout
  54                   (or (>= (get-internal-real-time) ,timeout)
  55                       (and (not (char-ready? ,port))
  56                            (not (expect-select ,port ,timeout)))))
  57              (if expect-timeout-proc
  58                  (expect-timeout-proc ,s)
  59                  #f)
  60              (let ((,c (read-char ,port)))
  61                (if expect-char-proc
  62                    (expect-char-proc ,c))
  63                (cond ((eof-object? ,c)
  64                       (if expect-eof-proc
  65                           (expect-eof-proc ,s)
  66                           #f))
  67                      (else
  68                       (set! ,s (string-append ,s (string ,c)))
  69                       (cond
  70                        ,@(let next-expr ((tests (map car clauses))
  71                                          (exprs (map cdr clauses))
  72                                          (body '()))
  73                            (cond
  74                             ((null? tests)
  75                              (reverse body))
  76                             (else
  77                              (next-expr
  78                               (cdr tests)
  79                               (cdr exprs)
  80                               (cons
  81                                `((,(car tests) ,s)
  82                                  ,@(cond ((null? (car exprs))
  83                                           '())
  84                                          ((eq? (caar exprs) '=>)
  85                                           (if (not (= (length (car exprs))
  86                                                       2))
  87                                               (scm-error 'misc-error
  88                                                          "expect"
  89                                                          "bad recipient: %S"
  90                                                          (list (car exprs))
  91                                                          #f)
  92                                               `((apply ,(cadar exprs)
  93                                                        (,(car tests) ,s)))))
  94                                          (else
  95                                           (car exprs))))
  96                                body)))))
  97                        (else (next-char)))))))))))
  98
  99 ;;; the regexec front-end to expect:
 100 ;;; each test must evaluate to a regular expression.
 101 (defmacro-public expect-strings clauses
 102   `(let ,@(let next-test ((tests (map car clauses))
 103                           (exprs (map cdr clauses))
 104                           (defs '())
 105                           (body '()))
 106             (cond ((null? tests)
 107                    (list (reverse defs) `(expect ,@(reverse body))))
 108                   (else
 109                    (let ((rxname (gentemp)))
 110                      (next-test (cdr tests)
 111                                 (cdr exprs)
 112                                 (cons `(,rxname (make-regexp ,(car tests)
 113                                                              regexp/newline))
 114                                       defs)
 115                                 (cons `((lambda (s)
 116                                           (expect-regexec ,rxname s))
 117                                         ,@(car exprs))
 118                                       body))))))))
 119
 120 ;;; simplified select: returns #t if input is waiting or #f if timed out.
 121 ;;; timeout is an absolute time in floating point seconds.
 122 (define-public (expect-select port timeout)
 123   (let* ((secs-usecs (gettimeofday))
 124          (relative (- timeout
 125                       (car secs-usecs)
 126                       (/ (cdr secs-usecs)
 127                          1000000))))    ; one million.
 128     (and (> relative 0)
 129          (pair? (car (select (list port) '() '()
 130                              relative))))))
 131
 132 ;;; convert a match object to a list of strings, for the => syntax.
 133 (define-public (expect-regexec rx s)
 134   (let ((match (regexp-exec rx s)))
 135     (if match
 136         (do ((i (- (match:count match) 1) (- i 1))
 137              (result '() (cons (match:substring match i) result)))
 138             ((< i 0) result))
 139         #f)))