From 339aa7144117c62099531235d84699d0fda83f36 Mon Sep 17 00:00:00 2001 From: Eli Barzilay Date: Sat, 31 Jan 2009 20:23:11 +0000 Subject: [PATCH] even better svn: r13341 --- collects/tests/mzscheme/sandbox.ss | 171 +++++++++++++++-------------- 1 file changed, 86 insertions(+), 85 deletions(-) diff --git a/collects/tests/mzscheme/sandbox.ss b/collects/tests/mzscheme/sandbox.ss index 51d77e2a47..11a67e21b0 100644 --- a/collects/tests/mzscheme/sandbox.ss +++ b/collects/tests/mzscheme/sandbox.ss @@ -36,6 +36,14 @@ (test 'shut (lambda () (nested* (shut))))) (let ([ev void]) + (define (make-evaluator! . args) + (set! ev (apply make-evaluator args))) + (define (make-base-evaluator! . args) + (set! ev (apply make-evaluator 'scheme/base args))) + (define (make-base-evaluator/reqs! reqs . args) + (set! ev (apply make-evaluator 'scheme/base #:requires reqs args))) + (define (make-module-evaluator! . args) + (set! ev (apply make-module-evaluator args))) (define (run thunk) (with-handlers ([void (lambda (e) (list 'exn: e))]) (call-with-values thunk (lambda vs (cons 'vals: vs))))) @@ -74,12 +82,12 @@ ;; basic stuff, limits --top-- - (set! ev (make-evaluator 'scheme/base - (make-prog "(define x 1)" - "(define (id x) x)" - "(define (plus1 x) x)" - "(define (loop) (loop))" - "(define (memory x) (make-vector x))"))) + (make-base-evaluator! + (make-prog "(define x 1)" + "(define (id x) x)" + "(define (plus1 x) x)" + "(define (loop) (loop))" + "(define (memory x) (make-vector x))")) (set-eval-limits ev 0.5 5) --eval-- x => 1 @@ -138,29 +146,28 @@ ,eof =err> "terminated .eof.$" ;; other termination messages - --top-- (set! ev (make-evaluator 'scheme/base)) (kill-evaluator ev) + --top-- (make-base-evaluator!) (kill-evaluator ev) --eval-- 123 =err> "terminated .evaluator-killed.$" ;; eval-limits apply to the sandbox creation too --top-- - (set! ev (parameterize ([sandbox-eval-limits '(0.25 5)]) - (make-evaluator 'scheme/base '(sleep 2)))) + (parameterize ([sandbox-eval-limits '(0.25 5)]) + (make-base-evaluator! '(sleep 2))) =err> "out of time" (when (custodian-memory-accounting-available?) (t --top-- - (set! ev (parameterize ([sandbox-eval-limits '(2 2)]) - (make-evaluator 'scheme/base - '(define a (for/list ([i (in-range 10)]) - (collect-garbage) - (make-bytes 500000)))))) + (parameterize ([sandbox-eval-limits '(2 2)]) + (make-base-evaluator! '(define a (for/list ([i (in-range 10)]) + (collect-garbage) + (make-bytes 500000))))) =err> "out of memor(?:y)")) ;; i/o --top-- - (set! ev (parameterize ([sandbox-input "3\n"] - [sandbox-output 'string] - [sandbox-error-output current-output-port]) - (make-evaluator 'scheme/base '(define x 123)))) + (parameterize ([sandbox-input "3\n"] + [sandbox-output 'string] + [sandbox-error-output current-output-port]) + (make-base-evaluator! '(define x 123))) --eval-- (printf "x = ~s\n" x) => (void) --top-- (get-output ev) => "x = 123\n" --eval-- (printf "x = ~s\n" x) => (void) @@ -174,18 +181,17 @@ --top-- (get-output ev) => "a\nb\n" (get-error-output ev) => #f --top-- - (set! ev (parameterize ([sandbox-output 'string] - [sandbox-error-output 'string]) - (make-evaluator 'scheme/base))) + (parameterize ([sandbox-output 'string] [sandbox-error-output 'string]) + (make-base-evaluator!)) --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 'scheme/base '(define x 123)))) + (parameterize ([sandbox-input 'pipe] + [sandbox-output 'bytes] + [sandbox-error-output current-output-port] + [sandbox-eval-limits '(0.25 10)]) + (make-base-evaluator! '(define x 123))) --eval-- (begin (printf "x = ~s\n" x) (fprintf (current-error-port) "err\n")) --top-- (get-output ev) => #"x = 123\nerr\n" @@ -210,8 +216,8 @@ --top-- (let-values ([(i1 o1) (make-pipe)] [(i2 o2) (make-pipe)]) ;; o1 -> i1 -ev-> o2 -> i2 - (set! ev (parameterize ([sandbox-input i1] [sandbox-output o2]) - (make-evaluator 'scheme/base '(define x 123)))) + (parameterize ([sandbox-input i1] [sandbox-output o2]) + (make-base-evaluator! '(define x 123))) (t --eval-- (printf "x = ~s\n" x) => (void) --top-- (read-line i2) => "x = 123" --eval-- (printf "x = ~s\n" x) => (void) @@ -227,48 +233,46 @@ ;; sexprs as a program --top-- - (set! ev (make-evaluator 'scheme/base '(define id (lambda (x) x)))) + (make-base-evaluator! '(define id (lambda (x) x))) --eval-- (id 123) => 123 --top-- - (set! ev (make-evaluator 'scheme/base '(define id (lambda (x) x)) - '(define fooo 999))) + (make-base-evaluator! '(define id (lambda (x) x)) '(define fooo 999)) --eval-- (id fooo) => 999 ;; test source locations too --top-- - (make-evaluator 'scheme/base 0 1 2 '(define foo)) - =err> "program:4:0: define" + (make-base-evaluator! 0 1 2 '(define foo)) + =err> "program:4:0: define" ;; empty program for clean repls --top-- - (set! ev (make-evaluator '(begin))) + (make-evaluator! '(begin)) --eval-- (define x (+ 1 2 3)) => (void) x => 6 (define x (+ x 10)) => (void) x => 16 --top-- - (set! ev (make-evaluator 'scheme/base)) + (make-base-evaluator!) --eval-- (define x (+ 1 2 3)) => (void) x => 6 (define x (+ x 10)) => (void) x => 16 --top-- - (set! ev (make-evaluator 'scheme/base '(define x (+ 1 2 3)))) + (make-base-evaluator! '(define x (+ 1 2 3))) --eval-- (define x (+ x 10)) =err> "cannot re-define a constant" ;; whole program argument --top-- - (set! ev (make-module-evaluator '(module foo scheme/base (define x 1)))) + (make-module-evaluator! '(module foo scheme/base (define x 1))) --eval-- x => 1 --top-- - (set! ev (make-module-evaluator - '(module foo scheme/base (provide x) (define x 1)))) + (make-module-evaluator! '(module foo scheme/base (provide x) (define x 1))) --eval-- x => 1 (define x 2) =err> "cannot re-define a constant" @@ -285,7 +289,7 @@ [test2-lib (strpath tmp "sandbox-test2.ss")] [test2-zo (strpath tmp "compiled" "sandbox-test2_ss.zo")]) (t --top-- - (set! ev (make-evaluator 'scheme/base)) + (make-base-evaluator!) --eval-- ;; reading from collects is allowed (list? (directory-list ,schemelib)) @@ -304,7 +308,7 @@ (lambda () (printf "~s\n" '(module sandbox-test scheme/base (define x 123) (provide x))))) - (set! ev (make-evaluator 'scheme/base #:requires `(,test-lib))) + (make-base-evaluator/reqs! `(,test-lib)) --eval-- x => 123 (length (with-input-from-file ,test-lib read)) => 5 @@ -313,8 +317,8 @@ --top-- ;; should work also for module evaluators ;; --> NO! Shouldn't make user code require whatever it wants - ;; (set! ev (make-evaluator `(module foo scheme/base - ;; (require (file ,test-lib))))) + ;; (make-module-evaluator! + ;; `(module foo scheme/base (require (file ,test-lib)))) ;; --eval-- ;; x => 123 ;; (length (with-input-from-file ,test-lib read)) => 5 @@ -323,11 +327,10 @@ --top-- ;; explicitly allow access to tmp, and write access to a single file (make-directory (build-path tmp "compiled")) - (set! ev (parameterize ([sandbox-path-permissions - `((read ,tmp) - (write ,test-zo) - ,@(sandbox-path-permissions))]) - (make-evaluator 'scheme/base))) + (parameterize ([sandbox-path-permissions + `((read ,tmp) (write ,test-zo) + ,@(sandbox-path-permissions))]) + (make-base-evaluator!)) --eval-- (length (with-input-from-file ,test-lib read)) => 5 (list? (directory-list ,tmp)) @@ -345,11 +348,10 @@ --top-- ;; a more explicit test of bytcode loading, allowing rw access to the ;; complete tmp directory, but read-bytecode only for test2-lib - (set! ev (parameterize ([sandbox-path-permissions - `((write ,tmp) - (read-bytecode ,test2-lib) - ,@(sandbox-path-permissions))]) - (make-evaluator 'scheme/base))) + (parameterize ([sandbox-path-permissions + `((write ,tmp) (read-bytecode ,test2-lib) + ,@(sandbox-path-permissions))]) + (make-base-evaluator!)) --eval-- (define (cp from to) (when (file-exists? to) (delete-file to)) @@ -366,35 +368,35 @@ ;; languages and requires --top-- - (set! ev (make-evaluator '(special r5rs) "(define x (eq? 'x 'X))")) + (make-evaluator! '(special r5rs) "(define x (eq? 'x 'X))") --eval-- x => #t --top-- - (set! ev (make-evaluator 'scheme/base "(define l null)")) + (make-base-evaluator! "(define l null)") --eval-- (cond [null? l 0]) => 0 (last-pair l) =err> "reference to an identifier" --top-- - (set! ev (make-evaluator '(special beginner) - (make-prog "(define l null)" "(define x 3.5)"))) + (make-evaluator! '(special beginner) + (make-prog "(define l null)" "(define x 3.5)")) --eval-- (cond [null? l 0]) =err> "expected an open parenthesis" --top-- (eq? (ev "6") (ev "(sub1 (* 2 3.5))")) (eq? (ev "6") (ev "(sub1 (* 2 x))")) --top-- - (set! ev (make-evaluator 'scheme/base #:requires '(scheme/list))) + (make-base-evaluator/reqs! '(scheme/list)) --eval-- (last-pair '(1 2 3)) => '(3) (last-pair null) =err> "expected argument of type" ;; coverage --top-- - (set! ev (parameterize ([sandbox-coverage-enabled #t]) - (make-evaluator 'scheme/base - (make-prog "(define (foo x) (+ x 1))" - "(define (bar x) (+ x 2))" - "(equal? (foo 3) 4)")))) + (parameterize ([sandbox-coverage-enabled #t]) + (make-base-evaluator! + (make-prog "(define (foo x) (+ x 1))" + "(define (bar x) (+ x 2))" + "(equal? (foo 3) 4)"))) (pair? (get-uncovered-expressions ev)) (pair? (get-uncovered-expressions ev #t)) --eval-- @@ -406,13 +408,13 @@ ;; misc parameters --top-- - (set! ev (parameterize ([sandbox-init-hook - (let ([old (sandbox-init-hook)]) - (lambda () - (old) - (compile-enforce-module-constants #f) - (compile-allow-set!-undefined #t)))]) - (make-evaluator 'scheme/base '(define x 123)))) + (parameterize ([sandbox-init-hook + (let ([old (sandbox-init-hook)]) + (lambda () + (old) + (compile-enforce-module-constants #f) + (compile-allow-set!-undefined #t)))]) + (make-base-evaluator! '(define x 123))) --eval-- (set! x 456) ; would be an error without the `enforce' parameter x => 456 @@ -421,11 +423,11 @@ ;; test that output is also collected under the limit --top-- - (set! ev (parameterize ([sandbox-output 'bytes] - [sandbox-error-output current-output-port] - [sandbox-memory-limit 2] - [sandbox-eval-limits '(0.25 1)]) - (make-evaluator 'scheme/base))) + (parameterize ([sandbox-output 'bytes] + [sandbox-error-output current-output-port] + [sandbox-memory-limit 2] + [sandbox-eval-limits '(0.25 1)]) + (make-base-evaluator!)) ;; GCing is needed to allow these to happen (note: the memory limit is very ;; tight here, this test usually fails if the sandbox library is not ;; compiled) @@ -440,26 +442,25 @@ ;; thread/custodian) --top-- (let () - (define (make!) (set! ev (make-evaluator 'scheme/base))) (define (3x2-terminations) - (t --top-- (make!) --eval-- + (t --top-- (make-base-evaluator!) --eval-- (kill-thread (current-thread)) =err> "terminated .thread-killed.$" - --top-- (make!) --eval-- + --top-- (make-base-evaluator!) --eval-- (custodian-shutdown-all (current-custodian)) =err> "terminated .custodian-shutdown.$" - --top-- (make!) --eval-- + --top-- (make-base-evaluator!) --eval-- (exit) =err> "terminated .exited.$" ;; now test that it's fine when called directly --top-- - (make!) + (make-base-evaluator!) (call-in-sandbox-context ev (lambda () (kill-thread (current-thread)))) =err> "terminated .thread-killed.$" - (make!) + (make-base-evaluator!) (call-in-sandbox-context ev (lambda () (custodian-shutdown-all (current-custodian)))) =err> "terminated .custodian-shutdown.$" - (make!) + (make-base-evaluator!) (call-in-sandbox-context ev exit) =err> "terminated .exited.$")) (define (test-terminations) ;; try without, then with per-expression limits @@ -471,9 +472,9 @@ --top-- (when (custodian-memory-accounting-available?) (t --top-- - (set! ev (parameterize ([sandbox-eval-limits '(2 5)] - [sandbox-memory-limit 100]) - (make-evaluator 'scheme/base))) + (parameterize ([sandbox-eval-limits '(2 5)] + [sandbox-memory-limit 100]) + (make-base-evaluator!)) --eval-- (define a '()) (define b 1)