Commit | Line | Data |
---|---|---|
2b1621ac | 1 | ;;;; Copyright (C) 1996, 1998, 1999, 2001 Free Software Foundation, Inc. |
f32e992f | 2 | ;;;; |
d7189b49 GH |
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. | |
f32e992f | 7 | ;;;; |
d7189b49 GH |
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. | |
f32e992f | 12 | ;;;; |
d7189b49 GH |
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 | |
15328041 JB |
15 | ;;;; the Free Software Foundation, Inc., 59 Temple Place, Suite 330, |
16 | ;;;; Boston, MA 02111-1307 USA | |
f32e992f | 17 | ;;;; |
a482f2cc MV |
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 | ;;;; | |
d7189b49 | 42 | \f |
f32e992f | 43 | ;;; Commentary: |
d7189b49 | 44 | |
f32e992f TTN |
45 | ;; This module is documented in the Guile Reference Manual. |
46 | ;; Briefly, these are exported: | |
2b1621ac | 47 | ;; procedures: expect-select, expect-regexec |
f32e992f TTN |
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, | |
0755b9df | 51 | ;; macros: expect, expect-strings |
f32e992f TTN |
52 | |
53 | ;;; Code: | |
54 | ||
55 | (define-module (ice-9 expect) | |
1a179b03 MD |
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)) | |
ec8469e7 | 61 | |
d7189b49 GH |
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 | ||
1a179b03 MD |
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) | |
d7189b49 GH |
72 | |
73 | ;;; expect: each test is a procedure which is applied to the accumulating | |
74 | ;;; string. | |
1a179b03 | 75 | (defmacro expect clauses |
872bd194 MV |
76 | (let ((s (gensym)) |
77 | (c (gensym)) | |
78 | (port (gensym)) | |
79 | (timeout (gensym))) | |
d7189b49 GH |
80 | `(let ((,s "") |
81 | (,port (or expect-port (current-input-port))) | |
cafa4c68 | 82 | ;; when timeout occurs, in floating point seconds. |
d7189b49 | 83 | (,timeout (if expect-timeout |
cafa4c68 GH |
84 | (let* ((secs-usecs (gettimeofday))) |
85 | (+ (car secs-usecs) | |
86 | expect-timeout | |
87 | (/ (cdr secs-usecs) | |
88 | 1000000))) ; one million. | |
d7189b49 GH |
89 | #f))) |
90 | (let next-char () | |
91 | (if (and expect-timeout | |
28d77376 | 92 | (not (expect-select ,port ,timeout))) |
d7189b49 GH |
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)) | |
8f59c14e JB |
99 | (if (not (eof-object? ,c)) |
100 | (set! ,s (string-append ,s (string ,c)))) | |
101 | (cond | |
28d77376 GH |
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. | |
8f59c14e JB |
105 | ,@(let next-expr ((tests (map car clauses)) |
106 | (exprs (map cdr clauses)) | |
107 | (body '())) | |
108 | (cond | |
109 | ((null? tests) | |
110 | (reverse body)) | |
d7189b49 | 111 | (else |
8f59c14e JB |
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" | |
8641dd9e | 124 | "bad recipient: ~S" |
8f59c14e JB |
125 | (list (car exprs)) |
126 | #f) | |
127 | `((apply ,(cadar exprs) | |
128 | (,(car tests) ,s ,port))))) | |
f32e992f | 129 | (else |
8f59c14e JB |
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)) | |
d7189b49 | 137 | (else |
8f59c14e | 138 | (next-char))))))))))) |
d7189b49 | 139 | |
156ecad5 | 140 | |
1a179b03 MD |
141 | (define expect-strings-compile-flags regexp/newline) |
142 | (define expect-strings-exec-flags regexp/noteol) | |
156ecad5 | 143 | |
d7189b49 GH |
144 | ;;; the regexec front-end to expect: |
145 | ;;; each test must evaluate to a regular expression. | |
1a179b03 | 146 | (defmacro expect-strings clauses |
d7189b49 GH |
147 | `(let ,@(let next-test ((tests (map car clauses)) |
148 | (exprs (map cdr clauses)) | |
28d8ab3c GH |
149 | (defs '()) |
150 | (body '())) | |
d7189b49 GH |
151 | (cond ((null? tests) |
152 | (list (reverse defs) `(expect ,@(reverse body)))) | |
153 | (else | |
872bd194 | 154 | (let ((rxname (gensym))) |
d7189b49 GH |
155 | (next-test (cdr tests) |
156 | (cdr exprs) | |
156ecad5 JB |
157 | (cons `(,rxname (make-regexp |
158 | ,(car tests) | |
159 | expect-strings-compile-flags)) | |
d7189b49 | 160 | defs) |
8f59c14e JB |
161 | (cons `((lambda (s eof?) |
162 | (expect-regexec ,rxname s eof?)) | |
d7189b49 GH |
163 | ,@(car exprs)) |
164 | body)))))))) | |
165 | ||
28d77376 GH |
166 | ;;; simplified select: returns #t if input is waiting or #f if timed out or |
167 | ;;; select was interrupted by a signal. | |
cafa4c68 | 168 | ;;; timeout is an absolute time in floating point seconds. |
1a179b03 | 169 | (define (expect-select port timeout) |
cafa4c68 | 170 | (let* ((secs-usecs (gettimeofday)) |
f32e992f | 171 | (relative (- timeout |
cafa4c68 GH |
172 | (car secs-usecs) |
173 | (/ (cdr secs-usecs) | |
174 | 1000000)))) ; one million. | |
d7189b49 | 175 | (and (> relative 0) |
28d8ab3c | 176 | (pair? (car (select (list port) '() '() |
cafa4c68 | 177 | relative)))))) |
28d8ab3c | 178 | |
8f59c14e JB |
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). | |
1a179b03 | 182 | (define (expect-regexec rx s eof?) |
2645b7b8 | 183 | ;; if expect-strings-exec-flags contains regexp/noteol, |
8f59c14e JB |
184 | ;; remove it for the eof test. |
185 | (let* ((flags (if (and eof? | |
186 | (logand expect-strings-exec-flags regexp/noteol)) | |
2645b7b8 JB |
187 | (logxor expect-strings-exec-flags regexp/noteol) |
188 | expect-strings-exec-flags)) | |
156ecad5 | 189 | (match (regexp-exec rx s 0 flags))) |
28d8ab3c GH |
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))) | |
2645b7b8 | 195 | |
f32e992f | 196 | ;;; expect.scm ends here |