expect.scm 5.5 KB

123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899100101102103104105106107108109110111112113114115116117118119120121122123124125126127128129130131132133134135136137138139140141142143144145146147148149150151152153154155156157158159160161162163164165166167168169170171172
  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 3 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. ;;; Commentary:
  18. ;; This module is documented in the Guile Reference Manual.
  19. ;; Briefly, these are exported:
  20. ;; procedures: expect-select, expect-regexec
  21. ;; variables: expect-port, expect-timeout, expect-timeout-proc,
  22. ;; expect-eof-proc, expect-char-proc,
  23. ;; expect-strings-compile-flags, expect-strings-exec-flags,
  24. ;; macros: expect, expect-strings
  25. ;;; Code:
  26. (define-module (ice-9 expect)
  27. :use-module (ice-9 regex)
  28. :export-syntax (expect expect-strings)
  29. :export (expect-port expect-timeout expect-timeout-proc
  30. expect-eof-proc expect-char-proc expect-strings-compile-flags
  31. expect-strings-exec-flags expect-select expect-regexec))
  32. ;;; Expect: a macro for selecting actions based on what it reads from a port.
  33. ;;; The idea is from Don Libes' expect based on Tcl.
  34. ;;; This version by Gary Houston incorporating ideas from Aubrey Jaffer.
  35. (define expect-port #f)
  36. (define expect-timeout #f)
  37. (define expect-timeout-proc #f)
  38. (define expect-eof-proc #f)
  39. (define expect-char-proc #f)
  40. ;;; expect: each test is a procedure which is applied to the accumulating
  41. ;;; string.
  42. (defmacro expect clauses
  43. (let ((s (gensym))
  44. (c (gensym))
  45. (port (gensym))
  46. (timeout (gensym)))
  47. `(let ((,s "")
  48. (,port (or expect-port (current-input-port)))
  49. ;; when timeout occurs, in floating point seconds.
  50. (,timeout (if expect-timeout
  51. (let* ((secs-usecs (gettimeofday)))
  52. (+ (car secs-usecs)
  53. expect-timeout
  54. (/ (cdr secs-usecs)
  55. 1000000))) ; one million.
  56. #f)))
  57. (let next-char ()
  58. (if (and expect-timeout
  59. (not (expect-select ,port ,timeout)))
  60. (if expect-timeout-proc
  61. (expect-timeout-proc ,s)
  62. #f)
  63. (let ((,c (read-char ,port)))
  64. (if expect-char-proc
  65. (expect-char-proc ,c))
  66. (if (not (eof-object? ,c))
  67. (set! ,s (string-append ,s (string ,c))))
  68. (cond
  69. ;; this expands to clauses where the car invokes the
  70. ;; match proc and the cdr is the return value from expect
  71. ;; if the proc matched.
  72. ,@(let next-expr ((tests (map car clauses))
  73. (exprs (map cdr clauses))
  74. (body '()))
  75. (cond
  76. ((null? tests)
  77. (reverse body))
  78. (else
  79. (next-expr
  80. (cdr tests)
  81. (cdr exprs)
  82. (cons
  83. `((,(car tests) ,s (eof-object? ,c))
  84. ,@(cond ((null? (car exprs))
  85. '())
  86. ((eq? (caar exprs) '=>)
  87. (if (not (= (length (car exprs))
  88. 2))
  89. (scm-error 'misc-error
  90. "expect"
  91. "bad recipient: ~S"
  92. (list (car exprs))
  93. #f)
  94. `((apply ,(cadar exprs)
  95. (,(car tests) ,s ,port)))))
  96. (else
  97. (car exprs))))
  98. body)))))
  99. ;; if none of the clauses matched the current string.
  100. (else (cond ((eof-object? ,c)
  101. (if expect-eof-proc
  102. (expect-eof-proc ,s)
  103. #f))
  104. (else
  105. (next-char)))))))))))
  106. (define expect-strings-compile-flags regexp/newline)
  107. (define expect-strings-exec-flags regexp/noteol)
  108. ;;; the regexec front-end to expect:
  109. ;;; each test must evaluate to a regular expression.
  110. (defmacro expect-strings clauses
  111. `(let ,@(let next-test ((tests (map car clauses))
  112. (exprs (map cdr clauses))
  113. (defs '())
  114. (body '()))
  115. (cond ((null? tests)
  116. (list (reverse defs) `(expect ,@(reverse body))))
  117. (else
  118. (let ((rxname (gensym)))
  119. (next-test (cdr tests)
  120. (cdr exprs)
  121. (cons `(,rxname (make-regexp
  122. ,(car tests)
  123. expect-strings-compile-flags))
  124. defs)
  125. (cons `((lambda (s eof?)
  126. (expect-regexec ,rxname s eof?))
  127. ,@(car exprs))
  128. body))))))))
  129. ;;; simplified select: returns #t if input is waiting or #f if timed out or
  130. ;;; select was interrupted by a signal.
  131. ;;; timeout is an absolute time in floating point seconds.
  132. (define (expect-select port timeout)
  133. (let* ((secs-usecs (gettimeofday))
  134. (relative (- timeout
  135. (car secs-usecs)
  136. (/ (cdr secs-usecs)
  137. 1000000)))) ; one million.
  138. (and (> relative 0)
  139. (pair? (car (select (list port) '() '()
  140. relative))))))
  141. ;;; match a string against a regexp, returning a list of strings (required
  142. ;;; by the => syntax) or #f. called once each time a character is added
  143. ;;; to s (eof? will be #f), and once when eof is reached (with eof? #t).
  144. (define (expect-regexec rx s eof?)
  145. ;; if expect-strings-exec-flags contains regexp/noteol,
  146. ;; remove it for the eof test.
  147. (let* ((flags (if (and eof?
  148. (logand expect-strings-exec-flags regexp/noteol))
  149. (logxor expect-strings-exec-flags regexp/noteol)
  150. expect-strings-exec-flags))
  151. (match (regexp-exec rx s 0 flags)))
  152. (if match
  153. (do ((i (- (match:count match) 1) (- i 1))
  154. (result '() (cons (match:substring match i) result)))
  155. ((< i 0) result))
  156. #f)))
  157. ;;; expect.scm ends here