From d8dd3224cc810df6414bf9c90bb0df8504a8cfb6 Mon Sep 17 00:00:00 2001
From: Eli Barzilay <eli@racket-lang.org>
Date: Mon, 9 Apr 2007 11:11:22 +0000
Subject: [PATCH] better sandbox input

svn: r5905

original commit: 30a27b1d8bd291c53d7bb0b2435e0cef8fac721a
---
 collects/mzlib/sandbox.ss | 40 ++++++++++++++++++++++++++-------------
 1 file changed, 27 insertions(+), 13 deletions(-)

diff --git a/collects/mzlib/sandbox.ss b/collects/mzlib/sandbox.ss
index 90e3dff..ccae084 100644
--- a/collects/mzlib/sandbox.ss
+++ b/collects/mzlib/sandbox.ss
@@ -16,10 +16,11 @@
            sandbox-network-guard
            sandbox-eval-limits
            kill-evaluator
+           set-eval-limits
+           put-input
            get-output
            get-error-output
            get-uncovered-expressions
-           set-eval-limits
            make-evaluator
            call-with-limits
            with-limits
@@ -354,12 +355,12 @@
   (define null-input         (open-input-bytes #""))
 
   (define (kill-evaluator eval)            (eval kill-evaluator))
+  (define (set-eval-limits eval . args)    ((eval set-eval-limits) args))
+  (define (put-input eval . args)          (apply (eval put-input) args))
   (define (get-output eval)                (eval get-output))
   (define (get-error-output eval)          (eval get-error-output))
   (define (get-uncovered-expressions eval . args)
     (apply (eval get-uncovered-expressions) args))
-  (define (set-eval-limits eval . args)
-    (apply (eval set-eval-limits) args))
 
   (define-syntax parameterize*
     (syntax-rules ()
@@ -374,6 +375,7 @@
     (define uncovered     #f)
     (define input-ch      (make-channel))
     (define result-ch     (make-channel))
+    (define input         #f)
     (define output        #f)
     (define error-output  #f)
     (define limits        (sandbox-eval-limits))
@@ -430,15 +432,24 @@
            (if src
              (filter (lambda (x) (equal? src (syntax-source x))) uncovered)
              uncovered))]))
+    (define (output-getter p) (if (procedure? p) (user-eval `(,p)) p))
+    (define input-putter
+      (case-lambda
+        [() (input-putter input-putter)]
+        [(arg) (cond [(not input)
+                      (error 'put-input "evaluator input is not 'pipe")]
+                     [(or (string? arg) (bytes? arg))
+                      (display arg input) (flush-output input)]
+                     [(eof-object? arg) (close-output-port input)]
+                     [(eq? arg input-putter) input]
+                     [else (error 'put-input "bad input: ~e" arg)])]))
     (define (evaluator expr)
       (cond [(eq? expr kill-evaluator) (kill-me)]
-            [(eq? expr get-output)
-             (if (procedure? output) (user-eval `(,output)) output)]
-            [(eq? expr get-error-output)
-             (if (procedure? error-output)
-               (user-eval `(,error-output)) error-output)]
+            [(eq? expr set-eval-limits) (lambda (args) (set! limits args))]
+            [(eq? expr put-input) input-putter]
+            [(eq? expr get-output) (output-getter output)]
+            [(eq? expr get-error-output) (output-getter error-output)]
             [(eq? expr get-uncovered-expressions) get-uncovered]
-            [(eq? expr set-eval-limits) (lambda args (set! limits args))]
             [else (user-eval expr)]))
     (define linked-outputs? #f)
     (define (make-output what out set-out! allow-link?)
@@ -471,10 +482,13 @@
          ;; set up the IO context
          [current-input-port
           (let ([inp (sandbox-input)])
-            (if inp
-              (or (input->port inp)
-                  (error 'make-evaluator "bad sandbox-input: ~e" inp))
-              null-input))]
+            (cond
+              [(not inp) null-input]
+              [(input->port inp) => values]
+              [(and (procedure? inp) (procedure-arity-includes? inp 0)) (inp)]
+              [(eq? 'pipe inp)
+               (let-values ([(i o) (make-pipe)]) (set! input o) i)]
+              [else (error 'make-evaluator "bad sandbox-input: ~e" inp)]))]
          [current-output-port (make-output 'output (sandbox-output)
                                            (lambda (o) (set! output o))
                                            #f)]