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 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 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 172