diff options
author | Bryan Newbold <bnewbold@robocracy.org> | 2017-02-20 00:05:25 -0800 |
---|---|---|
committer | Bryan Newbold <bnewbold@robocracy.org> | 2017-02-20 00:05:25 -0800 |
commit | 3278b75942bdbe706f7a0fba87729bb1e935b68b (patch) | |
tree | dcad4048dfc0b38367047426b2b14501bf5ff257 /Tscript.scm | |
parent | db04688faa20f3576257c0fe41752ec435beab9a (diff) | |
download | scm-58ed489de6cd0bb46878e2d0f4af0ecb62ccf9ce.tar.gz scm-58ed489de6cd0bb46878e2d0f4af0ecb62ccf9ce.zip |
Import Upstream version 5d2upstream/5d2
Diffstat (limited to 'Tscript.scm')
-rw-r--r-- | Tscript.scm | 60 |
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 |