diff --git a/collects/planet/lang/reader.ss b/collects/planet/lang/reader.ss index 55d64755a1..cab963a3a0 100644 --- a/collects/planet/lang/reader.ss +++ b/collects/planet/lang/reader.ss @@ -1,39 +1,42 @@ #lang scheme/base -(require "../parsereq.ss") +(require "../parsereq.ss" + syntax/readerr) (provide (rename-out [planet-read read] [planet-read-syntax read-syntax])) -(define (planet-read-fn in spec->read-data) - (let* ([spec (read-line in)] - [parsed-spec - (with-handlers ([exn:parse-failure? (λ (e) (raise-syntax-error 'read "bad syntax"))]) - (parse-package-string spec))]) - (values - `(planet "lang/main.ss" ,parsed-spec) - (spec->read-data `(planet "lang/reader.ss" ,parsed-spec))))) +(define (planet-read-fn in read-sym args src mod line col pos) + (let ([spec (regexp-try-match #px"^(.*?)(\\s|$)" in)] + [bad (lambda (str eof?) + ((if eof? + raise-read-eof-error + raise-read-error) + (format "bad planet path following language-loder syntax~a~a" + (if str ": " "") + (or str "")) + src line col pos + (let-values ([(line col pos2) (port-next-location in)]) + (and pos pos2 (- pos2 pos)))))]) + (if (or (not spec) + (equal? (cadr spec) "")) + (bad #f (eof-object? (peek-byte in))) + (let ([parsed-spec + (let ([str (bytes->string/latin-1 (cadr spec))]) + (if (module-path? `(planet ,(string->symbol str))) + `(planet ,(string->symbol (string-append str "/lang/reader"))) + #f))]) + (if parsed-spec + (let ([r (dynamic-require parsed-spec read-sym)]) + (if (and (procedure? r) + (procedure-arity-includes? r (+ 5 (length args)))) + (apply r (append args + (list in mod line col pos))) + (apply r (append args (list in))))) + (bad (cadr spec) #f)))))) -(define (wrap port spec read) - (let* ([body - (let loop ([a null]) - (let ([v (read port)]) - (if (eof-object? v) - (reverse a) - (loop (cons v a)))))] - [p-name (object-name port)] - [name (if (path? p-name) - (let-values ([(base name dir?) (split-path p-name)]) - (string->symbol (path->string (path-replace-suffix name #"")))) - 'page)]) - `(module ,name ,spec - . ,body))) - -(define (planet-read [inp (current-input-port)]) - (define-values (spec r) (planet-read-fn inp (λ (spec) (dynamic-require spec 'read)))) - (wrap inp spec r)) - -(define (planet-read-syntax [src #f] [inp (current-input-port)]) - (define-values (spec r) (planet-read-fn inp (λ (spec) (dynamic-require spec 'read-syntax)))) - (wrap inp spec (lambda (p) (r src p)))) +(define (planet-read inp mod line col pos) + (planet-read-fn inp 'read null (object-name inp) mod line col pos)) +(define (planet-read-syntax src inp mod line col pos) + (planet-read-fn inp 'read-syntax (list src) src mod line col pos)) diff --git a/collects/scheme/sandbox.ss b/collects/scheme/sandbox.ss index c5a60462aa..41d0bbd826 100644 --- a/collects/scheme/sandbox.ss +++ b/collects/scheme/sandbox.ss @@ -18,6 +18,7 @@ sandbox-path-permissions sandbox-network-guard sandbox-make-inspector + sandbox-make-logger sandbox-eval-limits kill-evaluator break-evaluator @@ -133,6 +134,8 @@ (define sandbox-make-inspector (make-parameter make-inspector)) +(define sandbox-make-logger (make-parameter current-logger)) + ;; computes permissions that are needed for require specs (`read' for all ;; files and "compiled" subdirs, `exists' for the base-dir) (define (module-specs->path-permissions mods) @@ -586,6 +589,7 @@ [current-security-guard (sandbox-security-guard)] [exit-handler (lambda x (error 'exit "user code cannot exit"))] [current-inspector ((sandbox-make-inspector))] + [current-logger ((sandbox-make-logger))] ;; This breaks because we need to load some libraries that are trusted ;; [current-code-inspector (make-inspector)] ;; Note the above definition of `current-eventspace': in MzScheme, it diff --git a/collects/scribblings/reference/sandbox.scrbl b/collects/scribblings/reference/sandbox.scrbl index 51528080eb..6f68da8911 100644 --- a/collects/scribblings/reference/sandbox.scrbl +++ b/collects/scribblings/reference/sandbox.scrbl @@ -451,6 +451,12 @@ A parameter that determines the procedure used to create the inspector for sandboxed evaluation. The procedure is called when initializing an evaluator, and the default parameter value is @scheme[make-inspector].} +@defparam[sandbox-make-logger make (-> logger?)]{ + +A parameter that determines the procedure used to create the logger +for sandboxed evaluation. The procedure is called when initializing an +evaluator, and the default parameter value is @scheme[current-logger].} + @; ---------------------------------------------------------------------- @section{Interacting with Evaluators}