better sandbox input

svn: r5905

collects/handin-server/sandbox.ss

@@ -2,7 +2,8 @@
   (require (lib "sandbox.ss"))
   (provide (all-from (lib "sandbox.ss")))
 
-  ;; discard all outputs
+  ;; no input/output
+  (sandbox-input        #f)
   (sandbox-output       #f)
   (sandbox-error-output #f)
 

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)
+            [(eq? expr set-eval-limits) (lambda (args) (set! limits args))]
-             (if (procedure? output) (user-eval `(,output)) output)]
+            [(eq? expr put-input) input-putter]
-            [(eq? expr get-error-output)
+            [(eq? expr get-output) (output-getter output)]
-             (if (procedure? error-output)
+            [(eq? expr get-error-output) (output-getter error-output)]
-               (user-eval `(,error-output)) 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
+            (cond
-              (or (input->port inp)
+              [(not inp) null-input]
-                  (error 'make-evaluator "bad sandbox-input: ~e" inp))
+              [(input->port inp) => values]
-              null-input))]
+              [(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)]

collects/tests/mzscheme/sandbox.ss

@@ -90,6 +90,26 @@
    --eval-- (begin (printf "a\n") (fprintf (current-error-port) "b\n"))
    --top--  (get-output ev) => "a\n"
             (get-error-output ev) => "b\n"
+   --top--
+   (set! ev (parameterize ([sandbox-input 'pipe]
+                           [sandbox-output 'bytes]
+                           [sandbox-error-output current-output-port]
+                           [sandbox-eval-limits '(0.25 10)])
+              (make-evaluator 'mzscheme '() '(define x 123))))
+   --eval--  (begin (printf "x = ~s\n" x)
+                    (fprintf (current-error-port) "err\n"))
+   --top--   (get-output ev) => #"x = 123\nerr\n"
+             (put-input ev "blah\n")
+             (put-input ev "blah\n")
+   --eval--  (read-line) => "blah"
+             (printf "line = ~s\n" (read-line))
+   --top--   (get-output ev) => #"line = \"blah\"\n"
+   --eval--  (read-line) =err> "out of time"
+   --top--   (put-input ev "blah\n")
+             (put-input ev eof)
+   --eval--  (read-line) => "blah"
+             (read-line) => eof
+             (read-line) => eof
    ;; test kill-evaluator here
    --top--
    (kill-evaluator ev) => (void)