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