From c966d7d3d2bc0d20c9e38baef28cf2b32e878a94 Mon Sep 17 00:00:00 2001
From: frese <frese>
Date: Tue, 20 Jul 2004 15:39:26 +0000
Subject: [PATCH] - added interact implementation - added wait-task and
 close-task

---
 scheme/expect.scm   | 11 ++++++
 scheme/interact.scm | 81 +++++++++++++++++++++++++++++++++++++++++++++
 scheme/packages.scm |  6 ++--
 3 files changed, 96 insertions(+), 2 deletions(-)
 create mode 100644 scheme/interact.scm

diff --git a/scheme/expect.scm b/scheme/expect.scm
index 5f3687c..a69cd71 100644
--- a/scheme/expect.scm
+++ b/scheme/expect.scm
@@ -42,6 +42,17 @@
 (define (make-task process in out)
   (really-make-task process in out "" #f))
 
+;;; Wait written for tasks.
+
+(define (wait-task task) (wait (task:process task)))
+
+;;; Close all ports associated with a task.
+
+(define (close-task task)
+  (close (task:out task))
+  (close (task:in task)))
+
+
 (define (tsend task fmt . args)
   (apply format (task:out task) fmt args))
 
diff --git a/scheme/interact.scm b/scheme/interact.scm
new file mode 100644
index 0000000..532fcfd
--- /dev/null
+++ b/scheme/interact.scm
@@ -0,0 +1,81 @@
+(define-syntax interact-clause-test
+  (syntax-rules (filter eof)
+    ((interact-clause-test char break) #t)
+    ((interact-clause-test eof break (eof body ...) clause2 ...)
+     (begin body ...))
+    ((interact-clause-test eof break clause1 clause2 ...)
+     (interact-clause-test eof break clause2 ...))
+    ((interact-clause-test char break (eof body ...) clause2 ...)
+     (interact-clause-test char break clause2 ...))
+    ((interact-clause-test char break (filter filter-proc) clause2 ...)
+     (and (filter-proc char break)
+          (interact-clause-test char break clause2 ...)))
+    ((interact-clause-test char break (test-char k body ...) clause2 ...)
+     (if (eq? char test-char) 
+         (and (let ((k break)) body ...)
+              (interact-clause-test char break clause2 ...))
+         (interact-clause-test char break clause2 ...)))))
+
+;;; Allow user to interact with program (sometimes there's just no other way)
+;;; (interact task) simply switches the user into interact mode with the task.
+;;; 
+;;; (interact task clause ...) filters the input.  The clause can either be a
+;;; character clause (character continuation-variable exp ...) or a filter
+;;; clause (filter proc).  A character clause matches the character given,
+;;; links the continuation variable to the continuation out of the
+;;; interaction, and runs the expressions.  A filter clause runs the given
+;;; filter-function with two arguments: the character entered and the
+;;; continuation out of the interaction.  In both cases, if the filter returns
+;;; true, the expression falls through.  If the expression falls through to
+;;; the bottom, the character is printed.  Note that the interaction will
+;;; continue anyway, unless the continuation was explicitly called.
+
+(define-syntax interact
+  (syntax-rules ()
+
+    ;; If there is just one argument, simply enable transfer.
+    ((interact with)
+     (call-with-current-continuation 
+      (lambda (break)
+        (let ((ivec (make-vector 2))
+              (ivec0 (current-input-port))
+              (ivec1 (task:in with)))
+          (with-errno-handler ((e p) ((errno/io) #f))
+            (let lp ()
+              (vector-set! ivec 0 ivec0)
+              (vector-set! ivec 1 ivec1)
+              (select! ivec '#() '#())
+              (if (char-ready? ivec0)
+                  (write-string (read-string/partial 256 ivec0) 
+                                (task:out with)))
+              (if (char-ready? ivec1)
+                  (write-string (read-string/partial 256 ivec1)))
+              (lp)))))))
+
+    ;; If there is more than one argument,
+    ;;enable transfer and allow escape keys.
+    ((interact with clauses ...)
+     (call-with-current-continuation
+      (lambda (break)
+        (let ((ivec (make-vector 2))
+              (ivec0 (current-input-port))
+              (ivec1 (task:in with)))
+          (with-errno-handler ((e p)
+                               ((errno/io)
+                                (interact-clause-test eof #f clauses ...)))
+            (let lp ()
+              (vector-set! ivec 0 ivec0)
+              (vector-set! ivec 1 ivec1)
+              (select! ivec '#() '#())
+              (if (char-ready? (current-input-port))
+                  (for-each (lambda (transfer)
+                              ;; Test for indicated escape keys.
+                              (and (interact-clause-test transfer break
+                                                         clauses ...)
+                                   ;; Only write if all clauses "fell through"
+                                   (write-char transfer (task:out with))))
+                            (string->list (read-string/partial 256 (current-inpu
+t-port)))))
+              (if (char-ready? (task:in with))
+                  (write-string (read-string/partial 256 (task:in with))))
+              (lp)))))))))
diff --git a/scheme/packages.scm b/scheme/packages.scm
index 8677c0b..e6d470c 100644
--- a/scheme/packages.scm
+++ b/scheme/packages.scm
@@ -21,16 +21,18 @@
 	  port->monitor
 
 	  user-task file->task ports->task close-task
+	  wait-task close-task
 	  spawn* (spawn :syntax)
 	  tsend tsend-line
-	  (expect :syntax))
+	  (expect :syntax)
+	  (interact :syntax))
   (for-syntax (open expect-syntax-support scheme))
 
   (open scsh formats structure-refs
 	receiving srfi-9 scheme srfi-13)
   (access signals) ; for ERROR
 
-  (files expect))
+  (files expect interact))
 
 (define-structure chat
   (export chat-abort chat-timeout chat-monitor