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)
("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)

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

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

@ -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"]

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

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

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

178
collects/setup/pack.rkt
View File

@ -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,55 +126,83 @@
(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)) string<?)))))
dir))
(if (not (equal? path as-path))
(format " as ~a"
(if as-files
(build-path as-dir (car as-files))
as-dir))
""))
(fprintf output "~s\n~s\n" 'dir (map element->string as-dpath))
(let* ([files (or files (sort (map element->string (directory-list dir)) string<?))]
[as-files (or as-files files)])
(for ([f (in-list files)]
[as-f (in-list as-files)])
(let* ([p (build-path dir f)]
[filter-val (file-filter p)])
(when filter-val
(if (directory-exists? p)
(loop p
(append dpath (list f))
(build-path as-dir f)
(append as-dpath (list f))
#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)
(let-values ([(base name dir?) (split-path path)])
@ -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")))))))

774
collects/setup/unpack.rkt
View File

@ -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))))))
(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 : 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)
;; 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"))
;; 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)]
(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)])
[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)])])))))
;; 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)
;; 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)
;; 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)
(and (path? s) (relative-path? s))
(relative-path? (cadr s))))
;; 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)))
;; 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))))
;; 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 (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?
(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)
'<unknown>
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)
'<unknown>
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))))))