- removed obsolete code
- cleaned up syntax rules - moved eof-patter to interact.scm
This commit is contained in:
frese
parent
7606bdca71
commit
7642842a3a
|
|
@ -96,121 +96,6 @@
|
|||
(close (task:in task))
|
||||
(close (task:out task)))
|
||||
|
||||
;;;; Append info to a buffer without its going over the max size.
|
||||
;;;; As data is moved out of the match buffer, it is moved into
|
||||
;;;; the pre-match buffer.
|
||||
;;;;
|
||||
;;;; Ack, this is not too efficient. Need to change this whole style.
|
||||
;
|
||||
;(define (buf-append task str max-size)
|
||||
; (let* ((buf (task:buf task))
|
||||
; (buf-size (string-length buf))
|
||||
; (str-size (string-length str))
|
||||
; (total-size (+ buf-size str-size)))
|
||||
;
|
||||
; (cond ((<= total-size max-size) ; BUF := all of BUF + all of STR.
|
||||
; (string-append buf str))
|
||||
;
|
||||
; ;; BUF := some of BUF + all of STR.
|
||||
; ((<= str-size max-size)
|
||||
; (let ((i (- total-size max-size)))
|
||||
; (set-task:pre-match! (string-append (task:pre-match task)
|
||||
; (substring buf 0 i)))
|
||||
; (string-append (substring buf i buf-size)
|
||||
; str)))
|
||||
;
|
||||
; ;; BUF := some of STR.
|
||||
; (else (let ((i (- str-size max-size)))
|
||||
; (set-task:pre-match! (string-append (task:pre-match task)
|
||||
; buf
|
||||
; (substring str 0 i)))
|
||||
; (substring str i str-size))))))
|
||||
|
||||
|
||||
;;; We just matched M out of BUFFER.
|
||||
;;; - Put everything in BUFFER *before* the match into (TASK:PRE-MATCH TASK).
|
||||
;;; - Put everything in BUFFER *after* the match into (TASK:BUF TASK).
|
||||
|
||||
(define (set-prematch task buffer m)
|
||||
(set-task:pre-match! task (substring buffer 0 (match:start m)))
|
||||
(set-task:buf! task
|
||||
(substring buffer (match:end m) (string-length buffer))))
|
||||
|
||||
|
||||
;;; Slurp in data from port ivec[i] and add it to the task's buffer.
|
||||
;;; Return the new data (not the whole buffer).
|
||||
;;; If we get EOF instead, set ivec[i] to #f and return false. This is
|
||||
;;; really inefficient in space and time -- every time we get a little bit
|
||||
;;; of input, we copy and throw away the whole match buffer. Argh.
|
||||
|
||||
(define (do-input task)
|
||||
(let* ((port (task:in task))
|
||||
|
||||
;; If the read blows up, return #f. This is how tty's indicate
|
||||
;; to pty's they've been closed. Ugh.
|
||||
(s (with-errno-handler ((e p) ((errno/io) #f))
|
||||
(read-string/partial 256 port))))
|
||||
|
||||
(and s (let ((newbuf (string-append (task:buf task) s)))
|
||||
(set-task:buf! task newbuf)
|
||||
s))))
|
||||
|
||||
;;; A (<task> <aclause> ...) task-clause becomes the following chunk of code
|
||||
;;; that is executed after the select call on ivec[]. I is the index of
|
||||
;;; <task>'s input port in the port vector ivec:
|
||||
;;;
|
||||
;;; If ivec[i] is non-#f
|
||||
;;; -- Select says there's input available.
|
||||
;;; Get input from task
|
||||
;;; If EOF
|
||||
;;; ivec[i] := #f (This task is now permanently out of the running.)
|
||||
;;; If there's an ON-EOF clause, do it and quit.
|
||||
;;; If no ON-EOF clause, go on to task i+1.
|
||||
;;; else we got some data:
|
||||
;;; Try out matches. On match, do the match action & we are done.
|
||||
;;; If no match, go on to task i+1
|
||||
;;;
|
||||
;;; If ivec[i] is #f
|
||||
;;; -- No input available right now.
|
||||
;;; ivec[i] := taski.in (Put the input port back in the vector)
|
||||
;;; go on to task i+1
|
||||
;;;
|
||||
;;; "go on to task i+i" means "loop back to the select call" when task i
|
||||
;;; is the last one.
|
||||
|
||||
(define (try-task ivec i task try-match-clauses do-next do-eof monitor)
|
||||
(if (vector-ref ivec i)
|
||||
|
||||
;; Input is available (or EOF). Read it in.
|
||||
;; If we get some, try out the pattern/action clauses.
|
||||
;; If we get EOF, do the EOF action (which is the ON-EOF action clause,
|
||||
;; if there is one, or go on to the next task clause if there isn't).
|
||||
(cond ((do-input task) =>
|
||||
(lambda (i) (try-match-clauses (task:buf task) i do-next)))
|
||||
(else
|
||||
(set-task:pre-match! task (task:buf task))
|
||||
(set-task:buf! task "")
|
||||
(monitor task #f) ; Signal EOF
|
||||
(do-eof)
|
||||
(vector-set! ivec i #f)))
|
||||
|
||||
;; No input available for task i. Put it back in the select vector
|
||||
;; for next time, and go on to the next thing.
|
||||
(begin (vector-set! ivec i (task:in task))
|
||||
(do-next))))
|
||||
|
||||
|
||||
;;; M is the match. S is the total string. I is the new data that just
|
||||
;;; arrived -- a non-empty suffix of S.
|
||||
(define (do-match-hacking task m s i monitor)
|
||||
;; Log all new data up to the match.
|
||||
(let* ((delta (- (string-length s) (string-length i)))
|
||||
(mend (- (match:end m 0) delta)))
|
||||
(monitor task (substring i 0 mend))
|
||||
(monitor task m))
|
||||
(set-prematch task s m)) ; Set the prematch buffer.
|
||||
|
||||
|
||||
;;; The default monitor -- does nothing.
|
||||
(define (null-monitor task event) #f)
|
||||
|
||||
|
|
@ -289,12 +174,6 @@
|
|||
(define *default-echo* #f)
|
||||
(define *default-max-size* #f)
|
||||
|
||||
(define-record-type :eof-pattern
|
||||
(make-eof-pattern)
|
||||
eof-pattern?)
|
||||
|
||||
(define eof-pattern (make-eof-pattern))
|
||||
|
||||
(define (in-select! rvec timeout)
|
||||
(receive (in out ex)
|
||||
(select! rvec '#() '#() timeout)
|
||||
|
|
@ -323,6 +202,33 @@
|
|||
(else *default-max-size*))))
|
||||
(expect-1* on-timeout monitor timeout echo max-size tasks-patterns-alist)))
|
||||
|
||||
;;; Slurp in data from port and add it to the task's buffer. Return
|
||||
;;; the new data (not the whole buffer). If we get EOF instead, set
|
||||
;;; ivec[i] to #f and return false. This is really inefficient in
|
||||
;;; space and time -- every time we get a little bit of input, we copy
|
||||
;;; and throw away the whole match buffer. Argh.
|
||||
|
||||
(define (do-input task)
|
||||
(let* ((port (task:in task))
|
||||
|
||||
;; If the read blows up, return #f. This is how tty's indicate
|
||||
;; to pty's they've been closed. Ugh.
|
||||
(s (with-errno-handler ((e p) ((errno/io) #f))
|
||||
(read-string/partial 256 port))))
|
||||
|
||||
(and s (let ((newbuf (string-append (task:buf task) s)))
|
||||
(set-task:buf! task newbuf)
|
||||
s))))
|
||||
|
||||
;;; We just matched M out of BUFFER.
|
||||
;;; - Put everything in BUFFER *before* the match into (TASK:PRE-MATCH TASK).
|
||||
;;; - Put everything in BUFFER *after* the match into (TASK:BUF TASK).
|
||||
|
||||
(define (set-prematch task buffer m)
|
||||
(set-task:pre-match! task (substring buffer 0 (match:start m)))
|
||||
(set-task:buf! task
|
||||
(substring buffer (match:end m) (string-length buffer))))
|
||||
|
||||
(define (expect-1* on-timeout monitor timeout echo max-size
|
||||
tasks-patterns-alist)
|
||||
(let ((handle-input
|
||||
|
|
@ -336,9 +242,14 @@
|
|||
((match)
|
||||
(let ((m (string-match ((cadr pattern)) s)))
|
||||
(if m
|
||||
(begin
|
||||
(do-match-hacking task m s input monitor)
|
||||
(monitor task m) ;; ??
|
||||
;; Log all new data up to the match.
|
||||
(let* ((delta (- (string-length s)
|
||||
(string-length input)))
|
||||
(mend (- (match:end m 0) delta)))
|
||||
(monitor task (substring input 0 mend))
|
||||
(monitor task m)
|
||||
;; Set the prematch buffer.
|
||||
(set-prematch task s m)
|
||||
((caddr pattern) m))
|
||||
(loop (cdr patterns)))))
|
||||
((eof) (loop (cdr patterns)))
|
||||
|
|
@ -446,46 +357,52 @@
|
|||
|
||||
(define-syntax expect-action-clauses
|
||||
(syntax-rules (on-eof test => else)
|
||||
((expect-action-clauses loop)
|
||||
((expect-action-clauses)
|
||||
'())
|
||||
((expect-action-clauses loop (on-eof body ...) clause ...)
|
||||
((expect-action-clauses (on-eof body ...) clause ...)
|
||||
(cons (list 'eof
|
||||
(lambda () body ...))
|
||||
(expect-action-clauses loop clause ...)))
|
||||
((expect-action-clauses loop (test exp body ...) clause ...)
|
||||
(expect-action-clauses clause ...)))
|
||||
((expect-action-clauses (test exp body ...) clause ...)
|
||||
(cons (list 'test
|
||||
(lambda () exp)
|
||||
(lambda (_) body ...))
|
||||
(expect-action-clauses loop clause ...)))
|
||||
((expect-action-clauses loop (test exp => proc) clause ...)
|
||||
(expect-action-clauses clause ...)))
|
||||
((expect-action-clauses (test exp => proc) clause ...)
|
||||
(cons (list 'test
|
||||
(lambda () exp)
|
||||
(lambda (v) (proc v)))
|
||||
(expect-action-clauses loop clause ...)))
|
||||
((expect-action-clauses loop (pattern (mvars ...) body ...) clause ...)
|
||||
(expect-action-clauses clause ...)))
|
||||
((expect-action-clauses (pattern (match mvars ...) body ...) clause ...)
|
||||
(cons (list 'match (lambda () pattern)
|
||||
(lambda (m)
|
||||
(let-match m (mvars ...) body ...)))
|
||||
(expect-action-clauses loop clause ...)))
|
||||
((expect-action-clauses loop (else body ...) clause ...)
|
||||
(let ((match m))
|
||||
(let-match m (mvars ...) body ...))))
|
||||
(expect-action-clauses clause ...)))
|
||||
((expect-action-clauses (else body ...) clause ...)
|
||||
(cons (list else (lambda () body ...))
|
||||
(expect-action-clauses loop clause ...)))))
|
||||
(expect-action-clauses clause ...)))))
|
||||
|
||||
(define-syntax expect-task-clauses
|
||||
(syntax-rules ()
|
||||
((expect-task-clauses loop)
|
||||
'())
|
||||
((expect-task-clauses loop (task aclause ...) clause ...)
|
||||
(append (cons task (expect-action-clauses loop aclause ...))
|
||||
(expect-task-clauses loop clause ...)))))
|
||||
(define-syntax expect-clauses
|
||||
(syntax-rules (option)
|
||||
((expect-clauses)
|
||||
(cons '() '()))
|
||||
((expect-clauses (option oclause ...) clause ...)
|
||||
(let ((res (expect-clauses clause ...)))
|
||||
(cons (append (expect-options-clauses oclause ...) (car res))
|
||||
(cdr res))))
|
||||
((expect-task-clauses (task aclause ...) clause ...)
|
||||
(let ((res (expect-clauses clause ...)))
|
||||
(cons (car res)
|
||||
(cons (cons task (expect-action-clauses aclause ...))
|
||||
(cdr res)))))))
|
||||
|
||||
(define-syntax expect
|
||||
(syntax-rules ()
|
||||
((expect name (var-inits ...) eclause ...)
|
||||
(let name (var-inits ...)
|
||||
(expect* (expect-options-clauses eclause ...)
|
||||
(expect-task-clauses name eclause ...))))
|
||||
(let ((r (expect-clauses eclause ...)))
|
||||
(expect* (car r) (cdr r)))))
|
||||
((expect (x ...) eclause ...)
|
||||
(let loop ()
|
||||
(expect* (expect-options-clauses loop (x ...) eclause ...)
|
||||
(expect-task-clauses loop (x ...) eclause ...))))))
|
||||
(let ((r (expect-clauses (x ...) eclause ...)))
|
||||
(expect* (car r) (cdr r))))))
|
||||
|
|
|
|||
Loading…
Reference in New Issue