guile18/ice-9/expect.scm

   1 ;;;;    Copyright (C) 1996, 1998, 1999, 2001, 2006 Free Software Foundation, Inc.
   2 ;;;;
   3 ;;;; This library is free software; you can redistribute it and/or
   4 ;;;; modify it under the terms of the GNU Lesser General Public
   5 ;;;; License as published by the Free Software Foundation; either
   6 ;;;; version 2.1 of the License, or (at your option) any later version.
   7 ;;;;
   8 ;;;; This library is distributed in the hope that it will be useful,
   9 ;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  10 ;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  11 ;;;; Lesser General Public License for more details.
  12 ;;;;
  13 ;;;; You should have received a copy of the GNU Lesser General Public
  14 ;;;; License along with this library; if not, write to the Free Software
  15 ;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
  16 ;;;;
  17 \f
  18 ;;; Commentary:
  19
  20 ;; This module is documented in the Guile Reference Manual.
  21 ;; Briefly, these are exported:
  22 ;;  procedures: expect-select, expect-regexec
  23 ;;   variables: expect-port, expect-timeout, expect-timeout-proc,
  24 ;;              expect-eof-proc, expect-char-proc,
  25 ;;              expect-strings-compile-flags, expect-strings-exec-flags,
  26 ;;      macros: expect, expect-strings
  27
  28 ;;; Code:
  29
  30 (define-module (ice-9 expect)
  31   :use-module (ice-9 regex)
  32   :export-syntax (expect expect-strings)
  33   :export (expect-port expect-timeout expect-timeout-proc
  34            expect-eof-proc expect-char-proc expect-strings-compile-flags
  35            expect-strings-exec-flags expect-select expect-regexec))
  36
  37 ;;; Expect: a macro for selecting actions based on what it reads from a port.
  38 ;;; The idea is from Don Libes' expect based on Tcl.
  39 ;;; This version by Gary Houston incorporating ideas from Aubrey Jaffer.
  40 \f
  41
  42 (define expect-port #f)
  43 (define expect-timeout #f)
  44 (define expect-timeout-proc #f)
  45 (define expect-eof-proc #f)
  46 (define expect-char-proc #f)
  47
  48 ;;; expect: each test is a procedure which is applied to the accumulating
  49 ;;; string.
  50 (defmacro expect clauses
  51   (let ((s (gensym))
  52         (c (gensym))
  53         (port (gensym))
  54         (timeout (gensym)))
  55     `(let ((,s "")
  56            (,port (or expect-port (current-input-port)))
  57            ;; when timeout occurs, in floating point seconds.
  58            (,timeout (if expect-timeout
  59                          (let* ((secs-usecs (gettimeofday)))
  60                            (+ (car secs-usecs)
  61                               expect-timeout
  62                               (/ (cdr secs-usecs)
  63                                  1000000))) ; one million.
  64                          #f)))
  65        (let next-char ()
  66          (if (and expect-timeout
  67                   (not (expect-select ,port ,timeout)))
  68              (if expect-timeout-proc
  69                  (expect-timeout-proc ,s)
  70                  #f)
  71              (let ((,c (read-char ,port)))
  72                (if expect-char-proc
  73                    (expect-char-proc ,c))
  74                (if (not (eof-object? ,c))
  75                    (set! ,s (string-append ,s (string ,c))))
  76                (cond
  77                 ;; this expands to clauses where the car invokes the
  78                 ;; match proc and the cdr is the return value from expect
  79                 ;; if the proc matched.
  80                 ,@(let next-expr ((tests (map car clauses))
  81                                   (exprs (map cdr clauses))
  82                                   (body '()))
  83                     (cond
  84                      ((null? tests)
  85                       (reverse body))
  86                      (else
  87                       (next-expr
  88                        (cdr tests)
  89                        (cdr exprs)
  90                        (cons
  91                         `((,(car tests) ,s (eof-object? ,c))
  92                           ,@(cond ((null? (car exprs))
  93                                    '())
  94                                   ((eq? (caar exprs) '=>)
  95                                    (if (not (= (length (car exprs))
  96                                                2))
  97                                        (scm-error 'misc-error
  98                                                   "expect"
  99                                                   "bad recipient: ~S"
 100                                                   (list (car exprs))
 101                                                   #f)
 102                                        `((apply ,(cadar exprs)
 103                                                 (,(car tests) ,s ,port)))))
 104                                   (else
 105                                    (car exprs))))
 106                         body)))))
 107                 ;; if none of the clauses matched the current string.
 108                 (else (cond ((eof-object? ,c)
 109                              (if expect-eof-proc
 110                                  (expect-eof-proc ,s)
 111                                  #f))
 112                             (else
 113                              (next-char)))))))))))
 114
 115
 116 (define expect-strings-compile-flags regexp/newline)
 117 (define expect-strings-exec-flags regexp/noteol)
 118
 119 ;;; the regexec front-end to expect:
 120 ;;; each test must evaluate to a regular expression.
 121 (defmacro expect-strings clauses
 122   `(let ,@(let next-test ((tests (map car clauses))
 123                           (exprs (map cdr clauses))
 124                           (defs '())
 125                           (body '()))
 126             (cond ((null? tests)
 127                    (list (reverse defs) `(expect ,@(reverse body))))
 128                   (else
 129                    (let ((rxname (gensym)))
 130                      (next-test (cdr tests)
 131                                 (cdr exprs)
 132                                 (cons `(,rxname (make-regexp
 133                                                  ,(car tests)
 134                                                  expect-strings-compile-flags))
 135                                       defs)
 136                                 (cons `((lambda (s eof?)
 137                                           (expect-regexec ,rxname s eof?))
 138                                         ,@(car exprs))
 139                                       body))))))))
 140
 141 ;;; simplified select: returns #t if input is waiting or #f if timed out or
 142 ;;; select was interrupted by a signal.
 143 ;;; timeout is an absolute time in floating point seconds.
 144 (define (expect-select port timeout)
 145   (let* ((secs-usecs (gettimeofday))
 146          (relative (- timeout
 147                       (car secs-usecs)
 148                       (/ (cdr secs-usecs)
 149                          1000000))))    ; one million.
 150     (and (> relative 0)
 151          (pair? (car (select (list port) '() '()
 152                              relative))))))
 153
 154 ;;; match a string against a regexp, returning a list of strings (required
 155 ;;; by the => syntax) or #f.  called once each time a character is added
 156 ;;; to s (eof? will be #f), and once when eof is reached (with eof? #t).
 157 (define (expect-regexec rx s eof?)
 158   ;; if expect-strings-exec-flags contains regexp/noteol,
 159   ;; remove it for the eof test.
 160   (let* ((flags (if (and eof?
 161                          (logand expect-strings-exec-flags regexp/noteol))
 162                     (logxor expect-strings-exec-flags regexp/noteol)
 163                     expect-strings-exec-flags))
 164          (match (regexp-exec rx s 0 flags)))
 165     (if match
 166         (do ((i (- (match:count match) 1) (- i 1))
 167              (result '() (cons (match:substring match i) result)))
 168             ((< i 0) result))
 169         #f)))
 170
 171 ;;; expect.scm ends here