dup-{in,out}put-port and sandbox-error-output default

svn: r9617

collects/mzlib/port.ss

@@ -1774,6 +1774,41 @@
 				   (memq mode '(none))))
 		      ;; Flush output
 		      (write-it #"" 0 0 #f #f)))])))))
+
+  ;; ----------------------------------------
+
+  (define dup-output-port
+    (opt-lambda (p [close? #f])
+      (let ([new (transplant-output-port p 
+                                         (lambda ()
+                                           (port-next-location p))
+                                         (let-values ([(line col pos)
+                                                       (port-next-location p)])
+                                           (or pos
+                                               (file-position p)))
+                                         close?
+                                         (lambda ()
+                                           (port-count-lines! p)))])
+        (port-display-handler new (port-display-handler p))
+        (port-write-handler new (port-write-handler p))
+        new)))
+
+  (define dup-input-port
+    (opt-lambda (p [close? #f])
+      (let ([new (transplant-input-port p 
+                                        (lambda ()
+                                          (port-next-location p))
+                                        (let-values ([(line col pos)
+                                                      (port-next-location p)])
+                                          (or pos
+                                              (file-position p)))
+                                        close?
+                                        (lambda ()
+                                          (port-count-lines! p)))])
+        (port-read-handler new (port-read-handler p))
+        new)))
+
+  ;; ----------------------------------------
   
   (provide open-output-nowhere
 	   make-pipe-with-specials
@@ -1790,6 +1825,8 @@
 	   make-limited-input-port
 	   reencode-input-port
 	   reencode-output-port
+           dup-input-port
+           dup-output-port
 	   strip-shell-command-start)
   
   (provide/contract (read-bytes-avail!-evt (mutable-bytes? input-port-with-progress-evts?

collects/scheme/sandbox.ss

@@ -45,7 +45,8 @@
 (define sandbox-init-hook    (make-parameter void))
 (define sandbox-input        (make-parameter #f))
 (define sandbox-output       (make-parameter #f))
-(define sandbox-error-output (make-parameter current-error-port))
+(define sandbox-error-output (make-parameter (lambda ()
+                                               (dup-output-port (current-error-port)))))
 (define sandbox-eval-limits  (make-parameter '(30 20))) ; 30sec, 20mb
 (define sandbox-propagate-breaks (make-parameter #t))
 (define sandbox-coverage-enabled (make-parameter #f))

collects/scribblings/reference/port-lib.scrbl

@@ -269,6 +269,33 @@ flush or special-write to the output port can hang if the most
 recently written bytes form an incomplete encoding sequence.}
 
 
+@defproc[(dup-input-port [in input-port?]
+                         [close? any/c #f])
+         input-port?]{
+
+Returns an input port that draws directly from @scheme[in]. Closing
+the resulting port closes @scheme[in] only if @scheme[close?] is
+@scheme[#t].
+
+The new port is initialized with the @tech{port read handler} of
+@scheme[in], but setting the handler on the result port does not
+affect reading directly from @scheme[in].}
+
+
+@defproc[(dup-output-port [out output-port?]
+                          [close? any/c #f])
+         output-port?]{
+
+Returns an output port that propagates data directly to
+@scheme[out]. Closing the resulting port closes @scheme[out] only if
+@scheme[close?] is @scheme[#t].
+
+The new port is initialized with the @tech{port display handler} and
+@tech{port write handler} of @scheme[out], but setting the handlers on
+the result port does not affect writing directly to @scheme[out].}
+
+
+
 @defproc[(relocate-input-port [in input-port?]
                               [line (or/c exact-positive-integer? false/c)]
                               [column (or/c exact-nonnegative-integer? false/c)]

collects/scribblings/reference/sandbox.scrbl

@@ -2,6 +2,7 @@
 @(require "mz.ss"
           scheme/sandbox
           (for-label scheme/sandbox
+                     scheme/port
                      (only-in scheme/gui make-gui-namespace)
                      scheme/gui/dynamic))
 
@@ -306,9 +307,9 @@ after its output, so using @scheme[current-output-port] for this
 parameter value means that the error port is the same as the
 evaluator's initial output port.
 
-The default is @scheme[current-error-port], which means that the error
-output of the generated evaluator goes to the calling context's error
-port.}
+The default is @scheme[(lambda () (dup-output-port
+(current-error-port)))], which means that the error output of the
+generated evaluator goes to the calling context's error port.}
 
 
 @defboolparam[sandbox-coverage-enabled enabled?]{

collects/tests/mzscheme/portlib.ss

@@ -666,4 +666,28 @@
 
 ;; --------------------------------------------------
 
+(let-values ([(in out) (make-pipe)])
+  (let ([in2 (dup-input-port in #f)]
+        [out2 (dup-output-port out #f)])
+    (port-count-lines! in2)
+    (test-values (list 1 0 1) (lambda ()
+                                (port-next-location in2)))
+    (display "\"hel\u03BBo\"\n" out)
+    (test "hel\u03BBo" read in2)
+    (test-values (list 1 7 8)
+                 (lambda ()
+                   (port-next-location in2)))
+    (test #\newline read-char in2)
+    (test-values (list 2 0 9) 
+                 (lambda () 
+                   (port-next-location in2)))
+    (close-output-port out2)
+    (test #f char-ready? in2)
+    (close-input-port in2)
+    (display "x " out)
+    (test 'x read in)))
+    
+
+;; --------------------------------------------------
+
 (report-errs)