From 1dd30ca031de14fda4a9858f974e1dd0bfeaf209 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Sat, 3 May 2008 04:47:14 +0000 Subject: [PATCH] dup-{in,out}put-port and sandbox-error-output default svn: r9617 --- collects/mzlib/port.ss | 37 +++++++++++++++++++ collects/scheme/sandbox.ss | 3 +- collects/scribblings/reference/port-lib.scrbl | 27 ++++++++++++++ collects/scribblings/reference/sandbox.scrbl | 7 ++-- collects/tests/mzscheme/portlib.ss | 24 ++++++++++++ 5 files changed, 94 insertions(+), 4 deletions(-) diff --git a/collects/mzlib/port.ss b/collects/mzlib/port.ss index 9d1751d845..17441c20cb 100644 --- a/collects/mzlib/port.ss +++ b/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? diff --git a/collects/scheme/sandbox.ss b/collects/scheme/sandbox.ss index 5617d9eac0..820e4e972b 100644 --- a/collects/scheme/sandbox.ss +++ b/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)) diff --git a/collects/scribblings/reference/port-lib.scrbl b/collects/scribblings/reference/port-lib.scrbl index b73d77e7a4..474da5fbad 100644 --- a/collects/scribblings/reference/port-lib.scrbl +++ b/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)] diff --git a/collects/scribblings/reference/sandbox.scrbl b/collects/scribblings/reference/sandbox.scrbl index 5186f0d928..3aded752b1 100644 --- a/collects/scribblings/reference/sandbox.scrbl +++ b/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?]{ diff --git a/collects/tests/mzscheme/portlib.ss b/collects/tests/mzscheme/portlib.ss index f9c2aa58d4..809fdb3c11 100644 --- a/collects/tests/mzscheme/portlib.ss +++ b/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)