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

improve support for layered and tethered installations

Browse Source 
Various "config.rktd" options are meant to support creating layers of
installation that builds existing layers. Configuration options also
supports a "tethering" mode that makes `raco setup` create launchers
that bind to the configration (so an environment variant doesn't have
to be set). While several pieces of this idea were in place in commit
6369e56709, it wasn't really finished, and there was no documentation
to explain how things are intended to work.

There's definitely still room for tools that automate the steps for
setting up a layer and tethering.

Along the way, this commit cleans up the `(find-system-path
'exec-file)` aspect of embedding executables as launchers to make them
consistent across platforms and work right as tethered launchers.
This commit is contained in:
Matthew Flatt 2021-05-16 10:14:50 -06:00
parent 0a9c70e95a
commit dfbb7040aa
18 changed files with 789 additions and 307 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

54
pkgs/racket-doc/scribblings/raco/config.scrbl
View File

@ -46,6 +46,11 @@ directory}:
@tech[#:doc '(lib "pkg/scribblings/pkg.scrbl")]{package
scope}. The default is @racket[(version)].}
@item{@indexed-racket['collects-search-dirs] --- a list of paths,
strings, byte strings, or @racket[#f] representing the search
path for collections. Each @racket[#f] in the list, if any, is
replaced with the @tech{main collection directory}.}
@item{@indexed-racket['lib-dir] --- a path, string, or byte string for the
@deftech{main library directory}. It defaults to a @filepath{lib}
sibling directory of the @tech{main collection directory}.}
@ -66,12 +71,23 @@ directory}:
It defaults to a @filepath{share} sibling directory of the main
collection directory.}
@item{@indexed-racket['share-search-dirs] --- analogous to
@racket['lib-search-dirs], where @racket[#f] is replaced by the
default search path, which is a user- and version-specific
directory followed by a directory as potentially configured via
@scheme['share-dir].
@history[#:added "8.1.0.6"]}
@item{@indexed-racket['links-file] --- a path, string, or byte string for the
@tech[#:doc reference-doc]{collection links file}. It defaults
to a @filepath{links.rktd} file in the @tech{main shared-file directory}.}
@item{@indexed-racket['links-search-files] --- like @racket['lib-search-dirs],
but for @tech[#:doc reference-doc]{collection links file}.}
but for @tech[#:doc reference-doc]{collection links file}. A @racket[#f]
is replaced by the default search path, which is the user- and version-specific
links file followed by the links file as potentially configured
via @scheme['links-file].}
@item{@indexed-racket['pkgs-dir] --- a path, string, or byte string
for packages that have @exec{installation} @tech[#:doc '(lib
@ -118,6 +134,22 @@ directory}:
@history[#:added "6.8.0.2"]}
@item{@indexed-racket['bin-search-dirs] --- like
@racket['lib-search-dirs], but for finding executables
such as @exec{racket}. A @racket[#f]
is replaced by the default search path, which is a
user- and version-specific directory followed by the main console
executable directory as potentially configured via
@scheme['bin-dir].
@history[#:added "8.1.0.6"]}
@item{@indexed-racket['gui-bin-search-dirs] --- like
@racket['bin-search-dirs], but for GUI executables,
and defaults to the @racket['bin-search-dirs] value.
@history[#:added "8.1.0.6"]}
@item{@indexed-racket['apps-dir] --- a path, string, or byte string
for the installation's directory for @filepath{.desktop} files.
It defaults to a @filepath{applications} subdirectory of the
@ -125,15 +157,26 @@ directory}:
@item{@indexed-racket['man-dir] --- a path, string, or byte string for the
installation's man-page directory. It defaults to a @filepath{man}
sibling directory of the @tech{main collection directory}.}
sibling directory of the @tech{main shared-file directory}.}
@item{@indexed-racket['man-search-dirs] --- analogous to
@racket['lib-search-dirs], where @racket[#f] is replaced by the
default search path, which is a user- and version-specific
directory followed by a directory as potentially configured via
@scheme['man-dir].
@history[#:added "8.1.0.6"]}
@item{@indexed-racket['doc-dir] --- a path, string, or byte string for the
main documentation directory. The value defaults to a
@filepath{doc} sibling directory of the
@tech{main collection directory}.}
@item{@indexed-racket['doc-search-dirs] --- like @racket['lib-search-dirs],
but for directories containing documentation.}
@item{@indexed-racket['doc-search-dirs] --- analogous to
@racket['lib-search-dirs], where @racket[#f] is replaced by the
default search path, which is a user- and version-specific
directory followed by a directory as potentially configured via
@scheme['doc-dir].}
@item{@indexed-racket['doc-search-url] --- a URL string that is augmented
with version and search-tag queries to form a remote
@ -210,7 +253,8 @@ directory}:
directory to hold extra copies of executables that are tied to the
configuration directory (as reported by @racket[find-config-dir])
that is active at the time the executables are created. See also
@racket[find-config-tethered-console-bin-dir] and
@secref["tethered-install"],
@racket[find-config-tethered-console-bin-dir], and
@racket[find-config-tethered-gui-bin-dir].}
@item{@indexed-racket['interactive-file] and

10
pkgs/racket-doc/scribblings/raco/exe-api.scrbl
View File

@ -279,10 +279,10 @@ currently supported keys are as follows:
brings the other instance to the front; @racket[#f] means that
multiple instances are expected.}
@item{@racket['forget-exe?] (Windows, Mac OS) : A boolean;
@item{@racket['forget-exe?] (Unix, Windows, Mac OS) : A boolean;
@racket[#t] for a launcher (see @racket[launcher?] below) does
not preserve the original executable name for
@racket[(find-system-path 'exec-file)]; the main consequence
@racket[(find-system-path 'exec-file)]; one consequence
is that library collections will be found relative to the
launcher instead of the original executable.}
@ -329,12 +329,12 @@ use of @tech[#:doc reference-doc]{collection links files}.
If the @racket[#:launcher?] argument is @racket[#t], then
@racket[mod-list] should be null, @racket[literal-files] should be
null, @racket[literal-sexp] should be @racket[#f], and the platform
should be Windows or Mac OS. The embedding executable is created in
null, and @racket[literal-sexp] should be @racket[#f]. The embedding executable is created in
such a way that @racket[(find-system-path 'exec-file)] produces the
source Racket or GRacket path instead of the embedding executable (but
the result of @racket[(find-system-path 'run-file)] is still the
embedding executable).
embedding executable), unless @racket['forget-exe?] is associated
to a true value in @racket[aux].
The @racket[#:variant] argument indicates which variant of the
original binary to use for embedding. The default is

250
pkgs/racket-doc/scribblings/raco/setup.scrbl
View File

@ -24,6 +24,7 @@
setup/link
compiler/compiler
compiler/module-suffix
compiler/find-exe
launcher/launcher
compiler/sig
launcher/launcher-sig
@ -1413,14 +1414,18 @@ current-system paths while @racket[get-cross-lib-search-dirs] and
@defproc[(get-main-collects-search-dirs) (listof path?)]{
Returns a list of paths to installation @filepath{collects}
directories, including the result of @racket[find-collects-dir].
directories, normally including the result of @racket[find-collects-dir].
These directories are normally included in the result of
@racket[(current-library-collection-paths)], but a
@envvar{PLTCOLLECTS} setting or change to the parameter may cause
them to be omitted. Any other path in
@racket[(current-library-collection-paths)] is treated as
user-specific. The directories indicated by the returned paths may
or may not exist.}
or may not exist.
The main-collections search path can be configured via
@racket['collects-search-dirs] in @filepath{config.rktd} (see
@secref["config-file"]).}
@defproc[(find-config-dir) (or/c path? #f)]{
Returns a path to the installation's @filepath{etc} directory, which
@ -1500,6 +1505,13 @@ current-system paths while @racket[get-cross-lib-search-dirs] and
@see-config[doc-search-dirs]}
@defproc[(get-doc-extra-search-dirs) (listof path?)]{
Like @racket[get-doc-search-dirs], but refrains from adding
@racket[(find-doc-dir)] and @racket[(find-user-doc-dir)] to the
underlying @racket['doc-search-dirs] configuration.
@history[#:added "8.1.0.6"]}
@defproc[(find-lib-dir) (or/c path? #f)]{
Returns a path to the installation's @filepath{lib} directory, which contains
libraries and other build information. The result is @racket[#f] if no such
@ -1543,6 +1555,13 @@ current-system paths while @racket[get-cross-lib-search-dirs] and
@history[#:added "6.9.0.1"]}
@defproc[(get-cross-lib-extra-search-dirs) (listof path?)]{
Like @racket[get-cross-lib-search-dirs], but refrains from adding
@racket[(find-lib-dir)] and @racket[(find-user-lib-dir)] to the
underlying @racket['lib-search-dirs] configuration.
@history[#:added "8.1.0.6"]}
@defproc[(find-dll-dir) (or/c path? #f)]{
Returns a path to the directory that contains DLLs for use with the
current executable (e.g., @filepath{libracket.dll} on Windows).
@ -1577,6 +1596,27 @@ current-system paths while @racket[get-cross-lib-search-dirs] and
@user-path["share"]}
@defproc[(get-share-search-dirs) (listof path?)]{
Returns a list of paths to search for files that are normally in a
@filepath{share} directory.
Unless it is configured otherwise, the result includes any
non-@racket[#f] result of @racket[(find-share-dir)] and
@racket[(find-user-share-dir)]---but the latter is included only if
the value of the @racket[use-user-specific-search-paths] parameter
is @racket[#t].
@see-config[share-search-dirs]
@history[#:added "8.1.0.6"]}
@defproc[(get-share-extra-search-dirs) (listof path?)]{
Like @racket[get-share-search-dirs], but refrains from adding
@racket[(find-share-dir)] and @racket[(find-user-share-dir)] to the
underlying @racket['share-search-dirs] configuration.
@history[#:added "8.1.0.6"]}
@defproc[(find-include-dir) (or/c path? #f)]{
Returns a path to the installation's @filepath{include} directory, which
contains @filepath{.h} files for building Racket extensions and embedding
@ -1626,6 +1666,34 @@ current-system paths while @racket[get-cross-lib-search-dirs] and
@user-path[#f]}
@defproc[(get-console-bin-search-dirs) (listof path?)]{
Analogous to @racket[get-share-search-dirs], but for paths to search
for executables such as @exec{racket}.
@see-config[bin-search-dirs]
@history[#:added "8.1.0.6"]}
@defproc[(get-console-bin-extra-search-dirs) (listof path?)]{
Analogous to @racket[get-share-extra-search-dirs] for the underlying
@racket['bin-search-dirs] configuration.
@history[#:added "8.1.0.6"]}
@defproc[(get-gui-bin-search-dirs) (listof path?)]{
Analogous to @racket[get-share-search-dirs], but for paths to search
for executables such as @exec{gracket}.
@see-config[gui-bin-search-dirs]
@history[#:added "8.1.0.6"]}
@defproc[(get-gui-bin-extra-search-dirs) (listof path?)]{
Analogous to @racket[get-share-extra-search-dirs] for the underlying
@racket['gui-bin-search-dirs] configuration.
@history[#:added "8.1.0.6"]}
@defproc[(find-apps-dir) (or/c path? #f)]{
Returns a path to the installation's directory @filepath{.desktop}
files (for Unix). The result is @racket[#f] if no such directory
@ -1650,6 +1718,20 @@ current-system paths while @racket[get-cross-lib-search-dirs] and
@user-path["man"]}
@defproc[(get-man-search-dirs) (listof path?)]{
Analogous to @racket[get-share-search-dirs], but for paths to search
for man pages.
@see-config[man-search-dirs]
@history[#:added "8.1.0.6"]}
@defproc[(get-man-extra-search-dirs) (listof path?)]{
Analogous to @racket[get-share-extra-search-dirs] for the underlying
@racket['man-search-dirs] configuration.
@history[#:added "8.1.0.6"]}
@defproc[(get-doc-search-url) string?]{
Returns a string that is used by the documentation system, augmented
with a version and search-key query, for remote documentation links.
@ -1705,14 +1787,7 @@ current-system paths while @racket[get-cross-lib-search-dirs] and
@racket[find-addon-tethered-gui-bin-dir], is @racket[#f] instead of
a path.
The intent of this protocol is to support a kind of sandbox: an
installation that is more specific than user-specific, and where
copies of executables such as @exec{racket} serve as entry points
into the sandbox. Assuming that the addon directory is set to a
directory other than the user's default addon directory when
@exec{raco setup} creates the executable copies, then further
package build and setup operations through the entry points will be
confined to the sandbox and not affect a user's default environment.
See @secref["tethered-install"] for more information.
@history[#:added "6.5.0.2"]}
@ -1726,7 +1801,9 @@ current-system paths while @racket[get-cross-lib-search-dirs] and
@filepath{config.rktd} in the @racket[(find-config-dir)] directory
(see @secref["config-file"]) and triggers executables that are
tethered only to a particular value of @racket[(find-config-dir)].
See @secref["tethered-install"] for more information.
@history[#:added "6.5.0.2"]}
@; ------------------------------------------------------------------------
@ -2363,3 +2440,154 @@ point already exists in @racket[(find-user-doc-dir)].
@history[#:changed "1.1" @list{Added the @racket[skip-user-doc-check?] argument.}]
}
@; ------------------------------------------------------------------------
@section[#:tag "layered-install"]{Layered Installations}
A typical Racket configuration includes two layers: an
@defterm{installation} layer and a @defterm{user} layer. The intent is
that the @defterm{installation} layer is read-only to all users of a
system, while the @defterm{user} layer allows each individual user to
install additional packages that extend the @defterm{installation}
layer. The @defterm{installation} layer is intended not only to be
read-only, but to not change after users start installing in their own
layers.
In an environment where Racket itself is under development, the
@defterm{installation} layer will change. In that setting, if the
@defterm{user} layer is used at all, care must be taken to not create
conflicts for the user layer when modifying the installation
layer---or else the user layer must be repaired on occasion.
By default, @exec{raco setup} updates both layers whenever it is run;
if a user does not have write permission the installation, @exec{raco
setup} with no arguments is all but certain to report permission
errors. The actions of @exec{raco setup} can be constrained to the
@defterm{user} layer by supplying the @DFlag{avoid-main} argument, or
@exec{raco setup} can be constrained to the @defterm{installation}
layer by using the @DFlag{no-user} argument. When @exec{raco pkg}
performs setup actions, it effectively supplies one of the other of
those based on the package's scope (and @exec{raco pkg} refuses to
operate on both scopes/layers at once).
The @defterm{user} layer is always both user- and version-specific.
More precisely, it is specific to the user and an installation's name,
where the installation's name is typically its version number.
However, the name of an installation can be changed through the
@racket['installation] setting in @filepath{config.rktd} (see
@secref["config-file"]). Setting an installation name changes the
directory where packages and executables reside within
@racket[(find-system-path 'addon-dir)]. The result of
@racket[(find-system-path 'addon-dir)] itself can be changed through
@racket['addon-dir] in @filepath{config.rktd}.
The @defterm{installation} and @defterm{user} configuration layers can
be generalized to multiple layers by setting search paths in
@filepath{config.rktd}. These search paths essentially treat the layer
closest to @defterm{user} as the @defterm{installation} layer that
might be adjusted by @exec{raco setup} and @exec{raco pkg}, but search
paths can chain to an existing (unchanging) implementation in much the
same way that @defterm{user} chains to @defterm{installation}. To
build a new layer, create new @filepath{config.rktd} that is like the
underlying layer's @filepath{config.rktd}, but
@;
@itemlist[
@item{each of @racket['lib-dir], @racket['share-dir],
@racket['links-file], @racket['pkgs-dir], @racket['bin-dir],
@racket['gui-bin-dir], @racket['apps-dir], @racket['doc-dir],
and @racket['man-dir] is a new directory or file; and}
@item{the corresponding search lists @racket['lib-search-dirs],
@racket['share-search-dirs], @racket['links-search-files],
@racket['pkgs-search-dirs], @racket['bin-search-dirs],
@racket['gui-bin-search-dirs], (no @racket['apps-dir] search
needed), @racket['doc-search-dirs], and
@racket['man-search-dirs] each add the old directory or file to
the search list just after @racket[#f]; note that the default
for each search list is @racket[(list #f)].}
]
@;
There is no argument to @exec{raco setup} that is analogous to
@DFlag{avoid-main} to avoid modifying nested layer; instead, nested
layers are expected to be fully set up so that @exec{raco setup}
need not change them. When @exec{raco setup} would otherwise install
an executable into the directory configured as @racket['bin-dir], it
consults the @racket['bin-search-dirs] list to check whether the
executable is already installed in one of those directories, and if so,
it will refrain from creating a copy in the new layer. The same
search-list check also applies to native libraries, shared files, and
man pages.
The default path to @filepath{config.rktd} is hardwired within a
@exec{racket} executable. In some cases, it can make sense for the
innermost layer's configuration to point to another layer, perhaps
because the filesystem provides an indirection. For example, on Unix,
a Racket installation in @filepath{/usr} might reasonably configure
the @defterm{installation} layer's directories to be in
@filepath{/usr/local} with @filepath{/usr} directories included in the
search lists.
To use @exec{racket} with a new @filepath{config.rktd}, you can supply
the @DFlag{config} or @DFlag{G} flag to @exec{racket} or set the
@envvar{PLTCONFIGDIR} environment variable to point to the directory
containing @filepath{config.rktd}. Alternatively, you can create a
@tech{tethered} layer that creates replacement executables like
@exec{racket} that are hardwired to the layer's configuration
directory.
@; ------------------------------------------------------------------------
@section[#:tag "tethered-install"]{Tethered Installations}
A @deftech{tethered} installation of Racket is a layer (see
@secref["layered-install"]) that includes a wrapper executable for
every executable across the installation's layers. Each wrapper
executable points back to the new layer's @filepath{config.rktd} (see
@secref["config-file"]) without the use of a @envvar{PLTCONFIGDIR}
environment variable or @DFlag{config} flag. In other words, a
tethered installation provides executables such as @exec{racket},
@exec{raco}, and @exec{drracket} that are tied to the layer. Tethering
thus helps to create a layer of installation that behaves in a more
self-contained way, but with minimal duplication of the underlying
layers.
Tethering works at either a @defterm{user} or @defterm{installation}
layer:
@itemlist[
@item{A @defterm{user} layer with tethering is represented by a fresh
directory @nonterm{addon-dir} and a
@filepath{@nonterm{addon-dir}/etc/config.rktd} file that maps
@racket['addon-tethered-console-bin-dir] to
@nonterm{tethered-bin-dir} and
@racket['addon-tethered-gui-bin-dir] to
@nonterm{tethered-gui-bin-dir}. Initialize the tethered layer
with
@commandline{racket -A @nonterm{addon-dir} -l- raco setup --avoid-main}}
@item{An @defterm{installation} layer with tethering is like a one
without tethering (see @secref["layered-install"]), but where
the layer's @filepath{@nonterm{layer-dir}/etc/config.rktd} file
htat maps @racket['config-tethered-console-bin-dir] to
@nonterm{tethered-bin-dir} and
@racket['config-tethered-gui-bin-dir] to
@nonterm{tethered-gui-bin-dir}. The @racket['bin-dir]
configuration can point to a directory that is ignored, since
the executables there will not be tethered. Initialize the
tethered layer with
@commandline{racket -G @nonterm{layer-dir}/etc -l- raco setup}}
]
In either case, initialization creates tethered executables in the
directories @nonterm{tethered-bin-dir} and
@nonterm{tethered-gui-bin-dir}. Thereafter, tethered executables like
@exec{@nonterm{tethered-bin-dir}/racket} and
@exec{@nonterm{tethered-bin-dir}/raco} can be used to work with the
tethered layer.

8
pkgs/racket-index/setup/private/doc-path.rkt
View File

@ -23,7 +23,13 @@
(memq 'main-doc flags)
(pair? (path->main-collects-relative dir)))
(and main?
(build-path (find-doc-dir) name))]
;; check for existing directory in search path before
;; assuming the main doc directory
(or (for/or ([dir (get-doc-search-dirs)])
(define p (build-path dir name))
(and (directory-exists? p)
p))
(build-path (find-doc-dir) name)))]
[else
(and (not (eq? 'never user-doc-mode))
(build-path dir "doc" name))]))

81
pkgs/racket-index/setup/scribble.rkt
View File

@ -58,6 +58,7 @@
dest-dir
flags
under-main?
via-search?
pkg?
category
out-count
@ -197,6 +198,11 @@
(define src (simplify-path (build-path dir (car d)) #f))
(define name (cadddr d))
(define dest (doc-path dir name flags under-main?))
(define via-search? (and under-main?
(not (or (equal? (find-doc-dir) dest)
(let-values ([(base name dir?) (split-path dest)])
(equal? (path->directory-path (find-doc-dir))
base))))))
(make-doc dir
(let ([spec (directory-record-spec rec)])
(list* (car spec)
@ -208,7 +214,7 @@
(cdr spec))))
src
dest
flags under-main? (and (path->pkg src) #t)
flags under-main? via-search? (and (path->pkg src) #t)
(caddr d)
(list-ref d 4)
(if (path? name) (path-element->string name) name)
@ -235,21 +241,28 @@
(define main-doc-exists? (ormap (lambda (d) (member 'main-doc-root (doc-flags d)))
main-docs))
(define (can-build*? docs) (can-build? only-dirs docs))
(define (can-build*? docs) (can-build? only-dirs avoid-main? docs))
(define main-db (find-doc-db-path latex-dest #f main-doc-exists?))
(define user-db (find-doc-db-path latex-dest #t main-doc-exists?))
;; Ensure that databases are created:
(define (touch-db db-file)
(define (touch-db db-file [copy-from #f])
(unless (file-exists? db-file)
(define-values (base name dir?) (split-path db-file))
(make-directory* base)
(when copy-from (copy-file copy-from db-file))
(doc-db-disconnect
(doc-db-file->connection db-file #t))))
(when (or (ormap can-build*? main-docs)
(and tidy? (not avoid-main?)))
(touch-db main-db))
;; start with docindex from previous search layer, if any
(define prev-db (and (not (file-exists? main-db))
(for/or ([dir (in-list (get-doc-extra-search-dirs))])
(define db (build-path dir "docindex.sqlite"))
(and (file-exists? db)
db))))
(touch-db main-db prev-db))
(when (or (ormap can-build*? user-docs)
(and tidy? make-user?))
(touch-db user-db))
@ -282,7 +295,7 @@
(or (ormap can-build*? user-docs)
(and tidy? make-user?)
always-user?)))
(define (can-build**? doc) (can-build? only-dirs doc auto-main? auto-user?))
(define (can-build**? doc) (can-build? only-dirs avoid-main? doc auto-main? auto-user?))
(unless latex-dest
;; Make sure "scribble.css", etc., is in place:
@ -318,7 +331,7 @@
(log-setup-info "getting document information")
(define (make-sequential-get-info only-fast?)
(get-doc-info only-dirs latex-dest
auto-main? auto-user? main-doc-exists?
avoid-main? auto-main? auto-user? main-doc-exists?
with-record-error setup-printf #f
only-fast? force-out-of-date?
no-lock (if gc-after-each-sequential? gc-point void)))
@ -328,11 +341,12 @@
[((doc-order-hint (car docs)) . > . -10) 0]
[else
(add1 (loop (cdr docs)))])))
(define count (for/sum ([doc (in-list docs)]) (if (can-build**? doc) 1 0)))
(define infos
(and (ormap can-build**? docs)
(and (count . > . 0)
(filter
values
(if (or ((min worker-count (length docs)) . < . 2)
(if (or ((min worker-count count) . < . 2)
only-fast?)
;; non-parallel version:
(map (make-sequential-get-info only-fast?) docs)
@ -353,7 +367,7 @@
(lambda (workerid)
(init-lock-ch!)
(list workerid program-name (verbose) only-dirs latex-dest
auto-main? auto-user? main-doc-exists?
avoid-main? auto-main? auto-user? main-doc-exists?
force-out-of-date? lock-ch))
(list-queue
(list-tail docs num-sequential)
@ -367,10 +381,10 @@
(lambda (args)
(apply setup-printf args)))
(define-worker (get-doc-info-worker workerid program-name verbosev only-dirs latex-dest
auto-main? auto-user? main-doc-exists?
avoid-main? auto-main? auto-user? main-doc-exists?
force-out-of-date? lock-ch)
(define ((get-doc-info-local program-name only-dirs latex-dest
auto-main? auto-user? main-doc-exists?
avoid-main? auto-main? auto-user? main-doc-exists?
force-out-of-date? lock
send/report)
doc)
@ -384,7 +398,7 @@
(go)))
(s-exp->fasl (serialize
((get-doc-info only-dirs latex-dest
auto-main? auto-user? main-doc-exists?
avoid-main? auto-main? auto-user? main-doc-exists?
with-record-error setup-printf workerid
#f force-out-of-date? lock void)
(deserialize (fasl->s-exp doc))))))
@ -393,7 +407,7 @@
(match-message-loop
[doc (send/success
((get-doc-info-local program-name only-dirs latex-dest
auto-main? auto-user? main-doc-exists?
avoid-main? auto-main? auto-user? main-doc-exists?
force-out-of-date? (lock-via-channel lock-ch)
send/report)
doc))])))))))))
@ -887,20 +901,23 @@
(find-doc-dir))
"docindex.sqlite")]))
(define (can-build? only-dirs doc [auto-main? #f] [auto-user? #f])
(or (not only-dirs)
(and auto-main?
(memq 'depends-all-main (doc-flags doc)))
(and auto-user?
(or (memq 'depends-all (doc-flags doc))
(memq 'depends-all-user (doc-flags doc))))
(ormap (lambda (d)
(let ([d (path->directory-path d)])
(let loop ([dir (path->directory-path (doc-src-dir doc))])
(or (equal? dir d)
(let-values ([(base name dir?) (split-path dir)])
(and (path? base) (loop base)))))))
only-dirs)))
(define (can-build? only-dirs avoid-main? doc [auto-main? #f] [auto-user? #f])
(and (not (doc-via-search? doc))
(or (not avoid-main?)
(not (doc-under-main? doc)))
(or (not only-dirs)
(and auto-main?
(memq 'depends-all-main (doc-flags doc)))
(and auto-user?
(or (memq 'depends-all (doc-flags doc))
(memq 'depends-all-user (doc-flags doc))))
(ormap (lambda (d)
(let ([d (path->directory-path d)])
(let loop ([dir (path->directory-path (doc-src-dir doc))])
(or (equal? dir d)
(let-values ([(base name dir?) (split-path dir)])
(and (path? base) (loop base)))))))
only-dirs))))
(define (load-doc/ensure-prefix doc)
(define (ensure-doc-prefix v src-spec)
@ -991,7 +1008,7 @@
(sha1 i))
(define ((get-doc-info only-dirs latex-dest
auto-main? auto-user? main-doc-exists?
avoid-main? auto-main? auto-user? main-doc-exists?
with-record-error setup-printf workerid
only-fast? force-out-of-date? lock gc-point)
doc)
@ -999,7 +1016,7 @@
;; First, move pre-rendered documentation, if any, into place
(let ([rendered-dir (let-values ([(base name dir?) (split-path (doc-dest-dir doc))])
(build-path (doc-src-dir doc) "doc" name))])
(when (and (can-build? only-dirs doc)
(when (and (can-build? only-dirs avoid-main? doc)
(directory-exists? rendered-dir)
(not (file-exists? (build-path rendered-dir "synced.rktd")))
(or (not (directory-exists? (doc-dest-dir doc)))
@ -1024,7 +1041,7 @@
path)))]
[src-sha1 (and src-zo (get-compiled-file-sha1 src-zo))]
[renderer (make-renderer latex-dest doc main-doc-exists?)]
[can-run? (can-build? only-dirs doc)]
[can-run? (can-build? only-dirs avoid-main? doc)]
[stamp-data (with-handlers ([exn:fail:filesystem? (lambda (exn) (list "" "" ""))])
(let ([v (call-with-input-file* stamp-file read)])
(if (and (list? v)
@ -1117,7 +1134,7 @@
(for-each delete-file info-out-files)
(delete-file info-in-file)
((get-doc-info only-dirs latex-dest
auto-main? auto-user? main-doc-exists?
avoid-main? auto-main? auto-user? main-doc-exists?
with-record-error setup-printf workerid
#f #f lock gc-point)
doc))])
@ -1126,7 +1143,7 @@
(error "old info has wrong version or flags"))
(when (and (or (not provides-time)
(provides-time . < . info-out-time))
(can-build? only-dirs doc))
(can-build? only-dirs avoid-main? doc))
;; Database is out of sync, and we don't need to build
;; this document, so update databse now. Note that a
;; timestamp is good enough for determing a sync,

103
racket/collects/compiler/embed.rkt
View File

@ -150,10 +150,28 @@
;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define (find-relevant-lib-dir f #:default [default #f])
(or
(for/or ([lib-dir (in-list (get-cross-lib-search-dirs))])
(define p (build-path lib-dir f))
(and (or (file-exists? p)
(directory-exists? p))
lib-dir))
default
(error 'find-relevant-lib-dir
"could not find ~s"
f)))
(define (find-in-lib f)
(build-path (find-relevant-lib-dir f #:default (find-lib-dir))
f))
;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define (prepare-macosx-mred exec-name dest aux variant)
(let* ([name (let-values ([(base name dir?) (split-path dest)])
(path-replace-extension name #""))]
[src (build-path (find-lib-dir) "Starter.app")]
[src (find-in-lib "Starter.app")]
[creator (let ([c (assq 'creator aux)])
(or (and c
(cdr c))
@ -291,31 +309,6 @@
resource-files))
(build-path dest "Contents" "MacOS" name)))
;; The starter-info file is now disabled. The GRacket
;; command line is handled the same as the Racket command
;; line.
(define use-starter-info? #f)
(define (finish-osx-mred dest flags exec-name keep-exe? relative?)
(call-with-output-file (build-path dest
"Contents"
"Resources"
"starter-info")
#:exists 'truncate
(lambda (port)
(write-plist
`(dict ,@(if keep-exe?
`((assoc-pair "executable name"
,(path->string
(if relative?
(relativize exec-name dest
(lambda (p)
(build-path 'up 'up 'up p)))
exec-name))))
null)
(assoc-pair "stored arguments"
(array ,@flags)))
port))))
;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Represent modules with lists starting with the filename, so we
@ -1535,14 +1528,13 @@
(cond
[(and mred? (eq? 'macosx (cross-system-type)))
(values (prepare-macosx-mred exe dest aux variant)
(mac-dest->executable (build-path (find-lib-dir) "Starter.app")
(mac-dest->executable (find-in-lib "Starter.app")
#t)
#t)]
[unix-starter?
(let ([starter (build-path (find-lib-dir)
(if (force exe-suffix?)
"starter.exe"
"starter"))])
(let ([starter (find-in-lib (if (force exe-suffix?)
"starter.exe"
"starter"))])
(when (or (file-exists? dest)
(directory-exists? dest)
(link-exists? dest))
@ -1581,7 +1573,7 @@
mred?)
(when mred?
;; adjust relative path, since exe may change directory :
(define rel (find-relative-path* dest (find-lib-dir)))
(define rel (find-relative-path* dest (find-relevant-lib-dir "Racket.framework")))
(update-framework-path (format "@executable_path/../../../~a"
(path->directory-path rel))
(mac-dest->executable dest mred?)
@ -1591,7 +1583,7 @@
(when (regexp-match #rx"^@executable_path"
(get-current-framework-path dest "Racket"))
(update-framework-path (string-append
(path->string (find-lib-dir))
(path->string (find-relevant-lib-dir "Racket.framework"))
"/")
dest
mred?))))))
@ -1626,7 +1618,7 @@
dest))])
(define (gui-bin->config rel)
;; Find the path to config-dir relative to the executable
(define p (find-relative-path* dest (find-config-dir)))
(define p (find-relative-path* (if keep-exe? orig-exe dest) (find-config-dir)))
(simplify-path
(if (eq? rel 'same)
p
@ -1635,18 +1627,17 @@
(if m
(if (cdr m)
(update-config-dir (dest->executable dest) (cdr m))
(when mred?
(when (and mred? (not keep-exe?))
(cond
[osx?
;; adjust relative path (since GRacket is likely off by one):
(update-config-dir (mac-dest->executable dest mred?)
(gui-bin->config "../../.."))]
[(eq? 'windows (cross-system-type))
(unless keep-exe?
;; adjust relative path (since GRacket is likely off by one):
(update-config-dir dest (gui-bin->config 'same)))]
[else
(update-config-dir dest (gui-bin->config 'same))])))
[osx?
;; adjust relative path (since GRacket is likely off by one):
(update-config-dir (mac-dest->executable dest mred?)
(gui-bin->config "../../.."))]
[(eq? 'windows (cross-system-type))
;; adjust relative path (since GRacket is likely off by one):
(update-config-dir dest (gui-bin->config 'same))]
[else
(update-config-dir dest (gui-bin->config 'same))])))
;; Check whether we need an absolute path to config:
(let ([dir (get-current-config-dir (dest->executable dest))])
(when (relative-path? dir)
@ -1676,10 +1667,11 @@
(lambda (start decl-end end)
(let ([start-s (number->string start)]
[decl-end-s (number->string decl-end)]
[end-s (number->string end)])
[end-s (number->string end)])
(append (if launcher?
(if (and (eq? 'windows (cross-system-type))
keep-exe?)
(if (and keep-exe?
;; a unix starter uses the same path as it execs
(not unix-starter?))
;; argv[0] replacement:
(list (path->string
(if relative?
@ -1820,7 +1812,7 @@
(when verbose?
(eprintf "Setting collection path\n"))
(set-collects-path dest-exe collects-path-bytes)]
[mred?
[(and mred? (not keep-exe?))
(cond
[osx?
;; default path in `gracket' is off by one:
@ -1828,13 +1820,10 @@
(build-path 'up 'up 'up
(find-relative-path* dest (find-collects-dir)))))]
[(eq? 'windows (cross-system-type))
(unless keep-exe?
;; off by one in this case, too:
(set-collects-path dest-exe (path->bytes
(find-relative-path* dest (find-collects-dir)))))])])
;; off by one in this case, too:
(set-collects-path dest-exe (path->bytes
(find-relative-path* dest (find-collects-dir))))])])
(cond
[(and use-starter-info? osx?)
(finish-osx-mred dest full-cmdline exe keep-exe? relative?)]
[unix-starter?
(let ([numpos (with-input-from-file dest-exe
(lambda () (find-cmdline
@ -1869,7 +1858,7 @@
(write-bytes #"s" out))
(flush-output out))
(file-position out (+ numpos 7))
(write-bytes #"!" out)
(write-bytes (if keep-exe? #"*" #"!") out)
(write-num start)
(write-num decl-end)
(write-num end)
@ -1921,7 +1910,7 @@
(file-position out))])
(file-position out cmdpos)
(fprintf out "~a...~a~a"
(if (and keep-exe? (eq? 'windows (cross-system-type))) "*" "?")
(if keep-exe? "*" "?")
(integer->integer-bytes end 4 #t #f)
(integer->integer-bytes (- new-end end) 4 #t #f)))))
(lambda ()

98
racket/collects/compiler/find-exe.rkt
View File

@ -10,48 +10,56 @@
[variant (if cross?
(cross-system-type 'gc)
(system-type 'gc))])
(let* ([base (if mred?
(or (and (not untethered?)
(find-addon-tethered-gui-bin-dir)
(find-config-tethered-gui-bin-dir))
(find-lib-dir))
(or (and (not untethered?)
(find-addon-tethered-console-bin-dir)
(find-config-tethered-console-bin-dir))
(find-console-bin-dir)))]
[fail
(lambda ()
(error 'find-exe
"can't find ~a executable for variant ~a"
(if mred? "GRacket" "Racket")
variant))])
(let ([exe (build-path
base
(case (if cross?
(cross-system-type)
(system-type))
[(macosx)
(cond
[(not mred?)
;; Need Racket:
(string-append "racket" (variant-suffix variant #f))]
[mred?
;; Need GRacket:
(let ([sfx (variant-suffix variant #t)])
(build-path (format "GRacket~a.app" sfx)
"Contents" "MacOS"
(format "GRacket~a" sfx)))])]
[(windows)
(format "~a~a.exe" (if mred?
"GRacket"
"Racket")
(variant-suffix variant #t))]
[(unix)
(format "~a~a" (if mred?
"gracket"
"racket")
(variant-suffix variant #f))]))])
(unless (or (file-exists? exe)
(directory-exists? exe))
(fail))
exe)))
(define (->list a) (if a (list a) null))
(define bases (if mred?
(append
(->list (and (not untethered?)
(find-addon-tethered-gui-bin-dir)))
(->list (and (not untethered?)
(find-config-tethered-gui-bin-dir)))
(if cross?
(get-cross-lib-search-dirs)
(get-lib-search-dirs)))
(append
(->list (and (not untethered?)
(find-addon-tethered-console-bin-dir)))
(->list (and (not untethered?)
(find-config-tethered-console-bin-dir)))
(get-console-bin-search-dirs))))
(define exe
(for/or ([base (in-list bases)])
(define exe (build-path
base
(case (if cross?
(cross-system-type)
(system-type))
[(macosx)
(cond
[(not mred?)
;; Need Racket:
(string-append "racket" (variant-suffix variant #f))]
[mred?
;; Need GRacket:
(let ([sfx (variant-suffix variant #t)])
(build-path (format "GRacket~a.app" sfx)
"Contents" "MacOS"
(format "GRacket~a" sfx)))])]
[(windows)
(format "~a~a.exe" (if mred?
"GRacket"
"Racket")
(variant-suffix variant #t))]
[(unix)
(format "~a~a" (if mred?
"gracket"
"racket")
(variant-suffix variant #f))])))
(and (or (file-exists? exe)
(directory-exists? exe))
exe)))
(unless exe
(error 'find-exe
"can't find ~a executable for variant ~a"
(if mred? "GRacket" "Racket")
variant))
exe)

121
racket/collects/launcher/launcher.rkt
View File

@ -79,33 +79,48 @@
v))
v)))
(define (find-dir what get-dir get-extra-search-dirs exe fail-ok?)
(or (for/or ([dir (in-list (cons (get-dir) (get-extra-search-dirs)))])
(and (file-or-directory-type (build-path dir exe) #f)
dir))
(if fail-ok?
#f
(error 'find-dir "unable to locate ~s executable: ~a" what exe))))
(define (find-lib-dir-for exe fail-ok?)
(find-dir "lib" find-lib-dir get-cross-lib-extra-search-dirs exe fail-ok?))
(define (find-console-bin-dir-for exe fail-ok?)
(find-dir "console-bin" find-console-bin-dir get-console-bin-extra-search-dirs exe fail-ok?))
(define (find-gui-bin-dir-for exe fail-ok?)
(find-dir "gui-bin" find-gui-bin-dir get-gui-bin-extra-search-dirs exe fail-ok?))
(define (variant-available? kind cased-kind-name variant)
(cond
[(or (eq? 'unix (cross-system-type))
(and (eq? 'macosx (cross-system-type))
(eq? kind 'mzscheme)))
(let ([bin-dir (if (eq? kind 'mzscheme)
(find-console-bin-dir)
(find-lib-dir))])
(and bin-dir
(file-exists?
(build-path bin-dir
(format "~a~a"
(case kind
[(mzscheme) 'racket]
[(mred) 'gracket])
(variant-suffix variant #f))))))]
(define exe (format "~a~a"
(case kind
[(mzscheme) 'racket]
[(mred) 'gracket])
(variant-suffix variant #f)))
(and (if (eq? kind 'mzscheme)
(find-console-bin-dir-for exe #t)
(find-lib-dir-for exe #t))
#t)]
[(eq? 'macosx (cross-system-type))
;; kind must be mred, because mzscheme case is caught above
(directory-exists? (build-path (find-lib-dir)
(format "~a~a.app"
cased-kind-name
(variant-suffix variant #f))))]
;; `kind` must be 'mred, because 'mzscheme case is caught above
(and (find-lib-dir-for (format "~a~a.app"
cased-kind-name
(variant-suffix variant #f))
#t)
#t)]
[(eq? 'windows (cross-system-type))
(file-exists?
(build-path
(if (eq? kind 'mzscheme) (find-console-bin-dir) (find-lib-dir))
(format "~a~a.exe" cased-kind-name (variant-suffix variant #t))))]
(define exe (format "~a~a.exe" cased-kind-name (variant-suffix variant #t)))
(and (if (eq? kind 'mzscheme)
(find-console-bin-dir-for exe #t)
(find-lib-dir-for exe #t))
#t)]
[else (error "unknown system type")]))
(define (available-variants kind)
@ -160,8 +175,13 @@
(available-variants 'mzscheme))
(define (install-template dest kind mz mr)
(define src (build-path (find-lib-dir)
(if (eq? kind 'mzscheme) mz mr)))
(define src (for/or ([lib-dir (in-list (get-lib-search-dirs))])
(define p (build-path lib-dir
(if (eq? kind 'mzscheme) mz mr)))
(and (or (file-exists? p)
(directory-exists? p))
p)))
(unless src (error "expected launcher template not found"))
(when (or (file-exists? dest)
(directory-exists? dest)
(link-exists? dest))
@ -174,9 +194,6 @@
(unless (equal? perms1 perms2)
(file-or-directory-permissions dest perms2))))
(define (script-variant? v)
(memq v '(script-3m script-cgc script-cs)))
(define (add-file-suffix path variant mred?)
(let ([s (variant-suffix
variant
@ -303,7 +320,7 @@
(let ([p (append (map (lambda (x) 'up) (cdr d)) b)])
(if (null? p) #f (apply build-path p))))))
(define (make-relative-path-header dest bindir use-librktdir?)
(define (make-relative-path-header dest bindir)
;; rely only on binaries in /usr/bin:/bin
(define (has-exe? exe)
(or (file-exists? (build-path "/usr/bin" exe))
@ -355,10 +372,8 @@
"cd \"$saveD\"\n"
"\n"
"bindir=\"$D"
(if use-librktdir?
""
(let ([s (relativize bindir-explode dest-explode)])
(if s (string-append "/" (protect-shell-string s)) "")))
(let ([s (relativize bindir-explode dest-explode)])
(if s (string-append "/" (protect-shell-string s)) ""))
"\"\n"
"PATH=\"$saveP\"\n")
;; fallback to absolute path header
@ -379,6 +394,13 @@
[alt-exe-is-gracket? (and alt-exe
(let ([m (assq 'exe-is-gracket aux)])
(and m (cdr m))))]
[use-exe (or alt-exe (case kind
[(mred) (if (eq? 'macosx (cross-system-type))
(format "GRacket~a.app/Contents/MacOS/Gracket~a"
(variant-suffix variant #t)
(variant-suffix variant #t))
"gracket")]
[(mzscheme) "racket"]))]
[x-flags? (and (eq? kind 'mred)
(eq? (cross-system-type) 'unix)
(not (script-variant? variant)))]
@ -404,9 +426,6 @@
"#!/bin/sh\n"
"# This script was created by make-"
(symbol->string kind)"-launcher\n")]
[use-librktdir? (if alt-exe
alt-exe-is-gracket?
(eq? kind 'mred))]
[addon? (let ([im (assoc 'install-mode aux)])
(and im (eq? (cdr im) 'addon-tethered)))]
[config? (let ([im (assoc 'install-mode aux)])
@ -414,7 +433,7 @@
[bindir (if alt-exe
(let ([m (assq 'exe-is-gracket aux)])
(if (and m (cdr m))
(find-lib-dir)
(find-lib-dir-for use-exe #f)
(let ([p (path-only dest)])
(if (eq? 'macosx (cross-system-type))
(let* ([cdir (or (and addon?
@ -426,7 +445,7 @@
(find-addon-tethered-gui-bin-dir))
(and config?
(find-config-tethered-gui-bin-dir))
(find-gui-bin-dir))]
(find-gui-bin-dir-for use-exe #f))]
[rel (find-relative-path cdir gdir)])
(cond
[(relative-path? rel)
@ -435,25 +454,19 @@
[else rel]))
p))))
(if (eq? kind 'mred)
(find-gui-bin-dir)
(find-console-bin-dir)))]
(if alt-exe
(find-gui-bin-dir-for use-exe #f)
(find-lib-dir-for use-exe #f))
(find-console-bin-dir-for use-exe #f)))]
[as-relative? (let ([a (assq 'relative? aux)])
(and a (cdr a)))]
[dir-finder
(if as-relative?
(make-relative-path-header dest bindir use-librktdir?)
(make-relative-path-header dest bindir)
(make-absolute-path-header bindir))]
[exec (format
"exec \"${~a}/~a~a\" ~a"
(if use-librktdir?
"librktdir"
"bindir")
(or alt-exe (case kind
[(mred) (if (eq? 'macosx (cross-system-type))
(format "GRacket~a.app/Contents/MacOS/Gracket"
(variant-suffix variant #t))
"gracket")]
[(mzscheme) "racket"]))
"exec \"${bindir}/~a~a\" ~a"
use-exe
(if alt-exe
""
(variant-suffix variant (and (eq? kind 'mred)
@ -480,18 +493,6 @@
(display "# {{{ bindir\n")
(display dir-finder)
(display "# }}} bindir\n")
(when use-librktdir?
(display "# {{{ librktdir\n")
(display "librktdir=\"$bindir/")
(display (find-relative-path (if as-relative?
(simplify-path
(let-values ([(base name dir?) (split-path (path->complete-path dest))])
base))
bindir)
(simplify-path
(find-lib-dir))))
(display "\"\n")
(display "# }}} librktdir\n"))
(newline)
(display (assemble-exec exec args)))))
(check-desktop aux dest))

3
racket/collects/racket/private/tethered-installer.rkt
View File

@ -27,4 +27,5 @@
(list "-A" (path->string (find-system-path 'addon-dir)))
null))
#:launcher? #t
#:aux `((relative? . #f)))))))
#:aux `((relative? . #f)
(forget-exe? . #t)))))))

3
racket/collects/setup/cross-system.rkt
View File

@ -11,8 +11,7 @@
(define (compute-cross!)
(unless cross-system-table
(define lib-dir (find-lib-dir))
(define ht (and lib-dir
(define ht (for/or ([lib-dir (in-list (get-cross-lib-search-dirs))])
(let ([f (build-path lib-dir "system.rktd")])
(and (file-exists? f)
(let ([ht (call-with-default-reading-parameterization

62
racket/collects/setup/dirs.rkt
View File

@ -9,8 +9,15 @@
(provide (except-out (all-from-out "private/dirs.rkt")
config:dll-dir
config:bin-dir
config:gui-bin-dir
config:bin-search-dirs
config:gui-bin-search-dirs
config:config-tethered-console-bin-dir
config:config-tethered-gui-bin-dir
config:lib-search-dirs
config:share-search-dirs
config:man-search-dirs
config:doc-search-dirs
define-finder
get-config-table
to-path)
@ -80,6 +87,61 @@
(define (find-addon-tethered-gui-bin-dir)
(find-addon-bin-dir 'addon-tethered-gui-bin-dir))
;; ----------------------------------------
;; Extra search paths
(provide get-console-bin-search-dirs
get-gui-bin-search-dirs
get-share-search-dirs
get-man-search-dirs
get-console-bin-extra-search-dirs
get-gui-bin-extra-search-dirs
get-share-extra-search-dirs
get-man-extra-search-dirs
get-doc-extra-search-dirs
get-cross-lib-extra-search-dirs)
(define (make-search-list config:search-dirs find-dir)
(combine-search (force config:search-dirs)
(let ([p (find-dir)])
(if p
(list p)
null))))
(define (get-console-bin-search-dirs)
(make-search-list config:bin-search-dirs find-console-bin-dir))
(define (get-gui-bin-search-dirs)
(make-search-list config:gui-bin-search-dirs find-gui-bin-dir))
(define (get-share-search-dirs)
(make-search-list config:share-search-dirs find-share-dir))
(define (get-man-search-dirs)
(make-search-list config:man-search-dirs find-man-dir))
(define (make-extra-search-list config:search-dirs)
(combine-search (force config:search-dirs) null))
(define (get-console-bin-extra-search-dirs)
(make-extra-search-list config:bin-search-dirs))
(define (get-gui-bin-extra-search-dirs)
(make-extra-search-list config:gui-bin-search-dirs))
(define (get-share-extra-search-dirs)
(make-extra-search-list config:share-search-dirs))
(define (get-man-extra-search-dirs)
(make-extra-search-list config:man-search-dirs))
(define (get-doc-extra-search-dirs)
(make-extra-search-list config:doc-search-dirs))
(define (get-cross-lib-extra-search-dirs)
(make-extra-search-list config:lib-search-dirs))
;; ----------------------------------------
;; DLLs

8
racket/collects/setup/main-doc.rkt
View File

@ -1,12 +1,16 @@
#lang s-exp racket/base
(require "dirs.rkt" "path-relativize.rkt")
(require "dirs.rkt"
"path-relativize.rkt")
(provide path->main-doc-relative
main-doc-relative->path)
(define-values (path->main-doc-relative
main-doc-relative->path)
(make-relativize find-doc-dir
(make-relativize (lambda ()
(define d (find-doc-dir))
(define extras (get-doc-extra-search-dirs))
(if d (cons d extras) extras))
'doc
'path->main-doc-relative
'main-doc-relative->path))

68
racket/collects/setup/path-relativize.rkt
View File

@ -3,7 +3,10 @@
(provide make-relativize)
(define (make-relativize find-root-dir tag to-rel-name from-rel-name)
(define (make-relativize find-roots-dir ; can return #f, one path, or a list of paths to try
tag
to-rel-name
from-rel-name)
;; Historical note: this module is based on the old "plthome.ss"
@ -16,14 +19,26 @@
;; (If it misses, things will continue to work fine and .dep files
;; will contain absolute path names.)
;; If `find-roots-dir` returns a list of roots, then a path is
;; converted as relative for the first root path where that's
;; possible, and a relative is converted back to a path for the
;; first one that exists (as a file, directory, or link) or
;; the first one if none exists. An empty roots list and a #f
;; from `find-root-dir` are treated as the same.
;; We need to compare paths to find when something is in the racket
;; tree, so we explode the paths. This is slower than the old way
;; (by a factor of 2 or so), but it's simpler and more portable.
(define (explode-path* path)
(explode-path (simplify-path (path->complete-path path))))
(define exploded-root
(delay (cond [(find-root-dir) => explode-path*] [else #f])))
(define exploded-roots
(delay (cond [(find-roots-dir)
=> (lambda (p)
(if (list? p)
(map explode-path* p)
(list (explode-path* p))))]
[else '()])))
;; path->relative : path-or-bytes -> datum-containing-bytes-or-path
(define (path->relative path0)
@ -33,7 +48,11 @@
[else (raise-argument-error to-rel-name
"(or/c path-string? bytes?)"
path0)]))
(let loop ([path (explode-path* path1)] [root (force exploded-root)])
(define orig-path (explode-path* path1))
(define roots (force exploded-roots))
(let loop ([path orig-path]
[root (and (pair? roots) (car roots))]
[roots (if (pair? roots) (cdr roots) '())])
(cond [(not root) path0]
[(null? root) (cons tag (map (lambda (pe)
(datum-intern-literal
@ -43,23 +62,48 @@
;; could be a byte string -- it should be possible to return
;; `path1', but that messes up the xform compilation somehow, by
;; having #<path...> values written into dep files.
[(null? path) path0]
[(null? path)
(cond
[(null? roots) path0]
[else (loop orig-path (car roots) (cdr roots))])]
[(equal? (normal-case-path (car path)) (normal-case-path (car root)))
(loop (cdr path) (cdr root))]
[else path0])))
(loop (cdr path) (cdr root) roots)]
[else
(cond
[(null? roots) path0]
[else (loop orig-path (car roots) (cdr roots))])])))
(define root-or-orig
(delay (or (find-root-dir)
(define roots-or-orig
(delay (or (let ([r (find-roots-dir)])
(and r
(if (list? r)
(and (pair? r) r)
(list r))))
;; No main "collects"/"doc"/whatever => use the
;; original working directory:
(find-system-path 'orig-dir))))
(list (find-system-path 'orig-dir)))))
;; relative->path : datum-containing-bytes-or-path -> path
(define (relative->path path)
(cond [(and (pair? path) (eq? tag (car path))
(and (list? (cdr path)) (andmap bytes? (cdr path))))
(apply build-path (force root-or-orig)
(map bytes->path-element (cdr path)))]
(define roots (force roots-or-orig))
(define elems (map bytes->path-element (cdr path)))
(define default-p (apply build-path (car roots) elems))
(define (exists? p) (file-or-directory-type p))
(cond
[(or (null? (cdr roots))
(exists? default-p))
default-p]
[else
(let loop ([roots (cdr roots)])
(cond
[(null? roots) default-p]
[else
(define p (apply build-path (car roots) elems))
(or (and (exists? p)
p)
(loop (cdr roots)))]))])]
[(path? path) path]
[(bytes? path) (bytes->path path)]
[(string? path) (string->path path)]

36
racket/collects/setup/private/dirs.rkt
View File

@ -61,15 +61,20 @@
(define-config config:lib-dir 'lib-dir to-path)
(define-config config:lib-search-dirs 'lib-search-dirs to-path)
(define-config config:share-dir 'share-dir to-path)
(define-config config:share-search-dirs 'share-search-dirs to-path)
(define-config config:apps-dir 'apps-dir to-path)
(define-config config:include-dir 'include-dir to-path)
(define-config config:include-search-dirs 'include-search-dirs to-path)
(define-config config:bin-dir 'bin-dir to-path)
(define-config config:bin-search-dirs 'bin-search-dirs to-path)
(define-config config:gui-bin-dir/raw 'gui-bin-dir to-path)
(define config:gui-bin-dir (delay/sync (or (force config:gui-bin-dir/raw) (force config:bin-dir))))
(define-config config:gui-bin-search-dirs/raw 'gui-bin-search-dirs to-path)
(define config:gui-bin-search-dirs (delay/sync (or (force config:gui-bin-search-dirs/raw) (force config:bin-search-dirs))))
(define-config config:config-tethered-console-bin-dir 'config-tethered-console-bin-dir to-path)
(define-config config:config-tethered-gui-bin-dir 'config-tethered-gui-bin-dir to-path)
(define-config config:man-dir 'man-dir to-path)
(define-config config:man-search-dirs 'man-search-dirs to-path)
(define-config config:links-file 'links-file to-path)
(define-config config:links-search-files 'links-search-files to-path)
(define-config config:pkgs-dir 'pkgs-dir to-path)
@ -209,24 +214,15 @@
;; ----------------------------------------
;; "doc"
(define delayed-#f (delay/sync #f))
(provide find-doc-dir
find-user-doc-dir
get-doc-search-dirs)
(define-finder no-provide
(define-finder provide
config:doc-dir
find-doc-dir
find-user-doc-dir
delayed-#f
get-new-doc-search-dirs
config:doc-search-dirs
get-doc-search-dirs
"doc")
;; For now, include "doc" pseudo-collections in search path:
(define (get-doc-search-dirs)
(combine-search (force config:doc-search-dirs)
(append (get-new-doc-search-dirs)
(map (lambda (p) (build-path p "doc"))
(current-library-collection-paths)))))
(provide config:doc-search-dirs)
;; ----------------------------------------
;; "include"
@ -250,6 +246,8 @@
get-cross-lib-search-dirs
"lib")
(provide config:lib-search-dirs)
;; ----------------------------------------
;; "share"
@ -259,6 +257,8 @@
find-user-share-dir
"share")
(provide config:share-search-dirs)
;; ----------------------------------------
;; "apps"
@ -278,15 +278,19 @@
find-user-man-dir
"man")
(provide config:man-search-dirs)
;; ----------------------------------------
;; Executables
;; `setup/dirs`
;; See `setup/dirs`
(provide config:bin-dir
config:gui-bin-dir
config:config-tethered-console-bin-dir
config:config-tethered-gui-bin-dir)
config:config-tethered-gui-bin-dir
config:bin-search-dirs
config:gui-bin-search-dirs)
;; ----------------------------------------
;; DLLs

96
racket/collects/setup/setup-core.rkt
View File

@ -17,6 +17,7 @@
planet/private/planet-shared
(only-in planet/resolver resolve-planet-path)
setup/cross-system
setup/variant
"option.rkt"
compiler/compiler
@ -1552,17 +1553,32 @@
(make-directory* dir))
(define skip-non-addon? (and (cc-main? cc)
(avoid-main-installation)))
(define skip-untethered-main? (and (cc-main? cc)
;; If the executable already exists in a search
;; directory other than the one for `p`, no need
;; to write `p` after all
(for/or ([dir (in-list (if (and (eq? kind 'gui)
(not (script-variant?
(current-launcher-variant))))
(get-gui-bin-extra-search-dirs)
(get-console-bin-extra-search-dirs)))])
(define-values (base name dir?) (split-path p))
(define p2 (build-path dir name))
(or (file-exists? p2)
(directory-exists? p2)))))
(unless skip-non-addon?
(prep-dir p)
(prep-dir receipt-path)
(unless skip-untethered-main?
(prep-dir p)
(prep-dir receipt-path))
(when config-p
(prep-dir config-p)))
(when addon-p
(prep-dir addon-p))
(hash-set! created-launchers
(record-launcher receipt-path mzln kind (current-launcher-variant)
(cc-collection cc) (cc-path cc))
#t)
(unless skip-untethered-main?
(hash-set! created-launchers
(record-launcher receipt-path mzln kind (current-launcher-variant)
(cc-collection cc) (cc-path cc))
#t))
(define (create p user? tethered?)
(define aux
(append
@ -1604,7 +1620,8 @@
p
aux)))
(unless skip-non-addon?
(create p (not (cc-main? cc)) #f)
(unless skip-untethered-main?
(create p (not (cc-main? cc)) #f))
(when config-p
(create config-p #f #t)))
(when addon-p
@ -1789,6 +1806,7 @@
copy-tag
move-tag
find-target-dir
get-extra-search-dirs
find-user-target-dir
path->relative-string/*
receipt-file
@ -1828,37 +1846,48 @@
(define (copy-lib lib moving?)
(define src (path->complete-path lib (cc-path cc)))
(define lib-name (file-name-from-path lib))
(define dest (build-dest-path dir lib-name))
(define already? (or (and moving?
(not (file-exists? src))
(not (directory-exists? src))
(or (file-exists? dest)
(directory-exists? dest)))
(same-content? src dest)))
(unless already?
(setup-printf "installing" (string-append what " ~a")
(path->relative-string/* dest)))
(hash-set!
installed-libs
(record-lib receipt-path lib-name (cc-collection cc) (cc-path cc))
#t)
(unless already?
(hash-set! dests dest #t)
(delete-directory/files/hard dest)
(make-parent-directory* dest)
(if (file-exists? src)
(if (cc-main? cc)
(copy-file src dest)
(copy-user-lib src dest))
(copy-directory/files src dest)))
src)
(cond
[(and (cc-main? cc)
(for/or ([s-dir (in-list (get-extra-search-dirs))])
(let ([p (build-dest-path s-dir lib-name)])
(or (file-exists? p)
(directory-exists? p)))))
;; already exists in one of the search directories, so
;; don't copy/move to this one
#f]
[else
(define dest (build-dest-path dir lib-name))
(define already? (or (and moving?
(not (file-exists? src))
(not (directory-exists? src))
(or (file-exists? dest)
(directory-exists? dest)))
(same-content? src dest)))
(unless already?
(setup-printf "installing" (string-append what " ~a")
(path->relative-string/* dest)))
(hash-set!
installed-libs
(record-lib receipt-path lib-name (cc-collection cc) (cc-path cc))
#t)
(unless already?
(hash-set! dests dest #t)
(delete-directory/files/hard dest)
(make-parent-directory* dest)
(if (file-exists? src)
(if (cc-main? cc)
(copy-file src dest)
(copy-user-lib src dest))
(copy-directory/files src dest)))
src]))
(for ([lib (in-list copy-libs)])
(copy-lib lib #f))
(for ([lib (in-list move-libs)])
(define src (copy-lib lib #t))
(delete-directory/files src #:must-exist? #f)))))
(when src
(delete-directory/files src #:must-exist? #f))))))
(when (or no-specific-collections?
(make-tidy))
(unless (avoid-main-installation)
@ -1967,6 +1996,7 @@
'copy-foreign-libs
'move-foreign-libs
find-lib-dir
get-cross-lib-extra-search-dirs
find-user-lib-dir
path->relative-string/lib
"libs.rktd" #t
@ -1991,6 +2021,7 @@
'copy-shared-files
'move-shared-files
find-share-dir
get-share-extra-search-dirs
find-user-share-dir
path->relative-string/share
"shares.rktd" #t
@ -2009,6 +2040,7 @@
'copy-man-pages
'move-man-pages
find-man-dir
get-man-extra-search-dirs
find-user-man-dir
path->relative-string/man
"mans.rktd" #f

20
racket/collects/setup/variant.rkt
View File

@ -4,7 +4,8 @@
setup/cross-system
racket/promise)
(provide variant-suffix)
(provide variant-suffix
script-variant?)
(define plain-variant
(delay/sync
@ -14,13 +15,13 @@
'cs
(cross-system-type 'gc))]
[else
(let* ([dir (find-console-bin-dir)]
[exe (cond [(eq? 'windows (system-type)) "Racket.exe"]
[(equal? #".dll" (system-type 'so-suffix))
;; in cygwin so-suffix is ".dll"
"racket.exe"]
[else "racket"])]
[f (build-path dir exe)])
(for/or ([dir (in-list (get-console-bin-search-dirs))])
(define exe (cond [(eq? 'windows (system-type)) "Racket.exe"]
[(equal? #".dll" (system-type 'so-suffix))
;; in cygwin so-suffix is ".dll"
"racket.exe"]
[else "racket"]))
(define f (build-path dir exe))
(and (file-exists? f)
(with-input-from-file f
(lambda ()
@ -42,3 +43,6 @@
(if (eq? 'cs (force plain-variant)) "" "CS"))]
[else (error 'variant-suffix "unknown variant: ~e" variant)])])
(if cased? r (string-downcase r))))
(define (script-variant? v)
(memq v '(script-3m script-cgc script-cs)))

36
racket/src/start/config.inc
View File

@ -350,9 +350,9 @@ static void extract_built_in_arguments(const self_exe_t self_exe, char **_prog,
char **argv2;
p = NULL;
#ifdef DOS_FILE_SYSTEM
if ((scheme_cmdline_exe_hack[0] == '?')
|| (scheme_cmdline_exe_hack[0] == '*')) {
#ifdef DOS_FILE_SYSTEM
/* This is how we make launchers in Windows. The cmdline is
added as a resource of type 257. The long integer at
scheme_cmdline_exe_hack[4] says where the command line starts
@ -424,9 +424,7 @@ static void extract_built_in_arguments(const self_exe_t self_exe, char **_prog,
+ 4);
}
}
}
#else
if (scheme_cmdline_exe_hack[0] == '?') {
long fileoff, cmdoff, cmdlen, need, got;
int fd;
fileoff = get_segment_offset(self_exe);
@ -454,8 +452,38 @@ static void extract_built_in_arguments(const self_exe_t self_exe, char **_prog,
}
}
close(fd);
}
if (scheme_cmdline_exe_hack[0] == '*') {
/* "*" means that the first item is argv[0] replacement,
because this executable is being treated as a launcher */
sprog = prog;
prog = (char *)p + 4;
if (prog[0] == '/') {
/* Absolute path */
} else {
/* Make it absolute, relative to this executable */
int plen = strlen(prog);
int mlen = strlen(self_exe);
char *s2;
while (mlen && (self_exe[mlen - 1] != '/')) {
mlen--;
}
s2 = (char *)malloc(mlen + plen + 1);
memcpy(s2, self_exe, mlen);
memcpy(s2 + mlen, prog, plen + 1);
prog = s2;
}
p += (p[0]
+ (((long)p[1]) << 8)
+ (((long)p[2]) << 16)
+ (((long)p[3]) << 24)
+ 4);
}
#endif
}
if (!p)
p = (unsigned char *)scheme_cmdline_exe_hack + 1;

39
racket/src/start/ustart.c
View File

@ -18,7 +18,7 @@
# define PRESERVE_IN_EXECUTABLE /* empty */
#endif
/* The config string after : is replaced with ! followed by a sequence
/* The config string after : is replaced with ! or * followed by a sequence
of little-endian 4-byte ints:
start - offset into the binary
prog_end - offset; start to prog_end is the program region
@ -32,6 +32,10 @@
dll_path - DLL directory if non-empty (relative is w.r.t. executable)
cmdline_arg ...
A * instead of ! at the start means that `-E` should be skipped,
so that `(find-system-path 'exec-file)` refers to the started
executable instaed of this starter.
For ELF binaries, the absolute values of `start', `decl_end', `prog_end',
and `end' are ignored if a ".rackcmdl" (starter) or ".rackprog"
(embedding) section is found. The `start' value is set to match the
@ -301,7 +305,7 @@ int main(int argc, char **argv)
}
data = (char *)malloc(end - prog_end);
new_argv = (char **)malloc((count + argc + (2 * collcount) + 13) * sizeof(char*));
new_argv = (char **)malloc((count + argc + (2 * collcount) + 15) * sizeof(char*));
fd = open(embedding_me, O_RDONLY, 0);
lseek(fd, prog_end, SEEK_SET);
@ -345,13 +349,6 @@ int main(int argc, char **argv)
argpos = 1;
inpos = 1;
/* Add -E flag; we can't just put `me` in `argv[0]`, because some
OSes (well, just OpenBSD) cannot find the executable path of a
process, and the actual executable may be needed to find embedded
boot images. */
new_argv[argpos++] = "-E";
new_argv[argpos++] = me;
/* Keep all X11 flags to the front: */
if (x11) {
int n;
@ -372,6 +369,17 @@ int main(int argc, char **argv)
}
}
if (config[7] != '*') {
/* Add -E flag; we can't just put `me` in `argv[0]`, because some
OSes (well, just OpenBSD) cannot find the executable path of a
process, and the actual executable may be needed to find embedded
boot images. */
new_argv[argpos++] = "-E";
new_argv[argpos++] = me;
}
new_argv[argpos++] = "-N";
new_argv[argpos++] = me;
/* Add -X and -S flags */
{
int offset, len;
@ -392,11 +400,14 @@ int main(int argc, char **argv)
new_argv[argpos++] = "-G";
new_argv[argpos++] = absolutize(_configdir + _configdir_offset, me);
/* next four args are "-k" and numbers; leave room to insert the
filename in place of "-k", and fix the numbers to match start,
decl_end, and prog_end */
new_argv[argpos++] = "-Y";
fix_argv = argpos;
if (count && !strcmp(data, "-k")) {
/* next four args are "-k" and numbers; leave room to insert the
filename in place of "-k", and fix the numbers to match start,
decl_end, and prog_end */
new_argv[argpos++] = "-Y";
fix_argv = argpos;
} else
fix_argv = 0;
/* Add built-in flags: */
while (count--) {