* Added `call-in-sandbox-context'.

* Removed `get-namespace' since it's generalized in the above.
* Deal with killing the current thread (or the current custodian) in
  the sandbox code.  (Works only without per-expression limits --
  still need to find a solution for `call-with-limits'.)
* Added tests for this.

svn: r12670

collects/scheme/sandbox.ss

@@ -29,7 +29,7 @@
          get-output
          get-error-output
          get-uncovered-expressions
-         get-namespace
+         call-in-sandbox-context
          make-evaluator
          make-module-evaluator
          call-with-limits
@@ -241,16 +241,16 @@
            (set! r
                  (with-handlers ([void (lambda (e) (list (p) raise e))])
                    (call-with-values thunk (lambda vs (list* (p) values vs)))))
-           (when timer (kill-thread timer)))))
+           (when timer (kill-thread timer))))))
-      (custodian-shutdown-all c)
+    (custodian-shutdown-all c)
-      (unless r (error 'call-with-limits "internal error"))
+    (unless r (error 'call-with-limits "internal error"))
-      ;; apply parameter changes first
+    ;; apply parameter changes first
-      (when (car r) (p (car r)))
+    (when (car r) (p (car r)))
-      (if (pair? (cdr r))
+    (if (pair? (cdr r))
-          (apply (cadr r) (cddr r))
+      (apply (cadr r) (cddr r))
-          (raise (make-exn:fail:resource (format "with-limit: out of ~a" (cdr r))
+      (raise (make-exn:fail:resource (format "with-limit: out of ~a" (cdr r))
-                                         (current-continuation-marks)
+                                     (current-continuation-marks)
-                                         (cdr r)))))))
+                                     (cdr r))))))
 
 (define-syntax with-limits
   (syntax-rules ()
@@ -438,7 +438,7 @@
 (define-evaluator-messenger get-output 'output)
 (define-evaluator-messenger get-error-output 'error-output)
 (define-evaluator-messenger (get-uncovered-expressions . xs) 'uncovered)
-(define-evaluator-messenger get-namespace 'namespace)
+(define-evaluator-messenger (call-in-sandbox-context thunk) 'thunk)
 
 (define (make-evaluator* init-hook require-perms program-maker)
   (define user-cust     (make-custodian))
@@ -451,6 +451,7 @@
   (define error-output  #f)
   (define limits        (sandbox-eval-limits))
   (define user-thread   #t) ; set later to the thread
+  (define user-done-evt #t) ; set in the same place
   (define orig-cust     (current-custodian))
   (define (limit-thunk thunk)
     (let* ([sec (and limits (car limits))]
@@ -503,7 +504,7 @@
                                          (lambda (e)
                                            (user-break)
                                            (loop))])
-                          (channel-get result-ch))))
+                          (sync user-done-evt result-ch))))
                eof)])
       (cond [(eof-object? r) (error 'evaluator "terminated")]
             [(eq? (car r) 'exn) (raise (cdr r))]
@@ -541,8 +542,8 @@
           [(output) (output-getter output)]
           [(error-output) (output-getter error-output)]
           [(uncovered) (apply get-uncovered (evaluator-message-args expr))]
-          [(namespace) (user-eval (make-evaluator-message
+          [(thunk)  (user-eval (make-evaluator-message
-                                   current-namespace '()))]
+                                (car (evaluator-message-args expr)) '()))]
           [else (error 'evaluator "internal error, bad message: ~e" msg)]))
       (user-eval expr)))
   (define linked-outputs? #f)
@@ -613,6 +614,7 @@
     ;; it will not use the new namespace.
     [current-eventspace (make-eventspace)])
    (set! user-thread (bg-run->thread (run-in-bg user-process)))
+   (set! user-done-evt (handle-evt user-thread (lambda (_) (user-kill) eof)))
    (let ([r (channel-get result-ch)])
      (if (eq? r 'ok)
          ;; initial program executed ok, so return an evaluator

collects/scribblings/reference/sandbox.scrbl

@@ -623,10 +623,18 @@ the @scheme[src] argument.  Using a sequence of S-expressions (not
 coverage results, since each expression may be assigned a single
 source location.}
 
-@defproc[(get-namespace [evaluator (any/c . -> . any)])
+@defproc[(call-in-sandbox-context [evaluator (any/c . -> . any)]
-         namespace?]{
+                                  [thunk (-> any)])
+         any]{
 
-Retrieves the namespace that is used in an evaluator.}
+Calls the given @scheme[thunk] in the context of a sandboxed
+evaluator.  The call is performed under the resource limits that are
+used for evaluating expressions.
+
+This is usually similar to @scheme[(evaluator (list thunk))], except
+that this relies on the common meaning of list expressions as function
+application (which is not true in all languages), and it relies on
+MzScheme's @scheme[eval] forgiving a non-S-expression input.}
 
 @; ----------------------------------------------------------------------
 

collects/tests/mzscheme/sandbox.ss

@@ -363,6 +363,30 @@
    ;;             (for ([i (in-range 100)]) (display 400k)))
    ;;           =err> "out of memory"
 
+   ;; test that killing the custodian works fine
+   ;; first try it without limits (which imply a nester thread/custodian)
+   --top--
+   (set! ev (parameterize ([sandbox-eval-limits #f])
+              (make-evaluator 'scheme/base)))
+   --eval--
+   (kill-thread (current-thread)) =err> "terminated"
+   --top--
+   (set! ev (parameterize ([sandbox-eval-limits #f])
+              (make-evaluator 'scheme/base)))
+   --eval--
+   (custodian-shutdown-all (current-custodian)) =err> "terminated"
+   --top--
+   ;; also happens when it's done directly
+   (set! ev (parameterize ([sandbox-eval-limits #f])
+              (make-evaluator 'scheme/base)))
+   (call-in-sandbox-context ev (lambda () (kill-thread (current-thread))))
+   =err> "terminated"
+   (set! ev (parameterize ([sandbox-eval-limits #f])
+              (make-evaluator 'scheme/base)))
+   (call-in-sandbox-context ev
+     (lambda () (custodian-shutdown-all (current-custodian))))
+   =err> "terminated"
+
    ))
 
 (report-errs)