commit 6ce47a9d1e8aba5b083c8e5832571b94d6db5106
parent d9f0de4582f7292d8dae03d96aaeea474c730c91
Author: Matthew Flatt <mflatt@racket-lang.org>
Date: Tue, 24 Aug 2010 20:50:46 -0600
change Scribble's `interaction', etc. to use non-default `current-print'
to format results, if one is installed in a sandboxed evaluator
original commit: a19899898f1f7774f634ad44df560f4813fec91c
Diffstat:
2 files changed, 70 insertions(+), 39 deletions(-)
diff --git a/collects/scribble/eval.rkt b/collects/scribble/eval.rkt
@@ -92,40 +92,45 @@
(make-flow (list p))))))
(format-output (cadar val-list+outputs) output-color)
(format-output (caddar val-list+outputs) error-color)
- (if (string? (caar val-list+outputs))
- ;; Error result case:
- (map
- (lambda (s)
- (car (format-output s error-color)))
- (filter
- (lambda (s) (not (equal? s "")))
- (let sloop ([s (caar val-list+outputs)])
- (apply
- append
- (map (lambda (s)
- (if ((string-length s) . > . maxlen)
- ;; break the error message into multiple lines:
- (let loop ([pos (sub1 maxlen)])
- (cond
- [(zero? pos) (cons (substring s 0 maxlen)
- (sloop (substring s maxlen)))]
- [(char-whitespace? (string-ref s pos))
- (cons (substring s 0 pos)
- (sloop (substring s (add1 pos))))]
- [else (loop (sub1 pos))]))
- (list s)))
- (regexp-split #rx"\n" s))))))
- ;; Normal result case:
- (let ([val-list (caar val-list+outputs)])
- (if (equal? val-list (list (void)))
- null
- (map (lambda (v)
- (list (make-flow (list (make-paragraph
- (list
- (hspace 2)
- (elem #:style result-color
- (to-element/no-color v #:expr? (print-as-expression)))))))))
- val-list))))
+ (cond
+ [(string? (caar val-list+outputs))
+ ;; Error result case:
+ (map
+ (lambda (s)
+ (car (format-output s error-color)))
+ (filter
+ (lambda (s) (not (equal? s "")))
+ (let sloop ([s (caar val-list+outputs)])
+ (apply
+ append
+ (map (lambda (s)
+ (if ((string-length s) . > . maxlen)
+ ;; break the error message into multiple lines:
+ (let loop ([pos (sub1 maxlen)])
+ (cond
+ [(zero? pos) (cons (substring s 0 maxlen)
+ (sloop (substring s maxlen)))]
+ [(char-whitespace? (string-ref s pos))
+ (cons (substring s 0 pos)
+ (sloop (substring s (add1 pos))))]
+ [else (loop (sub1 pos))]))
+ (list s)))
+ (regexp-split #rx"\n" s))))))]
+ [(box? (caar val-list+outputs))
+ ;; Output formatted as string:
+ (format-output (unbox (caar val-list+outputs)) result-color)]
+ [else
+ ;; Normal result case:
+ (let ([val-list (caar val-list+outputs)])
+ (if (equal? val-list (list (void)))
+ null
+ (map (lambda (v)
+ (list (make-flow (list (make-paragraph
+ (list
+ (hspace 2)
+ (elem #:style result-color
+ (to-element/no-color v #:expr? (print-as-expression)))))))))
+ val-list)))])
(loop (cdr expr-paras)
(cdr val-list+outputs)
#f)))))))
@@ -159,7 +164,21 @@
(get-output ev)
(get-error-output ev)))])
(list (let ([v (do-plain-eval ev s #t)])
- (make-reader-graph (copy-value v (make-hasheq))))
+ (if (call-in-sandbox-context
+ ev
+ (let ([cp (current-print)])
+ (lambda ()
+ (and (eq? (current-print) cp)
+ (print-as-expression)))))
+ (make-reader-graph (copy-value v (make-hasheq)))
+ (box
+ (call-in-sandbox-context
+ ev
+ (lambda ()
+ (let ([s (open-output-string)])
+ (parameterize ([current-output-port s])
+ (map (current-print) v))
+ (get-output-string s)))))))
(get-output ev)
(get-error-output ev)))])
(when expect
diff --git a/collects/scribblings/scribble/eval.scrbl b/collects/scribblings/scribble/eval.scrbl
@@ -25,12 +25,24 @@ set to @racket['string]. If @racket[eval] is not provided, an
evaluator is created using @racket[make-base-eval]. See also
@racket[make-eval-factory].
+If the value of @racket[current-print] in the sandbox is changed from
+its default value, or if @racket[print-as-expression] in the sandbox
+is set to @racket[#f], then each evaluation result is formatted to a
+string by applying @racket[(current-print)] to the value (with the
+output port set to a string port). Otherwise, result values are
+typeset using @racket[to-element/no-color].
+
Uses of @racket[code:comment] and @racketidfont{code:blank} are
stipped from each @racket[datum] before evaluation.
If a @racket[datum] has the form @racket[(@#,indexed-racket[eval:alts]
#,(svar show-datum) #,(svar eval-datum))], then @svar[show-datum] is
-typeset, while @svar[eval-datum] is evaluated.}
+typeset, while @svar[eval-datum] is evaluated.
+
+If a @racket[datum] has the form
+@racket[(@#,indexed-racket[eval:check] #,(svar eval-datum) #,(svar
+expect-datum))], then both @svar[eval-datum] and @svar[check-datum]
+are evaluated, and an error is raised if they are not @racket[equal?].}
@defform*[[(interaction-eval datum)
@@ -90,8 +102,8 @@ prompt, and with line of space after it.}
@defproc[(make-base-eval) (any/c . -> . any)]{
Creates an evaluator using @racket[(make-evaluator 'racket/base)],
-setting sandbox parameters to disable limits, set the outputs to
-@racket['string], and not add extra security guards.}
+setting sandbox parameters to disable limits, setting the outputs to
+@racket['string], and not adding extra security guards.}
@defproc[(make-base-eval-factory [mod-paths (listof module-path?)]) (-> (any/c . -> . any))]{
@@ -105,7 +117,7 @@ time) and then attached to each evaluator that is created.}
@defproc[(make-eval-factory [mod-paths (listof module-path?)]) (-> (any/c . -> . any))]{
-Like @racket[make-base-eval-factor], but each module in @racket[mod-paths] is
+Like @racket[make-base-eval-factory], but each module in @racket[mod-paths] is
also required into the top-level environment for each generated evaluator.}
