suzanne.soy/racket
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

adjust scribble's in-drracket html generator button to use the sandbox so user code cannot corrupt drracket.

Browse Source 
related to PR 11601
This commit is contained in:
Robby Findler 2011-01-08 16:37:58 -06:00
parent da9c34cd52
commit 49952e580b
1 changed files with 53 additions and 29 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

82
collects/scribble/tools/drracket-buttons.rkt
View File

@ -1,12 +1,13 @@
#lang scheme/base
#lang racket/base
(require scheme/runtime-path
scheme/gui/base
scheme/class
(require racket/runtime-path
racket/gui/base
racket/class
mrlib/bitmap-label
scheme/system
racket/system
setup/xref
net/sendurl)
net/sendurl
racket/sandbox)
(provide drracket-buttons)
@ -17,6 +18,8 @@
(define-namespace-anchor anchor)
(define original-error-display-handler (error-display-handler))
(define (make-render-button label bmp mode suffix extra-cmdline)
(list
label
@ -25,30 +28,51 @@
(let* ([t (send drs-frame get-definitions-text)]
[fn (send t get-filename)])
(if fn
(begin
(let ()
(send t save-file fn)
(let-values ([(p) (open-output-string)]
[(base name dir?) (split-path fn)])
(parameterize ([current-namespace (make-base-namespace)]
[current-output-port p]
[current-error-port p]
[current-directory base]
[current-command-line-arguments
(list->vector
(append
extra-cmdline
(list "--quiet")
(list mode (if (path? fn) (path->string fn) fn))))])
(namespace-attach-module (namespace-anchor->empty-namespace anchor) 'setup/xref)
(dynamic-require 'scribble/run #f)
(cond
[(equal? suffix #".html")
(send-url/file (path-replace-suffix fn suffix))]
[else
(system (format "open ~s" (path->string (path-replace-suffix fn suffix))))]))
(let ([s (get-output-string p)])
(unless (equal? s "")
(message-box "Scribble" s drs-frame)))))
(define p (open-output-string))
(define-values (base name dir?) (split-path fn))
(define sb
(parameterize ([sandbox-security-guard (current-security-guard)])
(make-evaluator 'racket/base)))
(define result
(call-in-sandbox-context
sb
(λ ()
(with-handlers (((λ (x) #t) (λ (e) (list 'exn e))))
(parameterize ([current-output-port p]
[current-error-port p]
[current-directory base]
[error-display-handler original-error-display-handler]
[current-command-line-arguments
(list->vector
(append
extra-cmdline
(list "--quiet")
(list mode (if (path? fn) (path->string fn) fn))))])
(namespace-attach-module (namespace-anchor->empty-namespace anchor) 'setup/xref)
(dynamic-require 'scribble/run #f)
(list 'normal))))))
(cond
[(eq? (list-ref result 0) 'exn)
(define exn (list-ref result 1))
(define sp (open-output-string))
(cond
[(exn? exn)
(fprintf sp "~a\n" (exn-message exn))
(for ([x (in-list (continuation-mark-set->context (exn-continuation-marks exn)))])
(fprintf sp " ~s\n" x))]
[else
(fprintf sp "uncaught exn: ~s\n" exn)])
(message-box "Scribble HTML - DrRacket"
(get-output-string sp))]
[(equal? suffix #".html")
(send-url/file (path-replace-suffix fn suffix))]
[else
(system (format "open ~s" (path->string (path-replace-suffix fn suffix))))])
(let ([s (get-output-string p)])
(unless (equal? s "")
(message-box "Scribble" s drs-frame))))
(message-box "Scribble" "Cannot render buffer without filename"))))))
(define drracket-buttons