diff --git a/collects/compiler/commands/info.rkt b/collects/compiler/commands/info.rkt index d97e168309..e20ae53b7d 100644 --- a/collects/compiler/commands/info.rkt +++ b/collects/compiler/commands/info.rkt @@ -4,6 +4,7 @@ '(("make" compiler/commands/make "compile source to bytecode" 100) ("exe" compiler/commands/exe "create executable" 20) ("pack" compiler/commands/pack "pack files/collections into a .plt archive" 10) + ("unpack" compiler/commands/unpack "unpack files/collections from a .plt archive" 10) ("decompile" compiler/commands/decompile "decompile bytecode" #f) ("expand" compiler/commands/expand "macro-expand source" #f) ("distribute" compiler/commands/exe-dir "prepare executable(s) in a directory for distribution" #f) diff --git a/collects/compiler/commands/unpack.rkt b/collects/compiler/commands/unpack.rkt new file mode 100644 index 0000000000..2c2a1cfdd7 --- /dev/null +++ b/collects/compiler/commands/unpack.rkt @@ -0,0 +1,102 @@ +#lang scheme/base +(require scheme/cmdline + raco/command-name + setup/unpack + racket/file + racket/port + racket/match + racket/string + racket/pretty) + +(define verbose (make-parameter #f)) + +(define just-show? (make-parameter #f)) +(define replace? (make-parameter #f)) +(define show-config? (make-parameter #f)) + +(define mzc-symbol (string->symbol (short-program+command-name))) + +(define files + (command-line + #:program (short-program+command-name) + #:once-each + [("-l" "--list") "just list archive content" + (just-show? #t)] + [("-c" "--config") "show archive configuration" + (show-config? #t)] + [("-f" "--force") "replace existing files when unpacking" + (replace? #t)] + #:args archive + archive)) + +(define (desc->path dir) + (if (path? dir) + dir + (apply build-path + (symbol->string (car dir)) + (cdr dir)))) + +(for ([filename (in-list files)]) + (fold-plt-archive filename + (lambda (config a) + (when (show-config?) + (match config + [`(lambda (request failure) + (case request + ((name) ,name) + ((unpacker) (quote mzscheme)) + ((requires) (quote ,reqs)) + ((conflicts) (quote ,conflicts)) + ((plt-relative?) ,plt-rel?) + ((plt-home-relative?) ,plt-home-rel?) + ((test-plt-dirs) ,test-plt-dirs) + (else (failure)))) + (printf "config:\n") + (printf " name: ~s\n" name) + (printf " requires:\n") + (for ([c (in-list reqs)]) + (printf " ~s ~s\n" (string-join (car c) "/") (cadr c))) + (printf " conflicts:\n") + (for ([c (in-list conflicts)]) + (printf " ~s\n" (string-join c "/"))) + (cond + [plt-home-rel? (printf " unpack to main installation\n")] + [plt-rel? (printf " unpack to user add-ons\n")] + [else (printf " unpack locally\n")])] + [else + (printf "config function:\n") + (pretty-write config)])) + a) + (lambda (setup i a) + (when (show-config?) + (match setup + [`(unit (import main-collects-parent-dir mzuntar) (export) (mzuntar void) (quote ,c)) + (printf "setup collections:\n") + (for ([c (in-list c)]) + (printf " ~s\n" (string-join c "/")))] + [else + (printf "setup unit:\n") + (pretty-write setup)])) + a) + (lambda (dir a) + (unless (eq? dir 'same) + (if (just-show?) + (printf "~a\n" (path->directory-path (desc->path dir))) + (make-directory* (desc->path dir)))) + a) + (lambda (file i kind a) + (if (just-show?) + (printf "~a~a\n" (desc->path file) + (if (eq? kind 'file-replace) + " [replace]" + "")) + (call-with-output-file* + (desc->path file) + #:exists (if (or (eq? kind 'file-replace) + (replace?)) + 'truncate/replace + 'error) + (lambda (o) + (copy-port i o)))) + a) + (void))) diff --git a/collects/scribblings/raco/plt.scrbl b/collects/scribblings/raco/plt.scrbl index 458cd17386..84c5c67b87 100644 --- a/collects/scribblings/raco/plt.scrbl +++ b/collects/scribblings/raco/plt.scrbl @@ -1,7 +1,10 @@ #lang scribble/doc -@(require scribble/manual "common.rkt" (for-label racket/base)) +@(require scribble/manual + "common.rkt" + (for-label racket/base + setup/pack)) -@title[#:tag "plt"]{@exec{raco pack}: Packaging Library Collections} +@title[#:tag "plt"]{@exec{raco pack}: Packing Library Collections} @margin-note{Before creating a @filepath{.plt} archive to distribute, consider instead posting your package on @@ -11,7 +14,10 @@ The @exec{raco pack} command creates an archive for distributing library files to Racket users. A distribution archive usually has the suffix @as-index{@filepath{.plt}}, which DrRacket recognizes as an archive to provide automatic unpacking facilities. The @exec{raco -setup} command also supports @filepath{.plt} unpacking. +setup} command (see @secref["setup"]) also supports @filepath{.plt} +unpacking with installation, while the @exec{raco unpack} command (see +@secref["unpack"]) unpacks an archive locally without attempting to +install it. An archive contains the following elements: @@ -131,9 +137,160 @@ unpacked, the unpacker will check that the @filepath{mred} collection is installed, and that @filepath{mred} has the same version as when @filepath{sirmail.plt} was created. +@; ------------------------------------------------------------------------ + +@section[#:tag "format-of-.plt-archives"]{Format of @filepath{.plt} Archives} + +The extension @filepath{.plt} is not required for a distribution +archive, but the @filepath{.plt}-extension convention helps users +identify the purpose of a distribution file. + +The raw format of a distribution file is described below. This format +is uncompressed and sensitive to communication modes (text +vs. binary), so the distribution format is derived from the raw format +by first compressing the file using @exec{gzip}, then encoding the gzipped +file with the MIME base64 standard (which relies only the characters +@litchar{A}-@litchar{Z}, @litchar{a}-@litchar{z}, @litchar{0}-@litchar{9}, +@litchar{+}, @litchar{/}, and @litchar{=}; all other characters are ignored +when a base64-encoded file is decoded). + +The raw format is + +@itemize[ + @item{ + @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: + + @itemize[ + @item{ + @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 + unpacking the archive, which associated versions; see the + documentation of @racket[pack] for details.} + + @item{ + @racket['conflicts] --- collections required @emph{not} to be installed + before unpacking the archive.} + + @item{ + @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-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 + 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. } + + @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. + + 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: + + @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, } + + @item{ + a relative path string --- the pathname of the directory or file + to be unpacked, relative to the unpack directory, and} + + @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). + +An @deftech{unpackable} is one of the following: + +@itemize[ + @item{ + The symbol @racket['dir] followed by a list. 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). + + The @racket['dir] symbol and list are extracted from the archive + using @racket[read] (and the result is @emph{not} + @racket[eval]uated).} + + @item{ + The symbol @racket['file], a list, a number, an asterisk, and the file + data. The list specifies the file's relative path, just as for + directories. The number indicates the size of the file to be + unpacked in bytes. The asterisk indicates the start of the file + data; the next n bytes are written to the file, where n is the + specified size of the file. + + The symbol, list, and number are all extracted from the archive + using @racket[read] (and the result is @emph{not} + @racket[eval]uated). After the number is read, input characters + are discarded until an asterisk is found. The file data must + follow this asterisk immediately.} + + @item{ + The symbol @racket['file-replace] is treated like @racket['file], + but if the file exists on disk already, the file in the archive replaces + the file on disk.} +] + @; ---------------------------------------- -@section{API for Packaging} +@section{API for Packing} @defmodule[setup/pack]{Although the @exec{raco pack} command can be used to create most @filepath{.plt} files, the @@ -192,6 +349,7 @@ making @filepath{.plt} archives.} (dest path-string?) (name string?) (paths (listof path-string?)) + [#:as-paths as-paths (listof path-string?) paths] [#:file-filter filter-proc (path-string? . -> . boolean?) std-filter] [#:encode? encode? boolean? #t] @@ -213,7 +371,10 @@ making @filepath{.plt} archives.} using the string @racket[name] as the name reported to @exec{raco setup} as the archive's description. The @racket[paths] argument must be a list of relative paths for directories and files; the contents of these files and - directories will be packed into the archive. + directories will be packed into the archive. The optional @racket[as-paths] + list provides the path to be recorded in the archive for each element of + @racket[paths] (so that the unpacked paths can be different from the packed + paths). The @racket[#:file-filter] procedure is called with the relative path of each candidate for packing. If it returns @racket[#f] for some path, then that @@ -306,12 +467,15 @@ making @filepath{.plt} archives.} @litchar{[.]plt$}.} @defproc[(mztar (path path-string?) + [#:as-path path path-string? path] (output output-port?) (filter (path-string? . -> . boolean?)) (file-mode (symbols 'file 'file-replace))) void?]{ Called by @racket[pack] to write one directory/file @racket[path] to the output port @racket[output] using the filter procedure @racket[filter] - (see @racket[pack] for a description of @racket[filter]). The + (see @racket[pack] for a description of @racket[filter]). The @racket[path] + is recorded in the output as @racket[as-path], in case the unpacked + path should be different from the original path. The @racket[file-mode] argument specifies the default mode for packing a file, either @racket['file] or @racket['file-replace].} diff --git a/collects/scribblings/raco/raco.scrbl b/collects/scribblings/raco/raco.scrbl index e14f55ef57..9196ef811c 100644 --- a/collects/scribblings/raco/raco.scrbl +++ b/collects/scribblings/raco/raco.scrbl @@ -20,6 +20,7 @@ a typical Racket installation. @include-section["exe.scrbl"] @include-section["dist.scrbl"] @include-section["plt.scrbl"] +@include-section["unpack.scrbl"] @include-section["planet.scrbl"] @include-section["setup.scrbl"] @include-section["decompile.scrbl"] diff --git a/collects/scribblings/raco/setup.scrbl b/collects/scribblings/raco/setup.scrbl index 367a5d1772..68c59bea98 100644 --- a/collects/scribblings/raco/setup.scrbl +++ b/collects/scribblings/raco/setup.scrbl @@ -584,14 +584,12 @@ form.} @section[#:tag ".plt-archives"]{API for Installing @filepath{.plt} Archives} -@subsection{Installing a Single @filepath{.plt} File} - The @racketmodname[setup/plt-single-installer] module provides a function for installing a single @filepath{.plt} file, and @racketmodname[setup/plt-installer] wraps it with a GUI interface. -@subsubsection{Non-GUI Installer} +@subsection{Non-GUI Installer} @local-module[setup/plt-single-installer]{ @@ -643,7 +641,7 @@ v should be run after a set of @|PLaneT| packages are removed.}} -@subsubsection[#:tag "gui-unpacking"]{GUI Installer} +@subsection[#:tag "gui-unpacking"]{GUI Installer} @defmodule[setup/plt-installer]{ The @racketmodname[setup/plt-installer] library in the setup collection @@ -683,7 +681,7 @@ v @; ---------------------------------------- -@subsubsection{GUI Unpacking Signature} +@subsection{GUI Unpacking Signature} @defmodule[setup/plt-installer-sig]{ @defsignature[setup:plt-installer^ ()]{ @@ -692,256 +690,12 @@ v @; ---------------------------------------- -@subsubsection{GUI Unpacking Unit} +@subsection{GUI Unpacking Unit} @defmodule[setup/plt-installer-unit]{ Imports @racket[mred^] and exports @racket[setup:plt-installer^]. } -@; ------------------------------------------------------------------------ - -@subsection[#:tag "unpacking-.plt-archives"]{Unpacking @filepath{.plt} Archives} - -@defmodule[setup/unpack]{The @racketmodname[setup/unpack] -library provides raw support for unpacking a @filepath{.plt} file.} - -@defproc[(unpack [archive path-string?] - [main-collects-parent-dir path-string? (current-directory)] - [print-status (string? . -> . any) (lambda (x) (printf "~a\n" x))] - [get-target-directory (-> path-string?) (lambda () (current-directory))] - [force? any/c #f] - [get-target-plt-directory - (path-string? - path-string? - (listof path-string?) - . -> . path-string?) - (lambda (_preferred-dir _main-dir _options) - _preferred-dir)]) - void?]{ - -Unpacks @racket[archive]. - -The @racket[main-collects-parent-dir] argument is passed along to -@racket[get-target-plt-directory]. - -The @racket[print-status] argument is used to report unpacking -progress. - -The @racket[get-target-directory] argument is used to get the -destination directory for unpacking an archive whose content is -relative to an arbitrary directory. - -If @racket[force?] is true, then version and required-collection -mismatches (comparing information in the archive to the current -installation) are ignored. - -The @racket[get-target-plt-directory] function is called to select a -target for installation for an archive whose is relative to the -installation. The function should normally return one if its first two -arguments; the third argument merely contains the first two, but has -only one element if the first two are the same. If the archive does -not request installation for all uses, then the first two arguments -will be different, and the former will be a user-specific location, -while the second will refer to the main installation.} - -@defproc[(fold-plt-archive [archive path-string?] - [on-config-fn (any/c any/c . -> . any/c)] - [on-setup-unit (any/c input-port? any/c . -> . any/c)] - [on-directory (path-string? any/c . -> . any/c)] - [on-file (path-string? input-port? any/c . -> . any/c)] - [initial-value any/c]) - any/c]{ - -Traverses the content of @racket[archive], which must be a -@filepath{.plt} archive that is created with the default unpacking -unit and configuration expression. The configuration expression is not -evaluated, the unpacking unit is not invoked, and not files are -unpacked to the filesystem. Instead, the information in the archive is -reported back through @racket[on-config], @racket[on-setup-unit], -@racket[on-directory], and @racket[on-file], each of which can build on -an accumulated value that starts with @racket[initial-value] and whose -final value is returned. - -The @racket[on-config-fn] function is called once with an S-expression -that represents a function to implement configuration information. -The second argument to @racket[on-config] is @racket[initial-value], -and the function's result is passes on as the last argument to @racket[on-setup-unit]. - -The @racket[on-setup-unit] function is called with the S-expression -representation of the installation unit, an input port that points to -the rest of the file, and the accumulated value. This input port is -the same port that will be used in the rest of processing, so if -@racket[on-setup-unit] consumes any data from the port, then that data -will not be consumed by the remaining functions. (This means that -on-setup-unit can leave processing in an inconsistent state, which is -not checked by anything, and therefore could cause an error.) -The result of @racket[on-setup-unit] becomes the new accumulated value. - -For each directory that would be created by the archive when unpacking -normally, @racket[on-directory] is called with the directory path and the -accumulated value up to that point, and its result is the new -accumulated value. - -For each file that would be created by the archive when unpacking -normally, @racket[on-file] is called with the file path, an input port -containing the contents of the file, and the accumulated value up to -that point; its result is the new accumulated value. The input port -can be used or ignored, and parsing of the rest of the file continues -the same either way. After @racket[on-file] returns control, however, -the input port is drained of its content.} - -@; ------------------------------------------------------------------------ - -@subsection[#:tag "format-of-.plt-archives"]{ - Format of @filepath{.plt} Archives} - -The extension @filepath{.plt} is not required for a distribution -archive, but the @filepath{.plt}-extension convention helps users -identify the purpose of a distribution file. - -The raw format of a distribution file is described below. This format -is uncompressed and sensitive to communication modes (text -vs. binary), so the distribution format is derived from the raw format -by first compressing the file using @exec{gzip}, then encoding the gzipped -file with the MIME base64 standard (which relies only the characters -@litchar{A}-@litchar{Z}, @litchar{a}-@litchar{z}, @litchar{0}-@litchar{9}, -@litchar{+}, @litchar{/}, and @litchar{=}; all other characters are ignored -when a base64-encoded file is decoded). - -The raw format is - -@itemize[ - @item{ - @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: - - @itemize[ - @item{ - @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 - unpacking the archive, which associated versions; see the - documentation of @racket[pack] for details.} - - @item{ - @racket['conflicts] --- collections required @emph{not} to be installed - before unpacking the archive.} - - @item{ - @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-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 - 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. } - - @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. - - 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: - - @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, } - - @item{ - a relative path string --- the pathname of the directory or file - to be unpacked, relative to the unpack directory, and} - - @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). - -An @deftech{unpackable} is one of the following: - -@itemize[ - @item{ - The symbol @racket['dir] followed by a list. 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). - - The @racket['dir] symbol and list are extracted from the archive - using @racket[read] (and the result is @emph{not} - @racket[eval]uated).} - - @item{ - The symbol @racket['file], a list, a number, an asterisk, and the file - data. The list specifies the file's relative path, just as for - directories. The number indicates the size of the file to be - unpacked in bytes. The asterisk indicates the start of the file - data; the next n bytes are written to the file, where n is the - specified size of the file. - - The symbol, list, and number are all extracted from the archive - using @racket[read] (and the result is @emph{not} - @racket[eval]uated). After the number is read, input characters - are discarded until an asterisk is found. The file data must - follow this asterisk immediately.} - - @item{ - The symbol @racket['file-replace] is treated like @racket['file], - but if the file exists on disk already, the file in the archive replaces - the file on disk.} -] - @; ---------------------------------------------------------- @section[#:tag "dirs"]{API for Finding Installation Directories} diff --git a/collects/scribblings/raco/unpack.scrbl b/collects/scribblings/raco/unpack.scrbl new file mode 100644 index 0000000000..23da1a5865 --- /dev/null +++ b/collects/scribblings/raco/unpack.scrbl @@ -0,0 +1,123 @@ +#lang scribble/doc +@(require scribble/manual + "common.rkt" + (for-label racket/base + setup/unpack)) + +@title[#:tag "unpack"]{@exec{raco unpack}: Unpacking Library Collections} + +The @exec{raco unpack} command unpacks a @filepath{.plt} archive (see +@secref["plt"]) to the current directory without attempting to install +any collections. Use @exec{raco setup -A} (see @secref["setup"]) to +unpack and install collections from a @filepath{.plt} archive. + +Command-line flags: + +@itemlist[ + + @item{@Flag{l} or @DFlag{list} --- lists the content of the archive + without unpacking it.} + + @item{@Flag{c} or @DFlag{config} --- shows the archive configuration + before unpacking or listing the archive content.} + + @item{@Flag{f} or @DFlag{force} --- replace files that exist already; + fails that the archive says should be replaced will be replaced + without this flag.} + +] + +@; ------------------------------------------------------------------------ + +@section[#:tag "unpacking-.plt-archives"]{Unpacking API} + +@defmodule[setup/unpack]{The @racketmodname[setup/unpack] +library provides raw support for unpacking a @filepath{.plt} file.} + +@defproc[(unpack [archive path-string?] + [main-collects-parent-dir path-string? (current-directory)] + [print-status (string? . -> . any) (lambda (x) (printf "~a\n" x))] + [get-target-directory (-> path-string?) (lambda () (current-directory))] + [force? any/c #f] + [get-target-plt-directory + (path-string? + path-string? + (listof path-string?) + . -> . path-string?) + (lambda (_preferred-dir _main-dir _options) + _preferred-dir)]) + void?]{ + +Unpacks @racket[archive]. + +The @racket[main-collects-parent-dir] argument is passed along to +@racket[get-target-plt-directory]. + +The @racket[print-status] argument is used to report unpacking +progress. + +The @racket[get-target-directory] argument is used to get the +destination directory for unpacking an archive whose content is +relative to an arbitrary directory. + +If @racket[force?] is true, then version and required-collection +mismatches (comparing information in the archive to the current +installation) are ignored. + +The @racket[get-target-plt-directory] function is called to select a +target for installation for an archive whose is relative to the +installation. The function should normally return one if its first two +arguments; the third argument merely contains the first two, but has +only one element if the first two are the same. If the archive does +not request installation for all uses, then the first two arguments +will be different, and the former will be a user-specific location, +while the second will refer to the main installation.} + +@defproc[(fold-plt-archive [archive path-string?] + [on-config-fn (any/c any/c . -> . any/c)] + [on-setup-unit (any/c input-port? any/c . -> . any/c)] + [on-directory (path-string? any/c . -> . any/c)] + [on-file (or/c (path-string? input-port? any/c . -> . any/c) + (path-string? input-port? (one-of/c 'file 'file-replace) any/c + . -> . any/c))] + [initial-value any/c]) + any/c]{ + +Traverses the content of @racket[archive], which must be a +@filepath{.plt} archive that is created with the default unpacking +unit and configuration expression. The configuration expression is not +evaluated, the unpacking unit is not invoked, and not files are +unpacked to the filesystem. Instead, the information in the archive is +reported back through @racket[on-config], @racket[on-setup-unit], +@racket[on-directory], and @racket[on-file], each of which can build on +an accumulated value that starts with @racket[initial-value] and whose +final value is returned. + +The @racket[on-config-fn] function is called once with an S-expression +that represents a function to implement configuration information. +The second argument to @racket[on-config] is @racket[initial-value], +and the function's result is passes on as the last argument to @racket[on-setup-unit]. + +The @racket[on-setup-unit] function is called with the S-expression +representation of the installation unit, an input port that points to +the rest of the file, and the accumulated value. This input port is +the same port that will be used in the rest of processing, so if +@racket[on-setup-unit] consumes any data from the port, then that data +will not be consumed by the remaining functions. (This means that +on-setup-unit can leave processing in an inconsistent state, which is +not checked by anything, and therefore could cause an error.) +The result of @racket[on-setup-unit] becomes the new accumulated value. + +For each directory that would be created by the archive when unpacking +normally, @racket[on-directory] is called with the directory path and the +accumulated value up to that point, and its result is the new +accumulated value. + +For each file that would be created by the archive when unpacking +normally, @racket[on-file] is called with the file path, an input port +containing the contents of the file, an optional mode symbol indicating +whether the file should be replaced, and the accumulated value up to +that point; its result is the new accumulated value. The input port +can be used or ignored, and parsing of the rest of the file continues +the same either way. After @racket[on-file] returns control, however, +the input port is drained of its content.} diff --git a/collects/setup/pack.rkt b/collects/setup/pack.rkt index e3462073ca..889f084e30 100644 --- a/collects/setup/pack.rkt +++ b/collects/setup/pack.rkt @@ -40,6 +40,7 @@ #:at-plt-home? at-plt-home?)) (define (pack-plt dest name paths + #:as-paths [as-paths paths] #:collections [collections null] #:file-filter [file-filter std-filter] #:encode? [encode? #t] @@ -125,56 +126,84 @@ (quote ,collections))) fileout) (newline fileout) - (for-each (lambda (path) - (mztar (simplify-path path #f) fileout file-filter file-mode)) - paths) + (for-each (lambda (path as-path) + (mztar (simplify-path path #f) #:as-path (simplify-path as-path #f) + fileout file-filter file-mode)) + paths as-paths) (close-output-port fileout) (thread-wait thd))) (define (element->string x) (if (path? x) (path->string x) x)) - (define (mztar path output file-filter file-mode) + (define (mztar path #:as-path [as-path path] output file-filter file-mode) (define (path->list p) (if (eq? p 'same) - null - (let-values ([(base name dir?) (split-path p)]) - (if (path? base) - (append (path->list base) (list name)) - (list name))))) - (define-values (init-dir init-files) + null + (let-values ([(base name dir?) (split-path p)]) + (if (path? base) + (append (path->list base) (list name)) + (list name))))) + (define-values (init-dir init-as-dir init-files init-as-files) (if (file-exists? path) - (let-values ([(base name dir?) (split-path path)]) - (values (if (eq? base 'relative) 'same base) (list name))) - (values (if (string? path) (string->path path) path) #f))) + (let*-values ([(base name dir?) (split-path path)] + [(as-base as-name as-dir?) (if as-path + (split-path as-path) + (values base name dir?))]) + (values (if (eq? base 'relative) 'same base) + (if (eq? as-base 'relative) 'same as-base) + (list name) + (list as-name))) + (let* ([init-dir (if (string? path) (string->path path) path)] + [init-as-dir (if (string? as-path) (string->path as-path) as-path)]) + (values init-dir + init-as-dir + #f + #f)))) - (let loop ([dir init-dir] [dpath (path->list init-dir)] [files init-files]) - (printf "MzTarring ~a...\n" + (let loop ([dir init-dir] [dpath (path->list init-dir)] + [as-dir init-as-dir] [as-dpath (path->list init-as-dir)] + [files init-files] + [as-files init-as-files]) + (printf "MzTarring ~a~a...\n" (path->string (if files (build-path dir (car files)) - dir))) - (fprintf output "~s\n~s\n" 'dir (map element->string dpath)) - (for-each - (lambda (f) - (let* ([p (build-path dir f)] - [filter-val (file-filter p)]) - (when filter-val - (if (directory-exists? p) - (loop p (append dpath (list f)) #f) - (let ([len (file-size p)]) - ;; (printf "MzTarring ~a\n" p) - (fprintf output "~s\n~s\n~s\n*" - (case filter-val - [(file) 'file] - [(file-replace) 'file-replace] - [else file-mode]) - (map element->string (append dpath (list f))) - len) - (call-with-input-file* p - (lambda (p) (copy-port p output)))))))) - (or files (sort (map element->string (directory-list dir)) stringstring as-dpath)) + (let* ([files (or files (sort (map element->string (directory-list dir)) stringstring (append as-dpath (list as-f))) + len) + (call-with-input-file* + p + (lambda (p) (copy-port p output))))))))))) + (define (std-filter path) (let-values ([(base name dir?) (split-path path)]) (let ([name (path->bytes name)]) @@ -198,31 +227,16 @@ #:at-plt-home? [at-plt-home? #f] #:test-plt-collects? [test-plt-collects? #t]) (let-values - ([(dir source-files requires conflicts name) + ([(source-files as-source-files requires conflicts name) (let ([dirs (map (lambda (cp) (apply collection-path cp)) collections)]) ;; Figure out the base path: (let* ([base-path #f] [base-path-setter #f] + [paths dirs] [rel-paths - (map (lambda (dir coll) - (let*-values ([(base c-name dir?) (split-path dir)] - [(base subdir) - (let loop ([l (cdr coll)][base base]) - (let-values ([(base x-name dir?) (split-path base)]) - (if (null? l) - (values base x-name) - (let-values ([(base subdir) (loop (cdr l) base)]) - (values base (build-path subdir x-name))))))]) - (if base-path - (unless (equal? base base-path) - (error 'mzc - "cannot combine collections that live in different directories: \"~a\" and: \"~a\"" - base-path-setter - dir)) - (begin (set! base-path-setter dir) - (set! base-path base))) - (build-path 'same subdir c-name))) - dirs collections)] + (map (lambda (coll) + (build-path "collects" (apply build-path coll))) + collections)] [infos (map (lambda (cp) (get-info cp)) collections)] [coll-list? (lambda (cl) @@ -244,7 +258,7 @@ which src-cp)) rl)) infos collections)))]) - (values base-path + (values paths rel-paths (get-dep-coll 'requires) (append (if replace? null collections) @@ -254,21 +268,21 @@ 'name (lambda () (caar collections)))))))]) (let ([output (path->complete-path output)]) - (parameterize ([current-directory dir]) - (pack-plt - output name - source-files - #:collections (append extra-setup-collections - (filter get-info collections)) - #:file-filter file-filter - #:file-mode (if replace? 'file-replace 'file) - #:plt-relative? #t - #:requires - ;; For each require, get current version - (map (lambda (r) - (let ([i (get-info r)]) - (let ([v (and i (i 'version (lambda () #f)))]) - (if v + (pack-plt + output name + source-files + #:as-paths as-source-files + #:collections (append extra-setup-collections + (filter get-info collections)) + #:file-filter file-filter + #:file-mode (if replace? 'file-replace 'file) + #:plt-relative? #t + #:requires + ;; For each require, get current version + (map (lambda (r) + (let ([i (get-info r)]) + (let ([v (and i (i 'version (lambda () #f)))]) + (if v (begin (unless (and (list? v) (andmap number? v) @@ -280,13 +294,13 @@ r)) (list r v)) (list r null))))) - requires - ;; Packer used to automatically include "mzscheme" - ;; dependency, but we've conlcuded that dependencies - ;; aren't typically useful. - #; - (cons '("mzscheme") requires)) - #:conflicts conflicts - #:at-plt-home? at-plt-home? - #:test-plt-dirs (and at-plt-home? test-plt-collects? - '("collects")))))))) + requires + ;; Packer used to automatically include "mzscheme" + ;; dependency, but we've conlcuded that dependencies + ;; aren't typically useful. + #; + (cons '("mzscheme") requires)) + #:conflicts conflicts + #:at-plt-home? at-plt-home? + #:test-plt-dirs (and at-plt-home? test-plt-collects? + '("collects"))))))) diff --git a/collects/setup/unpack.rkt b/collects/setup/unpack.rkt index 7a181f6827..769132bd9f 100644 --- a/collects/setup/unpack.rkt +++ b/collects/setup/unpack.rkt @@ -1,426 +1,436 @@ -(module unpack mzscheme +#lang racket/base - (require mzlib/etc - mzlib/inflate - mzlib/file - mzlib/list - mzlib/port - net/base64 - setup/getinfo - "dirs.rkt") +(require file/gunzip + racket/file + racket/list + racket/port + racket/bool + net/base64 + setup/getinfo + "dirs.rkt" + (only-in mzscheme make-namespace)) - (provide unpack - fold-plt-archive) +(provide unpack + fold-plt-archive) - ;; ---------------------------------------- +;; ---------------------------------------- - ;; Returns a port and a kill thunk - (define (port64gz->port p64gz) - ;; Inflate in a thread so the whole input isn't read at once - (let-values ([(base64-out base64-in) (make-pipe 4096)] - [(guz-out guz-in) (make-pipe 4096)]) - (let ([64t - (thread (lambda () - (dynamic-wind +;; Returns a port and a kill thunk +(define (port64gz->port p64gz) + ;; Inflate in a thread so the whole input isn't read at once + (let-values ([(base64-out base64-in) (make-pipe 4096)] + [(guz-out guz-in) (make-pipe 4096)]) + (let ([64t + (thread (lambda () + (dynamic-wind void (lambda () (base64-decode-stream p64gz base64-in)) (lambda () (close-output-port base64-in)))))] - [gzt - (thread (lambda () - (dynamic-wind + [gzt + (thread (lambda () + (dynamic-wind void (lambda () (gunzip-through-ports base64-out guz-in)) (lambda () (close-output-port guz-in)))))]) - (values guz-out (lambda () (kill-thread 64t) (kill-thread gzt)))))) - - ;; ------------------------------------------------------------ - - ;; fold-plt-archive : path[to .plt file] (sexpr A -> A) (sexpr input-port A -> A) (path A -> A) (path input-port A -> A) A -> A - (define (fold-plt-archive filename on-config-fn on-setup-unit on-directory on-file initial-value) - (let*-values ([(fip) (open-input-file filename)] - [(ip kill) (port64gz->port fip)]) - (dynamic-wind - void - (λ () (fold-plt-archive-port ip on-config-fn on-setup-unit on-directory on-file initial-value)) - (λ () - (close-input-port fip) - (kill))))) - - ;; fold-plt-archive-port : input-port (sexpr A -> A) (sexpr input-port A -> A) (path A -> A) (path input-port A -> A) A -> A - (define (fold-plt-archive-port p on-config-fn on-setup-unit on-directory on-file initial-value) - - ;; skip past the initial #"PLT" and two sexprs - (unless (and (eq? #\P (read-char p)) - (eq? #\L (read-char p)) - (eq? #\T (read-char p))) - (error "not an unpackable distribution archive")) - - (let* ([config-fn-sexpr (read p)] - [_ (when (eof-object? config-fn-sexpr) (error "malformed input"))] - [val (on-config-fn config-fn-sexpr initial-value)] - - [setup-unit (read p)] - [_ (when (eof-object? setup-unit) (error "malformed input"))] - [val (on-setup-unit setup-unit p val)]) - - ;; read contents of file directly. [on-setup-unit may have consumed all input, - ;; but if so this loop will just do nothing.] - (let loop ([val val]) - (let ([kind (read p)]) - (cond - [(eof-object? kind) val] - [else - (case kind - [(dir) - (let* ([v (read p)] - [s (expr->path-descriptor v)]) - (unless (relative-path-descriptor? s) - (error "expected a directory name relative path string, got" s)) - (let ([next-val (on-directory s val)]) - (loop next-val)))] - [(file file-replace) - (let* ([v (read p)] - [s (expr->path-descriptor v)]) - (unless (relative-path-descriptor? s) - (error "expected a file name relative path string, got" s)) - (let ([len (read p)]) - (unless (and (number? len) (integer? len)) - (error "expected a file name size, got" len)) - ;; Find starting * - (let loop () - (let ([c (read-char p)]) - (cond [(char=? c #\*) (void)] ; found it - [(char-whitespace? c) (loop)] - [(eof-object? c) (void)] ; signal the error below - [else (error - (format "unexpected character setting up ~a, looking for *" s) - c)]))) - (let-values ([(control fp) (protected-limited-input-port p len)]) - (let ([next-val (on-file s fp val)]) - (exhaust-port control) - (loop next-val)))))] - [else (error "unknown file tag" kind)])]))))) - - ;; path-descriptor ::= 'same | (list location path) - ;; location ::= symbol in '(same collects doc lib include) + (values guz-out (lambda () (kill-thread 64t) (kill-thread gzt)))))) - ;; expr->path-descriptor : sexpr -> path-descriptor - ;; extracts a path-descriptor from an sexpr embedded in a .plt file - ;; raises an error if the given sexpr can't be converted to a path descriptor - (define (expr->path-descriptor v) +;; ------------------------------------------------------------ + +;; fold-plt-archive : path[to .plt file] (sexpr A -> A) (sexpr input-port A -> A) (path A -> A) (path input-port A -> A) A -> A +(define (fold-plt-archive filename on-config-fn on-setup-unit on-directory on-file initial-value) + (let*-values ([(fip) (open-input-file filename)] + [(ip kill) (port64gz->port fip)]) + (dynamic-wind + void + (λ () (fold-plt-archive-port ip on-config-fn on-setup-unit on-directory on-file initial-value)) + (λ () + (close-input-port fip) + (kill))))) + +;; fold-plt-archive-port : input-port (sexpr A -> A) (sexpr input-port A -> A) (path A -> A) (path input-port A -> A) A -> A +(define (fold-plt-archive-port p on-config-fn on-setup-unit on-directory on-file initial-value) + + ;; skip past the initial #"PLT" and two sexprs + (unless (and (eq? #\P (read-char p)) + (eq? #\L (read-char p)) + (eq? #\T (read-char p))) + (error "not an unpackable distribution archive")) + + (let* ([config-fn-sexpr (read p)] + [_ (when (eof-object? config-fn-sexpr) (error "malformed input"))] + [val (on-config-fn config-fn-sexpr initial-value)] + + [setup-unit (read p)] + [_ (when (eof-object? setup-unit) (error "malformed input"))] + [val (on-setup-unit setup-unit p val)]) + + ;; read contents of file directly. [on-setup-unit may have consumed all input, + ;; but if so this loop will just do nothing.] + (let loop ([val val]) + (let ([kind (read p)]) + (cond + [(eof-object? kind) val] + [else + (case kind + [(dir) + (let* ([v (read p)] + [s (expr->path-descriptor v)]) + (unless (relative-path-descriptor? s) + (error "expected a directory name relative path string, got" s)) + (let ([next-val (on-directory s val)]) + (loop next-val)))] + [(file file-replace) + (let* ([v (read p)] + [s (expr->path-descriptor v)]) + (unless (relative-path-descriptor? s) + (error "expected a file name relative path string, got" s)) + (let ([len (read p)]) + (unless (and (number? len) (integer? len)) + (error "expected a file name size, got" len)) + ;; Find starting * + (let loop () + (let ([c (read-char p)]) + (cond [(char=? c #\*) (void)] ; found it + [(char-whitespace? c) (loop)] + [(eof-object? c) (void)] ; signal the error below + [else (error + (format "unexpected character setting up ~a, looking for *" s) + c)]))) + (let-values ([(control fp) (protected-limited-input-port p len)]) + (let ([next-val (if (procedure-arity-includes? on-file 4) + (on-file s fp kind val) + (on-file s fp val))]) + (exhaust-port control) + (loop next-val)))))] + [else (error "unknown file tag" kind)])]))))) + +;; path-descriptor ::= 'same | (list location path) +;; location ::= symbol in '(same collects doc lib include) + +;; expr->path-descriptor : sexpr -> path-descriptor +;; extracts a path-descriptor from an sexpr embedded in a .plt file +;; raises an error if the given sexpr can't be converted to a path descriptor +(define (expr->path-descriptor v) + (cond + [(null? v) 'same] + [(and (pair? v) (symbol? (car v)) (symbol=? (car v) 'same)) + (list 'same (apply build-path 'same (cdr v)))] + [(and (pair? v) (string? (car v))) + (let ([location (string->loc (car v))]) + (if (eq? location 'relative) + (apply build-path v) + (list location (apply build-path (cdr v)))))] + [else (error "malformed path description: " v)])) + +;; string->loc : string -> location +;; converts the string into a corresponding location, or raises an error +;; if that is not possible +(define (string->loc str) + (let ([loc (string->symbol str)]) (cond - [(null? v) 'same] - [(and (pair? v) (symbol? (car v)) (symbol=? (car v) 'same)) - (list 'same (apply build-path 'same (cdr v)))] - [(and (pair? v) (string? (car v))) - (let ([location (string->loc (car v))]) - (list location (apply build-path (cdr v))))] - [else (error "malformed path description: " v)])) + [(memq loc '(collects doc lib include same)) loc] + [else 'relative]))) - ;; string->loc : string -> location - ;; converts the string into a corresponding location, or raises an error - ;; if that is not possible - (define (string->loc str) - (let ([loc (string->symbol str)]) - (cond - [(memq loc '(collects doc lib include same)) loc] - [else (error "unknown path root: " loc)]))) - - ;; relative-path-descriptor? : path-descriptor -> boolean - ;; determines if the given path descriptor names a relative file rather - ;; than an absolute one - (define (relative-path-descriptor? s) - (or (eq? s 'same) (relative-path? (cadr s)))) - - ;; protected-limited-output-port input-port n -> (values input-port input-port) - ;; returns two input ports. the first reads from the given input port, and the second - ;; reads from the first. - ;; why would you ever want to do this? So that you can hand out the second, and then - ;; regardless of whether the user closes it or not you still have a limited input port - ;; you can read to exhaustion. - (define (protected-limited-input-port ip limit) - (let* ([i2 (make-limited-input-port ip limit #f)] - [i3 (make-limited-input-port i2 limit #f)]) - (values i2 i3))) - - ;; exhaust-port : input-port -> void - ;; consumes all input on the given port - (define exhaust-port - (let ([nowhere (open-output-nowhere)]) - (λ (ip) (copy-port ip nowhere)))) - - - ;; ------------------------------------------------------------ - +;; relative-path-descriptor? : path-descriptor -> boolean +;; determines if the given path descriptor names a relative file rather +;; than an absolute one +(define (relative-path-descriptor? s) + (or (eq? s 'same) + (and (path? s) (relative-path? s)) + (relative-path? (cadr s)))) - (define (pretty-name f) - (with-handlers ([void (lambda (x) f)]) - (let-values ([(base name dir?) (split-path f)]) - (format "~a in ~a" - (path->string name) - (if (path? base) (path->string base) base))))) +;; protected-limited-output-port input-port n -> (values input-port input-port) +;; returns two input ports. the first reads from the given input port, and the second +;; reads from the first. +;; why would you ever want to do this? So that you can hand out the second, and then +;; regardless of whether the user closes it or not you still have a limited input port +;; you can read to exhaustion. +(define (protected-limited-input-port ip limit) + (let* ([i2 (make-limited-input-port ip limit #f)] + [i3 (make-limited-input-port i2 limit #f)]) + (values i2 i3))) - (define (shuffle-path parent-dir get-dir shuffle? v) - (if shuffle? +;; exhaust-port : input-port -> void +;; consumes all input on the given port +(define exhaust-port + (let ([nowhere (open-output-nowhere)]) + (λ (ip) (copy-port ip nowhere)))) + + +;; ------------------------------------------------------------ + + +(define (pretty-name f) + (with-handlers ([void (lambda (x) f)]) + (let-values ([(base name dir?) (split-path f)]) + (format "~a in ~a" + (path->string name) + (if (path? base) (path->string base) base))))) + +(define (shuffle-path parent-dir get-dir shuffle? v) + (if shuffle? ;; Re-arrange for "collects', etc. (let ([v (remq* '(same) v)]) (if (null? v) - (values #f 'same) - (let ([dir - (case (string->symbol (car v)) - [(collects) (get-dir find-collects-dir find-user-collects-dir)] - [(doc) (get-dir find-doc-dir find-user-doc-dir)] - [(lib) (get-dir find-lib-dir find-user-lib-dir)] - [(include) (get-dir find-include-dir find-user-include-dir)] - [else #f])]) - (if dir - (if (null? (cdr v)) - (values dir 'same) - (values dir (apply build-path (cdr v)))) - (values parent-dir (apply build-path v)))))) + (values #f 'same) + (let ([dir + (case (string->symbol (car v)) + [(collects) (get-dir find-collects-dir find-user-collects-dir)] + [(doc) (get-dir find-doc-dir find-user-doc-dir)] + [(lib) (get-dir find-lib-dir find-user-lib-dir)] + [(include) (get-dir find-include-dir find-user-include-dir)] + [else #f])]) + (if dir + (if (null? (cdr v)) + (values dir 'same) + (values dir (apply build-path (cdr v)))) + (values parent-dir (apply build-path v)))))) (values parent-dir (if (null? v) 'same (apply build-path v))))) - (define (unmztar p filter parent-dir get-dir shuffle? print-status) - (define bufsize 4096) - (define buffer (make-bytes bufsize)) - (let loop () - (let ([kind (read p)]) - (unless (eof-object? kind) - (case kind - [(dir) (let-values ([(target-dir s) - (shuffle-path parent-dir get-dir shuffle? (read p))]) - (unless (or (eq? s 'same) (relative-path? s)) - (error "expected a directory name relative path string, got" s)) - (when (or (eq? s 'same) (filter 'dir s target-dir)) - (let ([d (build-path target-dir s)]) - (unless (directory-exists? d) - (print-status - (format " making directory ~a" (pretty-name d))) - (make-directory* d)))))] - [(file file-replace) - (let-values ([(target-dir s) - (shuffle-path parent-dir get-dir shuffle? (read p))]) - (unless (relative-path? s) - (error "expected a file name relative path string, got" s)) - (let ([len (read p)]) - (unless (and (number? len) (integer? len)) - (error "expected a file name size, got" len)) - (let* ([write? (filter kind s target-dir)] - [path (build-path target-dir s)]) - (let ([out (and write? - (if (file-exists? path) +(define (unmztar p filter parent-dir get-dir shuffle? print-status) + (define bufsize 4096) + (define buffer (make-bytes bufsize)) + (let loop () + (let ([kind (read p)]) + (unless (eof-object? kind) + (case kind + [(dir) (let-values ([(target-dir s) + (shuffle-path parent-dir get-dir shuffle? (read p))]) + (unless (or (eq? s 'same) (relative-path? s)) + (error "expected a directory name relative path string, got" s)) + (when (or (eq? s 'same) (filter 'dir s target-dir)) + (let ([d (build-path target-dir s)]) + (unless (directory-exists? d) + (print-status + (format " making directory ~a" (pretty-name d))) + (make-directory* d)))))] + [(file file-replace) + (let-values ([(target-dir s) + (shuffle-path parent-dir get-dir shuffle? (read p))]) + (unless (relative-path? s) + (error "expected a file name relative path string, got" s)) + (let ([len (read p)]) + (unless (and (number? len) (integer? len)) + (error "expected a file name size, got" len)) + (let* ([write? (filter kind s target-dir)] + [path (build-path target-dir s)]) + (let ([out (and write? + (if (file-exists? path) (if (eq? kind 'file) - #f - (open-output-file path 'truncate)) + #f + (open-output-file path 'truncate)) (open-output-file path)))]) - (when (and write? (not out)) - (print-status (format " skipping ~a; already exists" (pretty-name path)))) - (when out - (print-status (format " unpacking ~a" (pretty-name path)))) - ;; Find starting * - (let loop () - (let ([c (read-char p)]) - (cond [(char=? c #\*) (void)] ; found it - [(char-whitespace? c) (loop)] - [(eof-object? c) (void)] ; signal the error below - [else (error - (format "unexpected character setting up ~a, looking for *" - path) - c)]))) - ;; Copy file data - (let loop ([n len]) - (unless (zero? n) - (let ([l (read-bytes! buffer p 0 (min n bufsize))]) - (when (eof-object? l) - (error (format - "unexpected end-of-file while ~a ~a (at ~a of ~a)" - (if out "unpacking" "skipping") - path - (- len n -1) len))) - (when out (write-bytes buffer out 0 l)) - (loop (- n l))))) - (when out (close-output-port out))))))] - [else (error "unknown file tag" kind)]) - (loop))))) + (when (and write? (not out)) + (print-status (format " skipping ~a; already exists" (pretty-name path)))) + (when out + (print-status (format " unpacking ~a" (pretty-name path)))) + ;; Find starting * + (let loop () + (let ([c (read-char p)]) + (cond [(char=? c #\*) (void)] ; found it + [(char-whitespace? c) (loop)] + [(eof-object? c) (void)] ; signal the error below + [else (error + (format "unexpected character setting up ~a, looking for *" + path) + c)]))) + ;; Copy file data + (let loop ([n len]) + (unless (zero? n) + (let ([l (read-bytes! buffer p 0 (min n bufsize))]) + (when (eof-object? l) + (error (format + "unexpected end-of-file while ~a ~a (at ~a of ~a)" + (if out "unpacking" "skipping") + path + (- len n -1) len))) + (when out (write-bytes buffer out 0 l)) + (loop (- n l))))) + (when out (close-output-port out))))))] + [else (error "unknown file tag" kind)]) + (loop))))) - (define (call-info info flag mk-default test) - (if info +(define (call-info info flag mk-default test) + (if info (let ([v (info flag mk-default)]) (test v) v) (mk-default))) - (define unpack - (opt-lambda (archive [main-collects-parent-dir (current-directory)] - [print-status (lambda (x) (printf "~a\n" x))] - [get-target-directory (lambda () (current-directory))] - [force? #f] - [get-target-plt-directory - (lambda (preferred main-collects-parent-dir options) - preferred)]) - (let*-values ([(p64gz) (open-input-file archive)] - [(p kill) (port64gz->port p64gz)]) - (dynamic-wind - void - (lambda () - (unless (and (eq? #\P (read-char p)) - (eq? #\L (read-char p)) - (eq? #\T (read-char p))) - (error "not an unpackable distribution archive")) - (let* ([n (make-namespace)] - [info (let ([orig (current-namespace)]) - (parameterize ([current-namespace n]) - (namespace-require '(lib "mzlib/unit200.ss")) - (eval (read p))))]) - (unless (and (procedure? info) - (procedure-arity-includes? info 2)) - (error "expected a procedure of arity 2, got" info)) - (let ([name (call-info info 'name (lambda () #f) - (lambda (n) - (unless (string? n) - (if n - (error "couldn't find the package name") - (error "expected a string")))))] - [unpacker (call-info info 'unpacker (lambda () #f) - (lambda (n) - (unless (eq? n 'mzscheme) - (error "unpacker isn't mzscheme:" n))))] - [target-dir-info - (let ([rel? (call-info info 'plt-relative? (lambda () #f) values)] - [not-user-rel? (call-info info 'plt-home-relative? (lambda () #f) values)] - [test-dirs (call-info info 'test-plt-dirs (lambda () #f) values)]) - (if rel? - ;; Shuffling... - (if (and not-user-rel? - ;; Check for void because old unpacker didn't use - ;; the failure thunk. - (not (void? not-user-rel?)) - ;; Non-user optional if test-dirs are writable - (or (not test-dirs) - (andmap - (lambda (p) - (and (string? p) - (let ([dir (let-values ([(base dir) - (shuffle-path main-collects-parent-dir - (lambda (a b) (a)) - #t (list p))]) - (build-path base dir))]) - (memq 'write - (with-handlers ([exn:fail:filesystem? (lambda (x) null)]) - (file-or-directory-permissions dir)))))) - test-dirs))) - ;; Shuffle to main directory always: - (let ([dir (get-target-plt-directory main-collects-parent-dir - main-collects-parent-dir - (list main-collects-parent-dir))]) - (list dir (lambda (sys user) - (let ([a (sys)]) - (get-target-plt-directory a a (list a)))))) - ;; Prefer to shuffle to user directory: - (let ([addons (find-user-collects-dir)]) - (let ([dir (get-target-plt-directory - addons - main-collects-parent-dir - (list addons main-collects-parent-dir))]) - (list dir (lambda (sys user) - (let ([a (sys)] - [b (user)]) - (get-target-plt-directory b a (list b a)))))))) - ;; No shuffling --- install to target directory: - (list (get-target-directory))))]) +(define unpack + (lambda (archive + [main-collects-parent-dir (current-directory)] + [print-status (lambda (x) (printf "~a\n" x))] + [get-target-directory (lambda () (current-directory))] + [force? #f] + [get-target-plt-directory + (lambda (preferred main-collects-parent-dir options) + preferred)]) + (let*-values ([(p64gz) (open-input-file archive)] + [(p kill) (port64gz->port p64gz)]) + (dynamic-wind + void + (lambda () + (unless (and (eq? #\P (read-char p)) + (eq? #\L (read-char p)) + (eq? #\T (read-char p))) + (error "not an unpackable distribution archive")) + (let* ([n (make-namespace)] + [info (let ([orig (current-namespace)]) + (parameterize ([current-namespace n]) + (namespace-require '(lib "mzlib/unit200.ss")) + (eval (read p))))]) + (unless (and (procedure? info) + (procedure-arity-includes? info 2)) + (error "expected a procedure of arity 2, got" info)) + (let ([name (call-info info 'name (lambda () #f) + (lambda (n) + (unless (string? n) + (if n + (error "couldn't find the package name") + (error "expected a string")))))] + [unpacker (call-info info 'unpacker (lambda () #f) + (lambda (n) + (unless (eq? n 'mzscheme) + (error "unpacker isn't mzscheme:" n))))] + [target-dir-info + (let ([rel? (call-info info 'plt-relative? (lambda () #f) values)] + [not-user-rel? (call-info info 'plt-home-relative? (lambda () #f) values)] + [test-dirs (call-info info 'test-plt-dirs (lambda () #f) values)]) + (if rel? + ;; Shuffling... + (if (and not-user-rel? + ;; Check for void because old unpacker didn't use + ;; the failure thunk. + (not (void? not-user-rel?)) + ;; Non-user optional if test-dirs are writable + (or (not test-dirs) + (andmap + (lambda (p) + (and (string? p) + (let ([dir (let-values ([(base dir) + (shuffle-path main-collects-parent-dir + (lambda (a b) (a)) + #t (list p))]) + (build-path base dir))]) + (memq 'write + (with-handlers ([exn:fail:filesystem? (lambda (x) null)]) + (file-or-directory-permissions dir)))))) + test-dirs))) + ;; Shuffle to main directory always: + (let ([dir (get-target-plt-directory main-collects-parent-dir + main-collects-parent-dir + (list main-collects-parent-dir))]) + (list dir (lambda (sys user) + (let ([a (sys)]) + (get-target-plt-directory a a (list a)))))) + ;; Prefer to shuffle to user directory: + (let ([addons (find-user-collects-dir)]) + (let ([dir (get-target-plt-directory + addons + main-collects-parent-dir + (list addons main-collects-parent-dir))]) + (list dir (lambda (sys user) + (let ([a (sys)] + [b (user)]) + (get-target-plt-directory b a (list b a)))))))) + ;; No shuffling --- install to target directory: + (list (get-target-directory))))]) - ;; Stop if no target directory: - (if (car target-dir-info) + ;; Stop if no target directory: + (if (car target-dir-info) - ;; Check declared dependencies (none means v103) - (begin - (call-info info 'requires (lambda () null) - (lambda (l) - (define (bad) - (error "`requires' info is corrupt:" l)) - (when (void? l) - (if force? - (print-status "warning: archive is for an older version of PLT Scheme") - (error "cannot install; archive is for an older version of PLT Scheme"))) - (unless (or (list? l) (and force? (void? l))) - (bad)) - ;; Check each dependency: - (when (list? l) - (for-each - (lambda (d) - (unless (and (list? d) (= 2 (length d))) - (bad)) - (let ([coll-path (car d)] - [version (cadr d)]) - (unless (and (pair? coll-path) - (list? coll-path) - (andmap string? coll-path) - (list? version) - (andmap number? version)) - (bad)) - (with-handlers ([exn:fail:filesystem? - (lambda (x) - (if force? - (print-status - (format "warning: missing required collection ~s" coll-path)) - (error "cannot install; missing required collection" coll-path)))]) - (apply collection-path coll-path)) - (let ([inst-version - (with-handlers ([void (lambda (x) - (if (exn:break? x) - (raise x) - null))]) - (let ([info (get-info coll-path)]) - (info 'version (lambda () null))))]) - (let loop ([v version][iv inst-version]) - (unless (null? v) - (when (or (null? iv) - (not (= (car v) (car iv)))) - (let ([msg (format "version ~a of collection ~s is required, but version ~a is installed" - version coll-path - (if (null? inst-version) - ' - inst-version))]) - (if force? - (print-status (format "warning: ~a" msg)) - (error (format "cannot install; ~a" msg))))) - (loop (cdr v) (cdr iv))))))) - l)))) + ;; Check declared dependencies (none means v103) + (begin + (call-info + info 'requires (lambda () null) + (lambda (l) + (define (bad) + (error "`requires' info is corrupt:" l)) + (when (void? l) + (if force? + (print-status "warning: archive is for an older version of Racket") + (error "cannot install; archive is for an older version of Racket"))) + (unless (or (list? l) (and force? (void? l))) + (bad)) + ;; Check each dependency: + (when (list? l) + (for-each + (lambda (d) + (unless (and (list? d) (= 2 (length d))) + (bad)) + (let ([coll-path (car d)] + [version (cadr d)]) + (unless (and (pair? coll-path) + (list? coll-path) + (andmap string? coll-path) + (list? version) + (andmap number? version)) + (bad)) + (with-handlers ([exn:fail:filesystem? + (lambda (x) + (if force? + (print-status + (format "warning: missing required collection ~s" coll-path)) + (error "cannot install; missing required collection" coll-path)))]) + (apply collection-path coll-path)) + (let ([inst-version + (with-handlers ([void (lambda (x) + (if (exn:break? x) + (raise x) + null))]) + (let ([info (get-info coll-path)]) + (info 'version (lambda () null))))]) + (let loop ([v version][iv inst-version]) + (unless (null? v) + (when (or (null? iv) + (not (= (car v) (car iv)))) + (let ([msg (format "version ~a of collection ~s is required, but version ~a is installed" + version coll-path + (if (null? inst-version) + ' + inst-version))]) + (if force? + (print-status (format "warning: ~a" msg)) + (error (format "cannot install; ~a" msg))))) + (loop (cdr v) (cdr iv))))))) + l)))) - ;; Check for conflicts: - (call-info info 'conflicts (lambda () null) - (lambda (l) - (define (bad) - (error "`conflicts' info is corrupt:" l)) - (unless (or (list? l) (and force? (void? l))) - (bad)) - (when (list? l) - (for-each - (lambda (coll-path) - (unless (and (pair? coll-path) - (list? coll-path) - (andmap string? coll-path)) - (bad)) - (when (with-handlers ([exn:fail? (lambda (x) #f)]) - (apply collection-path coll-path)) - (error "cannot install; conflict with installed collection" - coll-path))) - l)))) + ;; Check for conflicts: + (call-info + info 'conflicts (lambda () null) + (lambda (l) + (define (bad) + (error "`conflicts' info is corrupt:" l)) + (unless (or (list? l) (and force? (void? l))) + (bad)) + (when (list? l) + (for-each + (lambda (coll-path) + (unless (and (pair? coll-path) + (list? coll-path) + (andmap string? coll-path)) + (bad)) + (when (with-handlers ([exn:fail? (lambda (x) #f)]) + (apply collection-path coll-path)) + (error "cannot install; conflict with installed collection" + coll-path))) + l)))) + + (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)))) - (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)))) - - ;; Cancelled: no collections - null)))) - (lambda () (kill) (close-input-port p64gz))))))) + ;; Cancelled: no collections + null)))) + (lambda () (kill) (close-input-port p64gz))))))