From 85899c7236dabf5bce566a50025c5e4f8cdb8d7b Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Wed, 10 Jul 2013 08:34:28 -0600 Subject: [PATCH] ".plt" unpacking: require literal S-expression pattern A literal S-expression is required instead of an S-expression that is evaluated. Any ".plt" file created in the normal way will still work. --- .../racket-doc/scribblings/raco/plt.scrbl | 126 ++++++++---------- .../racket-test/tests/racket/pack.rktl | 12 +- racket/lib/collects/racket/HISTORY.txt | 2 + racket/lib/collects/setup/unpack.rkt | 59 +++++--- 4 files changed, 106 insertions(+), 93 deletions(-) diff --git a/pkgs/racket-pkgs/racket-doc/scribblings/raco/plt.scrbl b/pkgs/racket-pkgs/racket-doc/scribblings/raco/plt.scrbl index b8f6ee57f8..20b62e9509 100644 --- a/pkgs/racket-pkgs/racket-doc/scribblings/raco/plt.scrbl +++ b/pkgs/racket-pkgs/racket-doc/scribblings/raco/plt.scrbl @@ -2,7 +2,8 @@ @(require scribble/manual "common.rkt" (for-label racket/base - setup/pack)) + setup/pack + racket/contract/base)) @title[#:tag "plt"]{@exec{raco pack}: Packing Library Collections} @@ -165,105 +166,90 @@ The raw format is @litchar{PLT} are the first three characters.} @item{ - A procedure that takes a symbol and a failure thunk and returns - information about archive for recognized symbols and calls the - failure thunk for unrecognized symbols. The information symbols - are: + An S-expression matching + + @racketblock[ + (lambda (request failure) + (case request + [(name) _name] + [(unpacker) (@#,racket[quote] mzscheme)] + [(requires) (@#,racket[quote] _requires)] + [(conflicts) (@#,racket[quote] _conflicts)] + [(plt-relative?) _plt-relative?] + [(plt-home-relative?) _plt-home-relative?] + [(test-plt-dirs) _test-dirs] + [else (failure)])) + ] + + where the @racket[_name], @racket[_requires], @|etc|, meta-variables + stand for S-expressions as follows: @itemize[ @item{ - @racket['name] --- a human-readable string describing the archive's + @racket[_name] --- a human-readable string describing the archive's contents. This name is used only for printing messages to the user during unpacking.} @item{ - @racket['unpacker] --- a symbol indicating the expected unpacking - environment. Currently, the only allowed value is @racket['mzscheme].} - - @item{ - @racket['requires] --- collections required to be installed before + @racket[_requires] --- a list of collections required to be installed before unpacking the archive, which associated versions; see the documentation of @racket[pack] for details.} @item{ - @racket['conflicts] --- collections required @emph{not} to be installed + @racket[_conflicts] --- a list of collections required @emph{not} to be installed before unpacking the archive.} @item{ - @racket['plt-relative?] --- a boolean; if true, then the archive's + @racket[_plt-relative?] --- a boolean; if true, then the archive's content should be unpacked relative to the plt add-ons directory.} @item{ - @racket['plt-home-relative?] --- a boolean; if true and if + @racket[_plt-home-relative?] --- a boolean; if true and if @racket['plt-relative?] is true, then the archive's content should be unpacked relative to the Racket installation.} @item{ - @racket['test-plt-dirs] --- @racket[#f] or a list of path strings; - in the latter case, a true value of @racket['plt-home-relative?] is + @racket[_test-plt-dirs] --- @racket[#f] or a @racket['_paths] where + @racket[_paths] is a list of path strings; + in the latter case, a true value of @racket[_plt-home-relative?] is cancelled if any of the directories in the list (relative to the Racket installation) is unwritable by the user.} ] - The procedure is extracted from the archive using the @racket[read] - and @racket[eval] procedures in a fresh namespace. } + The S-expression is extracted from the archive + using @racket[read] (and the result is @emph{not} + @racket[eval]uated).} @item{ - An old-style, unsigned unit using @racket[(lib mzlib/unit200)] that - drives the unpacking process. The unit accepts two imports: a path - string for the parent of the main @filepath{collects} directory and - an @racket[unmztar] procedure. The remainder of the unpacking - process consists of invoking this unit. It is expected that the - unit will call @racket[unmztar] procedure to unpack directories and - files that are defined in the input archive after this unit. The - result of invoking the unit must be a list of collection paths - (where each collection path is a list of strings); once the archive - is unpacked, @exec{raco setup} will compile and setup the specified - collections. + An S-expression matching - The @racket[unmztar] procedure takes one argument: a filter - procedure. The filter procedure is called for each directory and - file to be unpacked. It is called with three arguments: + @racketblock[ + (unit (import main-collects-parent-dir mzuntar) + (export) + (mzuntar void) + (@#,racket[quote] _collections)) + ] - @itemize[ - @item{ - @racket['dir], @racket['file], @racket['file-replace] - --- indicates whether the item to be - unpacked is a directory, a file, or a file to be replaced, } + where @racket[_collections] is a list of collection paths + (where each collection path is a list of strings); once the archive + is unpacked, @exec{raco setup} will compile and setup the specified + collections. - @item{ - a relative path string --- the pathname of the directory or file - to be unpacked, relative to the unpack directory, and} + The S-expression is extracted from the archive + using @racket[read] (and the result is @emph{not} + @racket[eval]uated).} - @item{ - a path string for the unpack directory (which can vary for a - Racket-relative install when elements of the archive start with - @racket["collects"], @racket["lib"], etc.).} - ] - - If the filter procedure returns @racket[#f] for a directory or file, the - directory or file is not unpacked. If the filter procedure returns - @racket[#t] and the directory or file for @racket['dir] or @racket['file] - already exists, it is not created. (The file for @racket[file-replace] - need not exist already.) +] - When a directory is unpacked, intermediate directories are created - as necessary to create the specified directory. When a file is - unpacked, the directory must already exist. - - The unit is extracted from the archive using @racket[read] and - @racket[eval].} ] - -Assuming that the unpacking unit calls the @racket[unmztar] procedure, the -archive should continue with @tech{unpackables}. @tech{Unpackables} are -extracted until the end-of-file is found (as indicated by an @litchar{=} -in the base64-encoded input archive). +The archive continues with @tech{unpackables}. @tech{Unpackables} are +extracted until the end-of-file is found (as indicated by an +@litchar{=} in the base64-encoded input archive). An @deftech{unpackable} is one of the following: @itemize[ @item{ - The symbol @racket['dir] followed by a list. The @racket[build-path] + The symbol @racket['dir] followed by a list S-expression. The @racket[build-path] procedure will be applied to the list to obtain a relative path for the directory (and the relative path is combined with the target directory path to get a complete path). @@ -358,7 +344,7 @@ making @filepath{.plt} archives.} (path-string? . -> . boolean?) std-filter] [#:encode? encode? boolean? #t] [#:file-mode file-mode-sym symbol? 'file] - [#:unpack-unit unit200-expr any/c #f] + [#:unpack-unit unpack-spec any/c #f] [#:collections collection-list (listof path-string?) null] [#:plt-relative? plt-relative? any/c #f] [#:at-plt-home? at-plt-home? any/c #f] @@ -395,11 +381,11 @@ making @filepath{.plt} archives.} archive. The default is @racket['file]. The @racket[#:unpack-unit] argument is usually - @racket[#f]. Otherwise, it must be an S-expression for a - @racket[mzlib/unit200]-style unit that performs the work of - unpacking; see @secref["format-of-.plt-archives"] more information - about the unit. If the @racket[#:unpack-unit] argument is - @racket[#f], an appropriate unpacking unit is generated. + @racket[#f]. Otherwise, it must be an S-expression for the + S-expression that describes unpacking; see + @secref["format-of-.plt-archives"] more information about the + unit. If the @racket[#:unpack-unit] argument is @racket[#f], an + appropriate S-expression is generated. The @racket[#:collections] argument is a list of collection paths to be compiled after the archive is unpacked. The default is the @racket[null]. @@ -454,7 +440,7 @@ making @filepath{.plt} archives.} [filter (path-string? . -> . boolean?) std-filter] [encode? boolean? #t] [file-mode symbol? 'file] - [unpack-unit boolean? #f] + [unpack-unit any/c #f] [plt-relative? boolean? #t] [requires (listof (listof path-string?) (listof exact-integer?)) null] diff --git a/pkgs/racket-pkgs/racket-test/tests/racket/pack.rktl b/pkgs/racket-pkgs/racket-test/tests/racket/pack.rktl index a32c8cdad1..1a405f611d 100644 --- a/pkgs/racket-pkgs/racket-test/tests/racket/pack.rktl +++ b/pkgs/racket-pkgs/racket-test/tests/racket/pack.rktl @@ -14,7 +14,7 @@ ;; Test via mzc interface -(define mzc (build-path (find-console-bin-dir) "mzc")) +(define raco (build-path (find-console-bin-dir) "raco")) (define (make-x-plt-str mod) (path->string (build-path (find-system-path 'temp-dir) (format "x~a.plt" mod)))) @@ -38,12 +38,12 @@ (lambda () (printf "BANANA\n"))) (parameterize ([current-directory (find-system-path 'temp-dir)]) - (system* mzc "--plt" x-plt-str "packed") - (system* mzc "--plt" x-replace-plt-str "--replace" "packed") + (system* raco "pack" x-plt-str "packed") + (system* raco "pack" "--replace" x-replace-plt-str "packed") (make-directory "collects") (rename-file-or-directory "packed" "collects/packed") - (system* mzc "--plt" x-user-collect-plt-str "--at-plt" "collects") - (system* mzc "--plt" x-collect-plt-str "--at-plt" "--all-users" "collects") + (system* raco "pack" "--at-plt" x-user-collect-plt-str "collects") + (system* raco "pack" "--at-plt" "--all-users" x-collect-plt-str "collects") (rename-file-or-directory "collects/packed" "packed") (delete-directory "collects")) @@ -88,7 +88,7 @@ (test 'BANANA with-input-from-file (build-path (collection-path "packed") "banana") read) (when pack-plt - (system* mzc "--collection-plt" pack-plt flag "packed")) + (system* raco "pack" flag "--collect" pack-plt "packed")) (delete-directory/files (build-path dir "packed"))) diff --git a/racket/lib/collects/racket/HISTORY.txt b/racket/lib/collects/racket/HISTORY.txt index bb24adfc4e..7916b928ce 100644 --- a/racket/lib/collects/racket/HISTORY.txt +++ b/racket/lib/collects/racket/HISTORY.txt @@ -1,5 +1,7 @@ Version 5.3.900.6 Added identifier-binding-symbol +Changed ".plt" file unpacking to require certain literal S-expression + patterns, instead of evaluating S-expressions from the archive Version 5.3.900.5 Added call-with-default-reading-parameterization diff --git a/racket/lib/collects/setup/unpack.rkt b/racket/lib/collects/setup/unpack.rkt index 707aa3cfc4..98c690d393 100644 --- a/racket/lib/collects/setup/unpack.rkt +++ b/racket/lib/collects/setup/unpack.rkt @@ -7,6 +7,7 @@ racket/bool net/base64 setup/getinfo + racket/match "dirs.rkt") (provide unpack @@ -275,11 +276,32 @@ (eq? #\L (read-char p)) (eq? #\T (read-char p))) (error "not an unpackable distribution archive")) - (let* ([n (make-base-namespace)] - [info (let ([orig (current-namespace)]) - (parameterize ([current-namespace n]) - (namespace-require '(lib "mzlib/unit200.ss")) - (eval (read p))))]) + (let* ([info (let ([v (read p)]) + (match v + [`(lambda (request failure) + (case request + [(name) ,name] + [(unpacker) 'mzscheme] + [(requires) ',requires] + [(conflicts) ',conflicts] + [(plt-relative?) ,plt-relative?] + [(plt-home-relative?) ,plt-home-relative?] + [(test-plt-dirs) ,test-dirs] ; #f or `(quote ,dirs) + [else (failure)])) + (lambda (request failure) + (case request + [(name) name] + [(unpacker) 'mzscheme] + [(requires) requires] + [(conflicts) conflicts] + [(plt-relative?) plt-relative?] + [(plt-home-relative?) plt-home-relative?] + [(test-plt-dirs) (and test-dirs + (cadr test-dirs))] + [else (failure)]))] + [else + (error "info-procedure S-expression did not have the expected shape: " + v)]))]) (unless (and (procedure? info) (procedure-arity-includes? info 2)) (error "expected a procedure of arity 2, got" info)) @@ -420,18 +442,21 @@ (unless (and name unpacker) (error "bad name or unpacker")) (print-status (format "Unpacking ~a from ~a" name archive)) - (let ([u (eval (read p) n)]) - (unless (eval `(unit? ,u) n) - (error "expected a v200 unit, got" u)) - (make-directory* (car target-dir-info)) - (let ([unmztar (lambda (filter) - (unmztar p filter - (car target-dir-info) - (lambda (a b) - ((cadr target-dir-info) a b)) - ((length target-dir-info) . > . 1) - print-status))]) - (eval `(invoke-unit ,u ,(car target-dir-info) ,unmztar) n)))) + (let ([u (read p)]) + (match u + [`(unit (import main-collects-parent-dir mzuntar) (export) + (mzuntar void) + (quote ,collections)) + (make-directory* (car target-dir-info)) + (unmztar p void + (car target-dir-info) + (lambda (a b) + ((cadr target-dir-info) a b)) + ((length target-dir-info) . > . 1) + print-status) + collections] + [else + (error "expected a `unit' pattern, got" u)]))) ;; Cancelled: no collections null))))