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

change sandbox to allow read from the planet directory; delay some path calculations in other libraries to avoid sandbox prohibitions (but the ones in Scribble seem like too much)

Browse Source 
svn: r16122
This commit is contained in:
Matthew Flatt 2009-09-24 14:54:15 +00:00
parent 26f99d3fa4
commit eab6803895
11 changed files with 67 additions and 48 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
collects/dynext/compile-unit.ss
View File

@ -286,7 +286,7 @@
(lambda (s)
((current-make-compile-include-strings) s))
includes))
((current-make-compile-include-strings) include-dir)
((current-make-compile-include-strings) (include-dir))
((current-make-compile-input-strings) in)
((current-make-compile-output-strings) out))])
(unless quiet?

14
collects/dynext/link-unit.ss
View File

@ -135,9 +135,9 @@
"-brtl"
(lambda ()
(map (lambda (mz-exp)
(format "-bI:~a/~a" include-dir mz-exp))
(format "-bI:~a/~a" (include-dir) mz-exp))
((wrap-3m "mzscheme~a.exp"))))
(format "-bE:~a/ext.exp" include-dir)
(format "-bE:~a/ext.exp" (include-dir))
"-bnoentry")]
[(parisc-hpux) (list "-b")]
[(ppc-macosx ppc-darwin x86_64-macosx x86_86-darwin) mac-link-flags]
@ -186,7 +186,7 @@
"," "," "c0d32.obj" "cw32.lib" "import32.lib"
(if (current-use-mzdyn)
(list "," (path->string
(build-path std-library-dir
(build-path (std-library-dir)
"bcc"
"mzdynb.def")))
null))))
@ -212,7 +212,7 @@
(define (make-win-link-libraries win-gcc? win-borland? unix?)
(let* ([file (lambda (f)
(path->string
(build-path std-library-dir
(build-path (std-library-dir)
(cond
[win-gcc? "gcc"]
[win-borland? "bcc"]
@ -220,7 +220,7 @@
f)))]
[dllfile (lambda (f)
(path->string
(build-path std-library-dir f)))]
(build-path (std-library-dir) f)))]
[filethunk (lambda (f)
(lambda ()
(map file (f))))]
@ -263,7 +263,7 @@
(list (lambda ()
(if (current-use-mzdyn)
(map (lambda (mz.o)
(path->string (build-path std-library-dir mz.o)))
(path->string (build-path (std-library-dir) mz.o)))
((wrap-3m "mzdyn~a.o")))
null)))]))
@ -369,7 +369,7 @@
;; Generate DLL link information
`("--dllname" ,(if (path? out) (path->string out) out)
,@(if (current-use-mzdyn)
`("--def" ,(path->string (build-path std-library-dir "gcc" "mzdyn.def")))
`("--def" ,(path->string (build-path (std-library-dir) "gcc" "mzdyn.def")))
`())
"--base-file" ,basefile
"--output-exp" ,(path->string expfile))]

4
collects/dynext/private/dirs.ss
View File

@ -2,7 +2,7 @@
(module dirs mzscheme
(require setup/dirs)
(define include-dir (find-include-dir))
(define std-library-dir (find-lib-dir))
(define include-dir find-include-dir)
(define std-library-dir find-lib-dir)
(provide include-dir std-library-dir))

4
collects/scheme/sandbox.ss
View File

@ -4,7 +4,8 @@
scheme/list
scheme/string
syntax/moddep
scheme/gui/dynamic)
scheme/gui/dynamic
planet/config)
(provide gui?
sandbox-init-hook
@ -843,6 +844,7 @@
[sandbox-path-permissions
`(,@(map (lambda (p) `(read-bytecode ,p))
(current-library-collection-paths))
(read-bytecode ,(PLANET-BASE-DIR))
(exists ,(find-system-path 'addon-dir))
,@(compute-permissions allow)
,@(sandbox-path-permissions))]

3
collects/scribble/private/manual-bib.ss
View File

@ -3,6 +3,7 @@
"../decode.ss"
"../struct.ss"
"../basic.ss"
"on-demand.ss"
(only-in "../core.ss" make-style)
"manual-sprop.ss"
"manual-utils.ss"
@ -64,7 +65,7 @@
(if date `(" " ,@(decode-content (list date)) ".") null)
(if url `(" " ,(link url (tt url))) null)))))
(define bib-style (make-style "SBibliography" scheme-properties))
(define-on-demand bib-style (make-style "SBibliography" scheme-properties))
(define (bibliography #:tag [tag "doc-bibliography"] . citations)
(make-unnumbered-part

5
collects/scribble/private/manual-proc.ss
View File

@ -13,6 +13,7 @@
"manual-bind.ss"
"manual-method.ss"
"manual-ex.ss"
"on-demand.ss"
scheme/string
scheme/list
(for-syntax scheme/base)
@ -26,9 +27,9 @@
;; private:
*defthing) ; XXX unknown contract
(define dots0
(define-on-demand dots0
(make-element meta-color (list "...")))
(define dots1
(define-on-demand dots1
(make-element meta-color (list "...+")))
(define (make-openers n)

6
collects/scribble/private/manual-sprop.ss
View File

@ -2,11 +2,13 @@
(require "../html-properties.ss"
"../latex-properties.ss"
setup/main-collects)
"on-demand.ss"
setup/main-collects
scheme/promise)
(provide scheme-properties)
(define scheme-properties
(define-on-demand scheme-properties
(let ([abs (lambda (s)
(path->main-collects-relative (build-path (collection-path "scribble") s)))])
(list (make-css-addition (abs "scheme.css"))

9
collects/scribble/private/manual-style.ss
View File

@ -6,6 +6,7 @@
"../scheme.ss"
(only-in "../core.ss" make-style plain)
"manual-utils.ss"
"on-demand.ss"
scheme/list
scheme/contract
scheme/string)
@ -28,10 +29,10 @@
onscreen defterm filepath exec envvar Flag DFlag PFlag DPFlag math
procedure
indexed-file indexed-envvar idefterm pidefterm)
(provide void-const
undefined-const)
(provide/contract
[PLaneT element?]
[void-const element?]
[undefined-const element?]
[hash-lang (-> element?)]
[etc string?]
[inset-flow (() () #:rest (listof pre-content?) . ->* . any/c)] ; XXX no docs and bad return contract
@ -152,9 +153,9 @@
(list (schememodfont "#lang"))
`(part ,(doc-prefix '(lib "scribblings/guide/guide.scrbl") "hash-lang"))))
(define void-const
(define-on-demand void-const
(schemeresultfont "#<void>"))
(define undefined-const
(define-on-demand undefined-const
(schemeresultfont "#<undefined>"))
(define (link url

10
collects/scribble/private/on-demand.ss Normal file
View File

@ -0,0 +1,10 @@
#lang scheme
(provide define-on-demand)
(define-syntax-rule (define-on-demand id rhs)
(begin
(define val (delay rhs))
(define-syntax (id stx)
(if (identifier? stx)
#'(force val)
(raise-syntax-error #f "bad syntax" stx)))))

43
collects/scribble/scheme.ss
View File

@ -3,6 +3,7 @@
"basic.ss"
"search.ss"
"private/manual-sprop.ss"
"private/on-demand.ss"
mzlib/class
mzlib/for
syntax/modresolve
@ -57,27 +58,27 @@
(cons 'tt-chars scheme-properties)
scheme-properties)))
(define output-color (make-scheme-style "ScmOut"))
(define input-color (make-scheme-style "ScmIn"))
(define input-background-color (make-scheme-style "ScmInBG"))
(define no-color (make-scheme-style "ScmPlain"))
(define reader-color (make-scheme-style "ScmRdr"))
(define result-color (make-scheme-style "ScmRes"))
(define keyword-color (make-scheme-style "ScmKw"))
(define comment-color (make-scheme-style "ScmCmt"))
(define paren-color (make-scheme-style "ScmPn"))
(define meta-color (make-scheme-style "ScmMeta"))
(define value-color (make-scheme-style "ScmVal"))
(define symbol-color (make-scheme-style "ScmSym"))
(define variable-color (make-scheme-style "ScmVar"))
(define opt-color (make-scheme-style "ScmOpt"))
(define error-color (make-scheme-style "ScmErr" #:tt? #f))
(define syntax-link-color (make-scheme-style "ScmStxLink"))
(define value-link-color (make-scheme-style "ScmValLink"))
(define module-color (make-scheme-style "ScmMod"))
(define module-link-color (make-scheme-style "ScmModLink"))
(define block-color (make-scheme-style "ScmBlk"))
(define highlighted-color (make-scheme-style "highlighted" #:tt? #f))
(define-on-demand output-color (make-scheme-style "ScmOut"))
(define-on-demand input-color (make-scheme-style "ScmIn"))
(define-on-demand input-background-color (make-scheme-style "ScmInBG"))
(define-on-demand no-color (make-scheme-style "ScmPlain"))
(define-on-demand reader-color (make-scheme-style "ScmRdr"))
(define-on-demand result-color (make-scheme-style "ScmRes"))
(define-on-demand keyword-color (make-scheme-style "ScmKw"))
(define-on-demand comment-color (make-scheme-style "ScmCmt"))
(define-on-demand paren-color (make-scheme-style "ScmPn"))
(define-on-demand meta-color (make-scheme-style "ScmMeta"))
(define-on-demand value-color (make-scheme-style "ScmVal"))
(define-on-demand symbol-color (make-scheme-style "ScmSym"))
(define-on-demand variable-color (make-scheme-style "ScmVar"))
(define-on-demand opt-color (make-scheme-style "ScmOpt"))
(define-on-demand error-color (make-scheme-style "ScmErr" #:tt? #f))
(define-on-demand syntax-link-color (make-scheme-style "ScmStxLink"))
(define-on-demand value-link-color (make-scheme-style "ScmValLink"))
(define-on-demand module-color (make-scheme-style "ScmMod"))
(define-on-demand module-link-color (make-scheme-style "ScmModLink"))
(define-on-demand block-color (make-scheme-style "ScmBlk"))
(define-on-demand highlighted-color (make-scheme-style "highlighted" #:tt? #f))
(define current-keyword-list
(make-parameter null))

15
collects/setup/private/omitted-paths.ss
View File

@ -9,7 +9,7 @@
(provide omitted-paths)
(require scheme/path scheme/list "../dirs.ss" "lib-roots.ss")
(require scheme/path scheme/list scheme/promise "../dirs.ss" "lib-roots.ss")
;; An entry for each collections root that holds a hash table. The hash table
;; maps a reversed list of subpath elements to the exploded omitted-paths
@ -19,11 +19,12 @@
;; main collection tree (it is not used there for documentation, and there is
;; at least one place where it contains code: scribble/doc).
(define roots
(map (lambda (p)
(list (explode-path (car p)) (make-hash)
;; don't omit "doc" in the main tree
(not (equal? (find-collects-dir) (car p)))))
library-roots))
(delay
(map (lambda (p)
(list (explode-path (car p)) (make-hash)
;; don't omit "doc" in the main tree
(not (equal? (find-collects-dir) (car p)))))
library-roots)))
;; if `x' has `y' as a prefix, return the tail,
;; eg (relative-from '(1 2 3 4) '(1 2)) => '(3 4)
@ -89,7 +90,7 @@
[r (ormap (lambda (root+table)
(let ([r (relative-from dir* (car root+table))])
(and r (cons (reverse r) root+table))))
roots)]
(force roots))]
[r (and r (apply accumulate-omitted get-info/full r))])
(unless r
(error 'omitted-paths