Commit | Line | Data |
---|---|---|
2645b7b8 | 1 | ;;;; Copyright (C) 1996, 1998, 1999 Free Software Foundation, Inc. |
d7189b49 GH |
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 | |
15328041 JB |
15 | ;;;; the Free Software Foundation, Inc., 59 Temple Place, Suite 330, |
16 | ;;;; Boston, MA 02111-1307 USA | |
d7189b49 GH |
17 | ;;;; |
18 | \f | |
19 | ||
28d8ab3c | 20 | (define-module (ice-9 expect) :use-module (ice-9 regex)) |
ec8469e7 | 21 | |
d7189b49 GH |
22 | ;;; Expect: a macro for selecting actions based on what it reads from a port. |
23 | ;;; The idea is from Don Libes' expect based on Tcl. | |
24 | ;;; This version by Gary Houston incorporating ideas from Aubrey Jaffer. | |
25 | \f | |
26 | ||
ec8469e7 JB |
27 | (define-public expect-port #f) |
28 | (define-public expect-timeout #f) | |
29 | (define-public expect-timeout-proc #f) | |
30 | (define-public expect-eof-proc #f) | |
31 | (define-public expect-char-proc #f) | |
d7189b49 GH |
32 | |
33 | ;;; expect: each test is a procedure which is applied to the accumulating | |
34 | ;;; string. | |
ec8469e7 | 35 | (defmacro-public expect clauses |
d7189b49 GH |
36 | (let ((s (gentemp)) |
37 | (c (gentemp)) | |
38 | (port (gentemp)) | |
39 | (timeout (gentemp))) | |
40 | `(let ((,s "") | |
41 | (,port (or expect-port (current-input-port))) | |
cafa4c68 | 42 | ;; when timeout occurs, in floating point seconds. |
d7189b49 | 43 | (,timeout (if expect-timeout |
cafa4c68 GH |
44 | (let* ((secs-usecs (gettimeofday))) |
45 | (+ (car secs-usecs) | |
46 | expect-timeout | |
47 | (/ (cdr secs-usecs) | |
48 | 1000000))) ; one million. | |
d7189b49 GH |
49 | #f))) |
50 | (let next-char () | |
51 | (if (and expect-timeout | |
52 | (or (>= (get-internal-real-time) ,timeout) | |
53 | (and (not (char-ready? ,port)) | |
54 | (not (expect-select ,port ,timeout))))) | |
55 | (if expect-timeout-proc | |
56 | (expect-timeout-proc ,s) | |
57 | #f) | |
58 | (let ((,c (read-char ,port))) | |
59 | (if expect-char-proc | |
60 | (expect-char-proc ,c)) | |
61 | (cond ((eof-object? ,c) | |
62 | (if expect-eof-proc | |
63 | (expect-eof-proc ,s) | |
64 | #f)) | |
65 | (else | |
66 | (set! ,s (string-append ,s (string ,c))) | |
67 | (cond | |
68 | ,@(let next-expr ((tests (map car clauses)) | |
ec8469e7 | 69 | (exprs (map cdr clauses)) |
28d8ab3c | 70 | (body '())) |
d7189b49 GH |
71 | (cond |
72 | ((null? tests) | |
73 | (reverse body)) | |
74 | (else | |
75 | (next-expr | |
76 | (cdr tests) | |
77 | (cdr exprs) | |
78 | (cons | |
156ecad5 | 79 | `((,(car tests) ,s ,port) |
d7189b49 | 80 | ,@(cond ((null? (car exprs)) |
28d8ab3c | 81 | '()) |
d7189b49 GH |
82 | ((eq? (caar exprs) '=>) |
83 | (if (not (= (length (car exprs)) | |
84 | 2)) | |
85 | (scm-error 'misc-error | |
86 | "expect" | |
87 | "bad recipient: %S" | |
88 | (list (car exprs)) | |
89 | #f) | |
90 | `((apply ,(cadar exprs) | |
156ecad5 | 91 | (,(car tests) ,s ,port))))) |
d7189b49 GH |
92 | (else |
93 | (car exprs)))) | |
94 | body))))) | |
95 | (else (next-char))))))))))) | |
96 | ||
156ecad5 JB |
97 | |
98 | (define-public expect-strings-compile-flags regexp/newline) | |
2645b7b8 | 99 | (define-public expect-strings-exec-flags regexp/noteol) |
156ecad5 | 100 | |
d7189b49 GH |
101 | ;;; the regexec front-end to expect: |
102 | ;;; each test must evaluate to a regular expression. | |
ec8469e7 | 103 | (defmacro-public expect-strings clauses |
d7189b49 GH |
104 | `(let ,@(let next-test ((tests (map car clauses)) |
105 | (exprs (map cdr clauses)) | |
28d8ab3c GH |
106 | (defs '()) |
107 | (body '())) | |
d7189b49 GH |
108 | (cond ((null? tests) |
109 | (list (reverse defs) `(expect ,@(reverse body)))) | |
110 | (else | |
111 | (let ((rxname (gentemp))) | |
112 | (next-test (cdr tests) | |
113 | (cdr exprs) | |
156ecad5 JB |
114 | (cons `(,rxname (make-regexp |
115 | ,(car tests) | |
116 | expect-strings-compile-flags)) | |
d7189b49 | 117 | defs) |
156ecad5 JB |
118 | (cons `((lambda (s port) |
119 | (expect-regexec | |
120 | ,rxname s port)) | |
d7189b49 GH |
121 | ,@(car exprs)) |
122 | body)))))))) | |
123 | ||
124 | ;;; simplified select: returns #t if input is waiting or #f if timed out. | |
cafa4c68 | 125 | ;;; timeout is an absolute time in floating point seconds. |
ec8469e7 | 126 | (define-public (expect-select port timeout) |
cafa4c68 GH |
127 | (let* ((secs-usecs (gettimeofday)) |
128 | (relative (- timeout | |
129 | (car secs-usecs) | |
130 | (/ (cdr secs-usecs) | |
131 | 1000000)))) ; one million. | |
d7189b49 | 132 | (and (> relative 0) |
28d8ab3c | 133 | (pair? (car (select (list port) '() '() |
cafa4c68 | 134 | relative)))))) |
28d8ab3c | 135 | |
2645b7b8 | 136 | ;;; return a regexp match as a list of strings, for the => syntax. |
156ecad5 | 137 | (define-public (expect-regexec rx s port) |
2645b7b8 JB |
138 | ;; if expect-strings-exec-flags contains regexp/noteol, |
139 | ;; check whether at EOF. if so, remove regexp/noteol | |
140 | (let* ((eof-next? | |
141 | (and (logand expect-strings-exec-flags regexp/noteol) | |
142 | (eof-object? (peek-char port)))) | |
143 | (flags (if eof-next? | |
144 | (logxor expect-strings-exec-flags regexp/noteol) | |
145 | expect-strings-exec-flags)) | |
156ecad5 | 146 | (match (regexp-exec rx s 0 flags))) |
28d8ab3c GH |
147 | (if match |
148 | (do ((i (- (match:count match) 1) (- i 1)) | |
149 | (result '() (cons (match:substring match i) result))) | |
150 | ((< i 0) result)) | |
151 | #f))) | |
2645b7b8 | 152 |