ice-9/expect.scm

   1 ;;;;    Copyright (C) 1996, 1998, 1999, 2001 Free Software Foundation, Inc.
   2 ;;;;
   3 ;;;; This program is free software; you can redistribute it and/or modify
   4 ;;;; it under the terms of the GNU General Public License as published by
   5 ;;;; the Free Software Foundation; either version 2, or (at your option)
   6 ;;;; any later version.
   7 ;;;;
   8 ;;;; This program 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
  11 ;;;; GNU General Public License for more details.
  12 ;;;;
  13 ;;;; You should have received a copy of the GNU General Public License
  14 ;;;; along with this software; see the file COPYING.  If not, write to
  15 ;;;; the Free Software Foundation, Inc., 59 Temple Place, Suite 330,
  16 ;;;; Boston, MA 02111-1307 USA
  17 ;;;;
  18 ;;;; As a special exception, the Free Software Foundation gives permission
  19 ;;;; for additional uses of the text contained in its release of GUILE.
  20 ;;;;
  21 ;;;; The exception is that, if you link the GUILE library with other files
  22 ;;;; to produce an executable, this does not by itself cause the
  23 ;;;; resulting executable to be covered by the GNU General Public License.
  24 ;;;; Your use of that executable is in no way restricted on account of
  25 ;;;; linking the GUILE library code into it.
  26 ;;;;
  27 ;;;; This exception does not however invalidate any other reasons why
  28 ;;;; the executable file might be covered by the GNU General Public License.
  29 ;;;;
  30 ;;;; This exception applies only to the code released by the
  31 ;;;; Free Software Foundation under the name GUILE.  If you copy
  32 ;;;; code from other Free Software Foundation releases into a copy of
  33 ;;;; GUILE, as the General Public License permits, the exception does
  34 ;;;; not apply to the code that you add in this way.  To avoid misleading
  35 ;;;; anyone as to the status of such modified files, you must delete
  36 ;;;; this exception notice from them.
  37 ;;;;
  38 ;;;; If you write modifications of your own for GUILE, it is your choice
  39 ;;;; whether to permit this exception to apply to your modifications.
  40 ;;;; If you do not wish that, delete this exception notice.
  41 ;;;;
  42 \f
  43 ;;; Commentary:
  44
  45 ;; This module is documented in the Guile Reference Manual.
  46 ;; Briefly, these are exported:
  47 ;;  procedures: expect-select, expect-regexec
  48 ;;   variables: expect-port, expect-timeout, expect-timeout-proc,
  49 ;;              expect-eof-proc, expect-char-proc,
  50 ;;              expect-strings-compile-flags, expect-strings-exec-flags,
  51 ;;      macros: expect, expect-strings
  52
  53 ;;; Code:
  54
  55 (define-module (ice-9 expect)
  56   :use-module (ice-9 regex)
  57   :export-syntax (expect expect-strings)
  58   :export (expect-port expect-timeout expect-timeout-proc
  59            expect-eof-proc expect-char-proc expect-strings-compile-flags
  60            expect-strings-exec-flags expect-select expect-regexec))
  61
  62 ;;; Expect: a macro for selecting actions based on what it reads from a port.
  63 ;;; The idea is from Don Libes' expect based on Tcl.
  64 ;;; This version by Gary Houston incorporating ideas from Aubrey Jaffer.
  65 \f
  66
  67 (define expect-port #f)
  68 (define expect-timeout #f)
  69 (define expect-timeout-proc #f)
  70 (define expect-eof-proc #f)
  71 (define expect-char-proc #f)
  72
  73 ;;; expect: each test is a procedure which is applied to the accumulating
  74 ;;; string.
  75 (defmacro expect clauses
  76   (let ((s (gensym))
  77         (c (gensym))
  78         (port (gensym))
  79         (timeout (gensym)))
  80     `(let ((,s "")
  81            (,port (or expect-port (current-input-port)))
  82            ;; when timeout occurs, in floating point seconds.
  83            (,timeout (if expect-timeout
  84                          (let* ((secs-usecs (gettimeofday)))
  85                            (+ (car secs-usecs)
  86                               expect-timeout
  87                               (/ (cdr secs-usecs)
  88                                  1000000))) ; one million.
  89                          #f)))
  90        (let next-char ()
  91          (if (and expect-timeout
  92                   (not (expect-select ,port ,timeout)))
  93              (if expect-timeout-proc
  94                  (expect-timeout-proc ,s)
  95                  #f)
  96              (let ((,c (read-char ,port)))
  97                (if expect-char-proc
  98                    (expect-char-proc ,c))
  99                (if (not (eof-object? ,c))
 100                    (set! ,s (string-append ,s (string ,c))))
 101                (cond
 102                 ;; this expands to clauses where the car invokes the
 103                 ;; match proc and the cdr is the return value from expect
 104                 ;; if the proc matched.
 105                 ,@(let next-expr ((tests (map car clauses))
 106                                   (exprs (map cdr clauses))
 107                                   (body '()))
 108                     (cond
 109                      ((null? tests)
 110                       (reverse body))
 111                      (else
 112                       (next-expr
 113                        (cdr tests)
 114                        (cdr exprs)
 115                        (cons
 116                         `((,(car tests) ,s (eof-object? ,c))
 117                           ,@(cond ((null? (car exprs))
 118                                    '())
 119                                   ((eq? (caar exprs) '=>)
 120                                    (if (not (= (length (car exprs))
 121                                                2))
 122                                        (scm-error 'misc-error
 123                                                   "expect"
 124                                                   "bad recipient: ~S"
 125                                                   (list (car exprs))
 126                                                   #f)
 127                                        `((apply ,(cadar exprs)
 128                                                 (,(car tests) ,s ,port)))))
 129                                   (else
 130                                    (car exprs))))
 131                         body)))))
 132                 ;; if none of the clauses matched the current string.
 133                 (else (cond ((eof-object? ,c)
 134                              (if expect-eof-proc
 135                                  (expect-eof-proc ,s)
 136                                  #f))
 137                             (else
 138                              (next-char)))))))))))
 139
 140
 141 (define expect-strings-compile-flags regexp/newline)
 142 (define expect-strings-exec-flags regexp/noteol)
 143
 144 ;;; the regexec front-end to expect:
 145 ;;; each test must evaluate to a regular expression.
 146 (defmacro expect-strings clauses
 147   `(let ,@(let next-test ((tests (map car clauses))
 148                           (exprs (map cdr clauses))
 149                           (defs '())
 150                           (body '()))
 151             (cond ((null? tests)
 152                    (list (reverse defs) `(expect ,@(reverse body))))
 153                   (else
 154                    (let ((rxname (gensym)))
 155                      (next-test (cdr tests)
 156                                 (cdr exprs)
 157                                 (cons `(,rxname (make-regexp
 158                                                  ,(car tests)
 159                                                  expect-strings-compile-flags))
 160                                       defs)
 161                                 (cons `((lambda (s eof?)
 162                                           (expect-regexec ,rxname s eof?))
 163                                         ,@(car exprs))
 164                                       body))))))))
 165
 166 ;;; simplified select: returns #t if input is waiting or #f if timed out or
 167 ;;; select was interrupted by a signal.
 168 ;;; timeout is an absolute time in floating point seconds.
 169 (define (expect-select port timeout)
 170   (let* ((secs-usecs (gettimeofday))
 171          (relative (- timeout
 172                       (car secs-usecs)
 173                       (/ (cdr secs-usecs)
 174                          1000000))))    ; one million.
 175     (and (> relative 0)
 176          (pair? (car (select (list port) '() '()
 177                              relative))))))
 178
 179 ;;; match a string against a regexp, returning a list of strings (required
 180 ;;; by the => syntax) or #f.  called once each time a character is added
 181 ;;; to s (eof? will be #f), and once when eof is reached (with eof? #t).
 182 (define (expect-regexec rx s eof?)
 183   ;; if expect-strings-exec-flags contains regexp/noteol,
 184   ;; remove it for the eof test.
 185   (let* ((flags (if (and eof?
 186                          (logand expect-strings-exec-flags regexp/noteol))
 187                     (logxor expect-strings-exec-flags regexp/noteol)
 188                     expect-strings-exec-flags))
 189          (match (regexp-exec rx s 0 flags)))
 190     (if match
 191         (do ((i (- (match:count match) 1) (- i 1))
 192              (result '() (cons (match:substring match i) result)))
 193             ((< i 0) result))
 194         #f)))
 195
 196 ;;; expect.scm ends here