Import Upstream version 5d2upstream/5d2

1 files changed, 60 insertions, 0 deletions

diff --git a/Tscript.scm b/Tscript.scm
new file mode 100644
index 0000000..22b80ea
--- /dev/null
+++ b/Tscript.scm
@@ -0,0 +1,60 @@
+(define transcript-on #f)
+(define transcript-off #f)
+
+(let ((*transcript-stack* '()))
+  (define (trans-on filename)
+    (let ((trans (open-output-file filename))
+	  (inp (current-input-port))
+	  (outp (current-output-port))
+	  (errp (current-error-port)))
+      (define (clone-port port)
+	(make-soft-port
+	 (vector (and (output-port? port)
+		      (lambda (c)
+			(write-char c port)
+			(write-char c trans)))
+		 (and (output-port? port)
+		      (lambda (s)
+			(display s port)
+			(display s trans)))
+		 (and (output-port? port)
+		      (lambda ()
+			(force-output port)
+			(force-output trans)))
+		 (and (input-port? port)
+		      (lambda ()
+			(let ((c (read-char port)))
+			  (write-char c trans)
+			  c)))
+		 (lambda ()
+		   (close-port port)))
+	 (if (input-port? port)
+	     (if (output-port? port) "r+" "r")
+	     "w")))
+
+      (set! *transcript-stack*
+	    (cons (list trans
+			(current-input-port)
+			(current-output-port)
+			(current-error-port))
+		  *transcript-stack*))
+      (set-current-input-port (clone-port inp))
+      (set-current-output-port (clone-port outp))
+      (set-current-error-port (clone-port errp))))
+
+  (define (trans-off)
+    (cond ((pair? *transcript-stack*)
+	   (apply (lambda (trans inp outp errp)
+		    (close-port trans)
+		    (set-current-input-port inp)
+		    (set-current-output-port outp)
+		    (set-current-error-port errp))
+		  (car *transcript-stack*))
+	   (set! *transcript-stack* (cdr *transcript-stack*)))
+	  (else
+	   (error "No transcript active"))))
+
+  (set! transcript-on trans-on)
+  (set! transcript-off trans-off))
+
+(provide 'transcript)
\ No newline at end of file