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

add `raco unpack'

Browse Source 
Although the ".plt" format is going to be replaced, the format is
currently viable for distributing collections, and I have wanted
a raw `unpack' command for a while. It was useful today to fix
problems with `raco pack' and collection links.
This commit is contained in:
Matthew Flatt 2011-08-24 14:18:38 -06:00
parent ee17f7ce47
commit 2dbaa45e1b
8 changed files with 904 additions and 735 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

1
collects/compiler/commands/info.rkt
View File

@ -4,6 +4,7 @@
'(("make" compiler/commands/make "compile source to bytecode" 100) '(("make" compiler/commands/make "compile source to bytecode" 100)
("exe" compiler/commands/exe "create executable" 20) ("exe" compiler/commands/exe "create executable" 20)
("pack" compiler/commands/pack "pack files/collections into a .plt archive" 10) ("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) ("decompile" compiler/commands/decompile "decompile bytecode" #f)
("expand" compiler/commands/expand "macro-expand source" #f) ("expand" compiler/commands/expand "macro-expand source" #f)
("distribute" compiler/commands/exe-dir "prepare executable(s) in a directory for distribution" #f) ("distribute" compiler/commands/exe-dir "prepare executable(s) in a directory for distribution" #f)

102
collects/compiler/commands/unpack.rkt Normal file
View File

@ -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)))

176
collects/scribblings/raco/plt.scrbl
View File

@ -1,7 +1,10 @@
#lang scribble/doc #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, @margin-note{Before creating a @filepath{.plt} archive to distribute,
consider instead posting your package on 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 library files to Racket users. A distribution archive usually has the
suffix @as-index{@filepath{.plt}}, which DrRacket recognizes as an suffix @as-index{@filepath{.plt}}, which DrRacket recognizes as an
archive to provide automatic unpacking facilities. The @exec{raco 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: 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 is installed, and that @filepath{mred} has the same version as when
@filepath{sirmail.plt} was created. @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 @defmodule[setup/pack]{Although the @exec{raco pack} command can be
used to create most @filepath{.plt} files, the used to create most @filepath{.plt} files, the
@ -192,6 +349,7 @@ making @filepath{.plt} archives.}
(dest path-string?) (dest path-string?)
(name string?) (name string?)
(paths (listof path-string?)) (paths (listof path-string?))
[#:as-paths as-paths (listof path-string?) paths]
[#:file-filter filter-proc [#:file-filter filter-proc
(path-string? . -> . boolean?) std-filter] (path-string? . -> . boolean?) std-filter]
[#:encode? encode? boolean? #t] [#: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 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 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 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 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 candidate for packing. If it returns @racket[#f] for some path, then that
@ -306,12 +467,15 @@ making @filepath{.plt} archives.}
@litchar{[.]plt$}.} @litchar{[.]plt$}.}
@defproc[(mztar (path path-string?) @defproc[(mztar (path path-string?)
[#:as-path path path-string? path]
(output output-port?) (output output-port?)
(filter (path-string? . -> . boolean?)) (filter (path-string? . -> . boolean?))
(file-mode (symbols 'file 'file-replace))) void?]{ (file-mode (symbols 'file 'file-replace))) void?]{
Called by @racket[pack] to write one directory/file @racket[path] to the Called by @racket[pack] to write one directory/file @racket[path] to the
output port @racket[output] using the filter procedure @racket[filter] 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, @racket[file-mode] argument specifies the default mode for packing a file,
either @racket['file] or @racket['file-replace].} either @racket['file] or @racket['file-replace].}

1
collects/scribblings/raco/raco.scrbl
View File

@ -20,6 +20,7 @@ a typical Racket installation.
@include-section["exe.scrbl"] @include-section["exe.scrbl"]
@include-section["dist.scrbl"] @include-section["dist.scrbl"]
@include-section["plt.scrbl"] @include-section["plt.scrbl"]
@include-section["unpack.scrbl"]
@include-section["planet.scrbl"] @include-section["planet.scrbl"]
@include-section["setup.scrbl"] @include-section["setup.scrbl"]
@include-section["decompile.scrbl"] @include-section["decompile.scrbl"]

254
collects/scribblings/raco/setup.scrbl
View File

@ -584,14 +584,12 @@ form.}
@section[#:tag ".plt-archives"]{API for Installing @filepath{.plt} Archives} @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 The @racketmodname[setup/plt-single-installer] module provides a
function for installing a single @filepath{.plt} file, and function for installing a single @filepath{.plt} file, and
@racketmodname[setup/plt-installer] wraps it with a GUI @racketmodname[setup/plt-installer] wraps it with a GUI
interface. interface.
@subsubsection{Non-GUI Installer} @subsection{Non-GUI Installer}
@local-module[setup/plt-single-installer]{ @local-module[setup/plt-single-installer]{
@ -643,7 +641,7 @@ v
should be run after a set of @|PLaneT| packages are removed.}} 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 @defmodule[setup/plt-installer]{ The
@racketmodname[setup/plt-installer] library in the setup collection @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]{ @defmodule[setup/plt-installer-sig]{
@defsignature[setup:plt-installer^ ()]{ @defsignature[setup:plt-installer^ ()]{
@ -692,256 +690,12 @@ v
@; ---------------------------------------- @; ----------------------------------------
@subsubsection{GUI Unpacking Unit} @subsection{GUI Unpacking Unit}
@defmodule[setup/plt-installer-unit]{ @defmodule[setup/plt-installer-unit]{
Imports @racket[mred^] and exports @racket[setup:plt-installer^]. } 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} @section[#:tag "dirs"]{API for Finding Installation Directories}

123
collects/scribblings/raco/unpack.scrbl Normal file
View File

@ -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.}

180
collects/setup/pack.rkt
View File

@ -40,6 +40,7 @@
#:at-plt-home? at-plt-home?)) #:at-plt-home? at-plt-home?))
(define (pack-plt dest name paths (define (pack-plt dest name paths
#:as-paths [as-paths paths]
#:collections [collections null] #:collections [collections null]
#:file-filter [file-filter std-filter] #:file-filter [file-filter std-filter]
#:encode? [encode? #t] #:encode? [encode? #t]
@ -125,56 +126,84 @@
(quote ,collections))) (quote ,collections)))
fileout) fileout)
(newline fileout) (newline fileout)
(for-each (lambda (path) (for-each (lambda (path as-path)
(mztar (simplify-path path #f) fileout file-filter file-mode)) (mztar (simplify-path path #f) #:as-path (simplify-path as-path #f)
paths) fileout file-filter file-mode))
paths as-paths)
(close-output-port fileout) (close-output-port fileout)
(thread-wait thd))) (thread-wait thd)))
(define (element->string x) (define (element->string x)
(if (path? x) (path->string x) 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) (define (path->list p)
(if (eq? p 'same) (if (eq? p 'same)
null null
(let-values ([(base name dir?) (split-path p)]) (let-values ([(base name dir?) (split-path p)])
(if (path? base) (if (path? base)
(append (path->list base) (list name)) (append (path->list base) (list name))
(list name))))) (list name)))))
(define-values (init-dir init-files) (define-values (init-dir init-as-dir init-files init-as-files)
(if (file-exists? path) (if (file-exists? path)
(let-values ([(base name dir?) (split-path path)]) (let*-values ([(base name dir?) (split-path path)]
(values (if (eq? base 'relative) 'same base) (list name))) [(as-base as-name as-dir?) (if as-path
(values (if (string? path) (string->path path) path) #f))) (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]) (let loop ([dir init-dir] [dpath (path->list init-dir)]
(printf "MzTarring ~a...\n" [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 (path->string
(if files (if files
(build-path dir (car files)) (build-path dir (car files))
dir))) dir))
(fprintf output "~s\n~s\n" 'dir (map element->string dpath)) (if (not (equal? path as-path))
(for-each (format " as ~a"
(lambda (f) (if as-files
(let* ([p (build-path dir f)] (build-path as-dir (car as-files))
[filter-val (file-filter p)]) as-dir))
(when filter-val ""))
(if (directory-exists? p) (fprintf output "~s\n~s\n" 'dir (map element->string as-dpath))
(loop p (append dpath (list f)) #f) (let* ([files (or files (sort (map element->string (directory-list dir)) string<?))]
(let ([len (file-size p)]) [as-files (or as-files files)])
;; (printf "MzTarring ~a\n" p) (for ([f (in-list files)]
(fprintf output "~s\n~s\n~s\n*" [as-f (in-list as-files)])
(case filter-val (let* ([p (build-path dir f)]
[(file) 'file] [filter-val (file-filter p)])
[(file-replace) 'file-replace] (when filter-val
[else file-mode]) (if (directory-exists? p)
(map element->string (append dpath (list f))) (loop p
len) (append dpath (list f))
(call-with-input-file* p (build-path as-dir f)
(lambda (p) (copy-port p output)))))))) (append as-dpath (list f))
(or files (sort (map element->string (directory-list dir)) string<?))))) #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 as-dpath (list as-f)))
len)
(call-with-input-file*
p
(lambda (p) (copy-port p output)))))))))))
(define (std-filter path) (define (std-filter path)
(let-values ([(base name dir?) (split-path path)]) (let-values ([(base name dir?) (split-path path)])
(let ([name (path->bytes name)]) (let ([name (path->bytes name)])
@ -198,31 +227,16 @@
#:at-plt-home? [at-plt-home? #f] #:at-plt-home? [at-plt-home? #f]
#:test-plt-collects? [test-plt-collects? #t]) #:test-plt-collects? [test-plt-collects? #t])
(let-values (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)]) (let ([dirs (map (lambda (cp) (apply collection-path cp)) collections)])
;; Figure out the base path: ;; Figure out the base path:
(let* ([base-path #f] (let* ([base-path #f]
[base-path-setter #f] [base-path-setter #f]
[paths dirs]
[rel-paths [rel-paths
(map (lambda (dir coll) (map (lambda (coll)
(let*-values ([(base c-name dir?) (split-path dir)] (build-path "collects" (apply build-path coll)))
[(base subdir) collections)]
(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)]
[infos (map (lambda (cp) (get-info cp)) collections)] [infos (map (lambda (cp) (get-info cp)) collections)]
[coll-list? [coll-list?
(lambda (cl) (lambda (cl)
@ -244,7 +258,7 @@
which src-cp)) which src-cp))
rl)) rl))
infos collections)))]) infos collections)))])
(values base-path (values paths
rel-paths rel-paths
(get-dep-coll 'requires) (get-dep-coll 'requires)
(append (if replace? null collections) (append (if replace? null collections)
@ -254,21 +268,21 @@
'name 'name
(lambda () (caar collections)))))))]) (lambda () (caar collections)))))))])
(let ([output (path->complete-path output)]) (let ([output (path->complete-path output)])
(parameterize ([current-directory dir]) (pack-plt
(pack-plt output name
output name source-files
source-files #:as-paths as-source-files
#:collections (append extra-setup-collections #:collections (append extra-setup-collections
(filter get-info collections)) (filter get-info collections))
#:file-filter file-filter #:file-filter file-filter
#:file-mode (if replace? 'file-replace 'file) #:file-mode (if replace? 'file-replace 'file)
#:plt-relative? #t #:plt-relative? #t
#:requires #:requires
;; For each require, get current version ;; For each require, get current version
(map (lambda (r) (map (lambda (r)
(let ([i (get-info r)]) (let ([i (get-info r)])
(let ([v (and i (i 'version (lambda () #f)))]) (let ([v (and i (i 'version (lambda () #f)))])
(if v (if v
(begin (begin
(unless (and (list? v) (unless (and (list? v)
(andmap number? v) (andmap number? v)
@ -280,13 +294,13 @@
r)) r))
(list r v)) (list r v))
(list r null))))) (list r null)))))
requires requires
;; Packer used to automatically include "mzscheme" ;; Packer used to automatically include "mzscheme"
;; dependency, but we've conlcuded that dependencies ;; dependency, but we've conlcuded that dependencies
;; aren't typically useful. ;; aren't typically useful.
#; #;
(cons '("mzscheme") requires)) (cons '("mzscheme") requires))
#:conflicts conflicts #:conflicts conflicts
#:at-plt-home? at-plt-home? #:at-plt-home? at-plt-home?
#:test-plt-dirs (and at-plt-home? test-plt-collects? #:test-plt-dirs (and at-plt-home? test-plt-collects?
'("collects")))))))) '("collects")))))))

802
collects/setup/unpack.rkt
View File

@ -1,426 +1,436 @@
(module unpack mzscheme #lang racket/base
(require mzlib/etc (require file/gunzip
mzlib/inflate racket/file
mzlib/file racket/list
mzlib/list racket/port
mzlib/port racket/bool
net/base64 net/base64
setup/getinfo setup/getinfo
"dirs.rkt") "dirs.rkt"
(only-in mzscheme make-namespace))
(provide unpack (provide unpack
fold-plt-archive) fold-plt-archive)
;; ---------------------------------------- ;; ----------------------------------------
;; Returns a port and a kill thunk ;; Returns a port and a kill thunk
(define (port64gz->port p64gz) (define (port64gz->port p64gz)
;; Inflate in a thread so the whole input isn't read at once ;; Inflate in a thread so the whole input isn't read at once
(let-values ([(base64-out base64-in) (make-pipe 4096)] (let-values ([(base64-out base64-in) (make-pipe 4096)]
[(guz-out guz-in) (make-pipe 4096)]) [(guz-out guz-in) (make-pipe 4096)])
(let ([64t (let ([64t
(thread (lambda () (thread (lambda ()
(dynamic-wind (dynamic-wind
void void
(lambda () (base64-decode-stream p64gz base64-in)) (lambda () (base64-decode-stream p64gz base64-in))
(lambda () (close-output-port base64-in)))))] (lambda () (close-output-port base64-in)))))]
[gzt [gzt
(thread (lambda () (thread (lambda ()
(dynamic-wind (dynamic-wind
void void
(lambda () (gunzip-through-ports base64-out guz-in)) (lambda () (gunzip-through-ports base64-out guz-in))
(lambda () (close-output-port guz-in)))))]) (lambda () (close-output-port guz-in)))))])
(values guz-out (lambda () (kill-thread 64t) (kill-thread gzt)))))) (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)
;; 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 ;; 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 (expr->path-descriptor v) (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 (cond
[(null? v) 'same] [(memq loc '(collects doc lib include same)) loc]
[(and (pair? v) (symbol? (car v)) (symbol=? (car v) 'same)) [else 'relative])))
(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)]))
;; string->loc : string -> location ;; relative-path-descriptor? : path-descriptor -> boolean
;; converts the string into a corresponding location, or raises an error ;; determines if the given path descriptor names a relative file rather
;; if that is not possible ;; than an absolute one
(define (string->loc str) (define (relative-path-descriptor? s)
(let ([loc (string->symbol str)]) (or (eq? s 'same)
(cond (and (path? s) (relative-path? s))
[(memq loc '(collects doc lib include same)) loc] (relative-path? (cadr s))))
[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))))
;; ------------------------------------------------------------
(define (pretty-name f) ;; protected-limited-output-port input-port n -> (values input-port input-port)
(with-handlers ([void (lambda (x) f)]) ;; returns two input ports. the first reads from the given input port, and the second
(let-values ([(base name dir?) (split-path f)]) ;; reads from the first.
(format "~a in ~a" ;; why would you ever want to do this? So that you can hand out the second, and then
(path->string name) ;; regardless of whether the user closes it or not you still have a limited input port
(if (path? base) (path->string base) base))))) ;; 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) ;; exhaust-port : input-port -> void
(if shuffle? ;; 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. ;; Re-arrange for "collects', etc.
(let ([v (remq* '(same) v)]) (let ([v (remq* '(same) v)])
(if (null? v) (if (null? v)
(values #f 'same) (values #f 'same)
(let ([dir (let ([dir
(case (string->symbol (car v)) (case (string->symbol (car v))
[(collects) (get-dir find-collects-dir find-user-collects-dir)] [(collects) (get-dir find-collects-dir find-user-collects-dir)]
[(doc) (get-dir find-doc-dir find-user-doc-dir)] [(doc) (get-dir find-doc-dir find-user-doc-dir)]
[(lib) (get-dir find-lib-dir find-user-lib-dir)] [(lib) (get-dir find-lib-dir find-user-lib-dir)]
[(include) (get-dir find-include-dir find-user-include-dir)] [(include) (get-dir find-include-dir find-user-include-dir)]
[else #f])]) [else #f])])
(if dir (if dir
(if (null? (cdr v)) (if (null? (cdr v))
(values dir 'same) (values dir 'same)
(values dir (apply build-path (cdr v)))) (values dir (apply build-path (cdr v))))
(values parent-dir (apply build-path v)))))) (values parent-dir (apply build-path v))))))
(values parent-dir (if (null? v) 'same (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 (unmztar p filter parent-dir get-dir shuffle? print-status)
(define bufsize 4096) (define bufsize 4096)
(define buffer (make-bytes bufsize)) (define buffer (make-bytes bufsize))
(let loop () (let loop ()
(let ([kind (read p)]) (let ([kind (read p)])
(unless (eof-object? kind) (unless (eof-object? kind)
(case kind (case kind
[(dir) (let-values ([(target-dir s) [(dir) (let-values ([(target-dir s)
(shuffle-path parent-dir get-dir shuffle? (read p))]) (shuffle-path parent-dir get-dir shuffle? (read p))])
(unless (or (eq? s 'same) (relative-path? s)) (unless (or (eq? s 'same) (relative-path? s))
(error "expected a directory name relative path string, got" s)) (error "expected a directory name relative path string, got" s))
(when (or (eq? s 'same) (filter 'dir s target-dir)) (when (or (eq? s 'same) (filter 'dir s target-dir))
(let ([d (build-path target-dir s)]) (let ([d (build-path target-dir s)])
(unless (directory-exists? d) (unless (directory-exists? d)
(print-status (print-status
(format " making directory ~a" (pretty-name d))) (format " making directory ~a" (pretty-name d)))
(make-directory* d)))))] (make-directory* d)))))]
[(file file-replace) [(file file-replace)
(let-values ([(target-dir s) (let-values ([(target-dir s)
(shuffle-path parent-dir get-dir shuffle? (read p))]) (shuffle-path parent-dir get-dir shuffle? (read p))])
(unless (relative-path? s) (unless (relative-path? s)
(error "expected a file name relative path string, got" s)) (error "expected a file name relative path string, got" s))
(let ([len (read p)]) (let ([len (read p)])
(unless (and (number? len) (integer? len)) (unless (and (number? len) (integer? len))
(error "expected a file name size, got" len)) (error "expected a file name size, got" len))
(let* ([write? (filter kind s target-dir)] (let* ([write? (filter kind s target-dir)]
[path (build-path target-dir s)]) [path (build-path target-dir s)])
(let ([out (and write? (let ([out (and write?
(if (file-exists? path) (if (file-exists? path)
(if (eq? kind 'file) (if (eq? kind 'file)
#f #f
(open-output-file path 'truncate)) (open-output-file path 'truncate))
(open-output-file path)))]) (open-output-file path)))])
(when (and write? (not out)) (when (and write? (not out))
(print-status (format " skipping ~a; already exists" (pretty-name path)))) (print-status (format " skipping ~a; already exists" (pretty-name path))))
(when out (when out
(print-status (format " unpacking ~a" (pretty-name path)))) (print-status (format " unpacking ~a" (pretty-name path))))
;; Find starting * ;; Find starting *
(let loop () (let loop ()
(let ([c (read-char p)]) (let ([c (read-char p)])
(cond [(char=? c #\*) (void)] ; found it (cond [(char=? c #\*) (void)] ; found it
[(char-whitespace? c) (loop)] [(char-whitespace? c) (loop)]
[(eof-object? c) (void)] ; signal the error below [(eof-object? c) (void)] ; signal the error below
[else (error [else (error
(format "unexpected character setting up ~a, looking for *" (format "unexpected character setting up ~a, looking for *"
path) path)
c)]))) c)])))
;; Copy file data ;; Copy file data
(let loop ([n len]) (let loop ([n len])
(unless (zero? n) (unless (zero? n)
(let ([l (read-bytes! buffer p 0 (min n bufsize))]) (let ([l (read-bytes! buffer p 0 (min n bufsize))])
(when (eof-object? l) (when (eof-object? l)
(error (format (error (format
"unexpected end-of-file while ~a ~a (at ~a of ~a)" "unexpected end-of-file while ~a ~a (at ~a of ~a)"
(if out "unpacking" "skipping") (if out "unpacking" "skipping")
path path
(- len n -1) len))) (- len n -1) len)))
(when out (write-bytes buffer out 0 l)) (when out (write-bytes buffer out 0 l))
(loop (- n l))))) (loop (- n l)))))
(when out (close-output-port out))))))] (when out (close-output-port out))))))]
[else (error "unknown file tag" kind)]) [else (error "unknown file tag" kind)])
(loop))))) (loop)))))
(define (call-info info flag mk-default test) (define (call-info info flag mk-default test)
(if info (if info
(let ([v (info flag mk-default)]) (test v) v) (let ([v (info flag mk-default)]) (test v) v)
(mk-default))) (mk-default)))
(define unpack (define unpack
(opt-lambda (archive [main-collects-parent-dir (current-directory)] (lambda (archive
[print-status (lambda (x) (printf "~a\n" x))] [main-collects-parent-dir (current-directory)]
[get-target-directory (lambda () (current-directory))] [print-status (lambda (x) (printf "~a\n" x))]
[force? #f] [get-target-directory (lambda () (current-directory))]
[get-target-plt-directory [force? #f]
(lambda (preferred main-collects-parent-dir options) [get-target-plt-directory
preferred)]) (lambda (preferred main-collects-parent-dir options)
(let*-values ([(p64gz) (open-input-file archive)] preferred)])
[(p kill) (port64gz->port p64gz)]) (let*-values ([(p64gz) (open-input-file archive)]
(dynamic-wind [(p kill) (port64gz->port p64gz)])
void (dynamic-wind
(lambda () void
(unless (and (eq? #\P (read-char p)) (lambda ()
(eq? #\L (read-char p)) (unless (and (eq? #\P (read-char p))
(eq? #\T (read-char p))) (eq? #\L (read-char p))
(error "not an unpackable distribution archive")) (eq? #\T (read-char p)))
(let* ([n (make-namespace)] (error "not an unpackable distribution archive"))
[info (let ([orig (current-namespace)]) (let* ([n (make-namespace)]
(parameterize ([current-namespace n]) [info (let ([orig (current-namespace)])
(namespace-require '(lib "mzlib/unit200.ss")) (parameterize ([current-namespace n])
(eval (read p))))]) (namespace-require '(lib "mzlib/unit200.ss"))
(unless (and (procedure? info) (eval (read p))))])
(procedure-arity-includes? info 2)) (unless (and (procedure? info)
(error "expected a procedure of arity 2, got" info)) (procedure-arity-includes? info 2))
(let ([name (call-info info 'name (lambda () #f) (error "expected a procedure of arity 2, got" info))
(lambda (n) (let ([name (call-info info 'name (lambda () #f)
(unless (string? n) (lambda (n)
(if n (unless (string? n)
(error "couldn't find the package name") (if n
(error "expected a string")))))] (error "couldn't find the package name")
[unpacker (call-info info 'unpacker (lambda () #f) (error "expected a string")))))]
(lambda (n) [unpacker (call-info info 'unpacker (lambda () #f)
(unless (eq? n 'mzscheme) (lambda (n)
(error "unpacker isn't mzscheme:" n))))] (unless (eq? n 'mzscheme)
[target-dir-info (error "unpacker isn't mzscheme:" n))))]
(let ([rel? (call-info info 'plt-relative? (lambda () #f) values)] [target-dir-info
[not-user-rel? (call-info info 'plt-home-relative? (lambda () #f) values)] (let ([rel? (call-info info 'plt-relative? (lambda () #f) values)]
[test-dirs (call-info info 'test-plt-dirs (lambda () #f) values)]) [not-user-rel? (call-info info 'plt-home-relative? (lambda () #f) values)]
(if rel? [test-dirs (call-info info 'test-plt-dirs (lambda () #f) values)])
;; Shuffling... (if rel?
(if (and not-user-rel? ;; Shuffling...
;; Check for void because old unpacker didn't use (if (and not-user-rel?
;; the failure thunk. ;; Check for void because old unpacker didn't use
(not (void? not-user-rel?)) ;; the failure thunk.
;; Non-user optional if test-dirs are writable (not (void? not-user-rel?))
(or (not test-dirs) ;; Non-user optional if test-dirs are writable
(andmap (or (not test-dirs)
(lambda (p) (andmap
(and (string? p) (lambda (p)
(let ([dir (let-values ([(base dir) (and (string? p)
(shuffle-path main-collects-parent-dir (let ([dir (let-values ([(base dir)
(lambda (a b) (a)) (shuffle-path main-collects-parent-dir
#t (list p))]) (lambda (a b) (a))
(build-path base dir))]) #t (list p))])
(memq 'write (build-path base dir))])
(with-handlers ([exn:fail:filesystem? (lambda (x) null)]) (memq 'write
(file-or-directory-permissions dir)))))) (with-handlers ([exn:fail:filesystem? (lambda (x) null)])
test-dirs))) (file-or-directory-permissions dir))))))
;; Shuffle to main directory always: test-dirs)))
(let ([dir (get-target-plt-directory main-collects-parent-dir ;; Shuffle to main directory always:
main-collects-parent-dir (let ([dir (get-target-plt-directory main-collects-parent-dir
(list main-collects-parent-dir))]) main-collects-parent-dir
(list dir (lambda (sys user) (list main-collects-parent-dir))])
(let ([a (sys)]) (list dir (lambda (sys user)
(get-target-plt-directory a a (list a)))))) (let ([a (sys)])
;; Prefer to shuffle to user directory: (get-target-plt-directory a a (list a))))))
(let ([addons (find-user-collects-dir)]) ;; Prefer to shuffle to user directory:
(let ([dir (get-target-plt-directory (let ([addons (find-user-collects-dir)])
addons (let ([dir (get-target-plt-directory
main-collects-parent-dir addons
(list addons main-collects-parent-dir))]) main-collects-parent-dir
(list dir (lambda (sys user) (list addons main-collects-parent-dir))])
(let ([a (sys)] (list dir (lambda (sys user)
[b (user)]) (let ([a (sys)]
(get-target-plt-directory b a (list b a)))))))) [b (user)])
;; No shuffling --- install to target directory: (get-target-plt-directory b a (list b a))))))))
(list (get-target-directory))))]) ;; No shuffling --- install to target directory:
(list (get-target-directory))))])
;; Stop if no target directory: ;; Stop if no target directory:
(if (car target-dir-info) (if (car target-dir-info)
;; Check declared dependencies (none means v103) ;; Check declared dependencies (none means v103)
(begin (begin
(call-info info 'requires (lambda () null) (call-info
(lambda (l) info 'requires (lambda () null)
(define (bad) (lambda (l)
(error "`requires' info is corrupt:" l)) (define (bad)
(when (void? l) (error "`requires' info is corrupt:" l))
(if force? (when (void? l)
(print-status "warning: archive is for an older version of PLT Scheme") (if force?
(error "cannot install; archive is for an older version of PLT Scheme"))) (print-status "warning: archive is for an older version of Racket")
(unless (or (list? l) (and force? (void? l))) (error "cannot install; archive is for an older version of Racket")))
(bad)) (unless (or (list? l) (and force? (void? l)))
;; Check each dependency: (bad))
(when (list? l) ;; Check each dependency:
(for-each (when (list? l)
(lambda (d) (for-each
(unless (and (list? d) (= 2 (length d))) (lambda (d)
(bad)) (unless (and (list? d) (= 2 (length d)))
(let ([coll-path (car d)] (bad))
[version (cadr d)]) (let ([coll-path (car d)]
(unless (and (pair? coll-path) [version (cadr d)])
(list? coll-path) (unless (and (pair? coll-path)
(andmap string? coll-path) (list? coll-path)
(list? version) (andmap string? coll-path)
(andmap number? version)) (list? version)
(bad)) (andmap number? version))
(with-handlers ([exn:fail:filesystem? (bad))
(lambda (x) (with-handlers ([exn:fail:filesystem?
(if force? (lambda (x)
(print-status (if force?
(format "warning: missing required collection ~s" coll-path)) (print-status
(error "cannot install; missing required collection" coll-path)))]) (format "warning: missing required collection ~s" coll-path))
(apply collection-path coll-path)) (error "cannot install; missing required collection" coll-path)))])
(let ([inst-version (apply collection-path coll-path))
(with-handlers ([void (lambda (x) (let ([inst-version
(if (exn:break? x) (with-handlers ([void (lambda (x)
(raise x) (if (exn:break? x)
null))]) (raise x)
(let ([info (get-info coll-path)]) null))])
(info 'version (lambda () null))))]) (let ([info (get-info coll-path)])
(let loop ([v version][iv inst-version]) (info 'version (lambda () null))))])
(unless (null? v) (let loop ([v version][iv inst-version])
(when (or (null? iv) (unless (null? v)
(not (= (car v) (car iv)))) (when (or (null? iv)
(let ([msg (format "version ~a of collection ~s is required, but version ~a is installed" (not (= (car v) (car iv))))
version coll-path (let ([msg (format "version ~a of collection ~s is required, but version ~a is installed"
(if (null? inst-version) version coll-path
'<unknown> (if (null? inst-version)
inst-version))]) '<unknown>
(if force? inst-version))])
(print-status (format "warning: ~a" msg)) (if force?
(error (format "cannot install; ~a" msg))))) (print-status (format "warning: ~a" msg))
(loop (cdr v) (cdr iv))))))) (error (format "cannot install; ~a" msg)))))
l)))) (loop (cdr v) (cdr iv)))))))
l))))
;; Check for conflicts: ;; Check for conflicts:
(call-info info 'conflicts (lambda () null) (call-info
(lambda (l) info 'conflicts (lambda () null)
(define (bad) (lambda (l)
(error "`conflicts' info is corrupt:" l)) (define (bad)
(unless (or (list? l) (and force? (void? l))) (error "`conflicts' info is corrupt:" l))
(bad)) (unless (or (list? l) (and force? (void? l)))
(when (list? l) (bad))
(for-each (when (list? l)
(lambda (coll-path) (for-each
(unless (and (pair? coll-path) (lambda (coll-path)
(list? coll-path) (unless (and (pair? coll-path)
(andmap string? coll-path)) (list? coll-path)
(bad)) (andmap string? coll-path))
(when (with-handlers ([exn:fail? (lambda (x) #f)]) (bad))
(apply collection-path coll-path)) (when (with-handlers ([exn:fail? (lambda (x) #f)])
(error "cannot install; conflict with installed collection" (apply collection-path coll-path))
coll-path))) (error "cannot install; conflict with installed collection"
l)))) 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) ;; Cancelled: no collections
(error "bad name or unpacker")) null))))
(print-status (format "Unpacking ~a from ~a" name archive)) (lambda () (kill) (close-input-port p64gz))))))
(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)))))))