diff options
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 |