diff --git a/pkgs/racket-doc/scribblings/raco/config.scrbl b/pkgs/racket-doc/scribblings/raco/config.scrbl index f0b6a29727..6bd883ed63 100644 --- a/pkgs/racket-doc/scribblings/raco/config.scrbl +++ b/pkgs/racket-doc/scribblings/raco/config.scrbl @@ -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 diff --git a/pkgs/racket-doc/scribblings/raco/exe-api.scrbl b/pkgs/racket-doc/scribblings/raco/exe-api.scrbl index 7da25d3639..5c0e334ff0 100644 --- a/pkgs/racket-doc/scribblings/raco/exe-api.scrbl +++ b/pkgs/racket-doc/scribblings/raco/exe-api.scrbl @@ -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 diff --git a/pkgs/racket-doc/scribblings/raco/setup.scrbl b/pkgs/racket-doc/scribblings/raco/setup.scrbl index 7bcac523cb..a99cbe2040 100644 --- a/pkgs/racket-doc/scribblings/raco/setup.scrbl +++ b/pkgs/racket-doc/scribblings/raco/setup.scrbl @@ -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. diff --git a/pkgs/racket-index/setup/private/doc-path.rkt b/pkgs/racket-index/setup/private/doc-path.rkt index 9fc7fd4bda..875c3de50f 100644 --- a/pkgs/racket-index/setup/private/doc-path.rkt +++ b/pkgs/racket-index/setup/private/doc-path.rkt @@ -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))])) diff --git a/pkgs/racket-index/setup/scribble.rkt b/pkgs/racket-index/setup/scribble.rkt index 22c339bcc8..21ab76f247 100644 --- a/pkgs/racket-index/setup/scribble.rkt +++ b/pkgs/racket-index/setup/scribble.rkt @@ -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, diff --git a/racket/collects/compiler/embed.rkt b/racket/collects/compiler/embed.rkt index b1aa836aad..24741357d5 100644 --- a/racket/collects/compiler/embed.rkt +++ b/racket/collects/compiler/embed.rkt @@ -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 () diff --git a/racket/collects/compiler/find-exe.rkt b/racket/collects/compiler/find-exe.rkt index bdad1f3e9d..936648302d 100644 --- a/racket/collects/compiler/find-exe.rkt +++ b/racket/collects/compiler/find-exe.rkt @@ -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) diff --git a/racket/collects/launcher/launcher.rkt b/racket/collects/launcher/launcher.rkt index 68eee3ad87..0481546a5c 100644 --- a/racket/collects/launcher/launcher.rkt +++ b/racket/collects/launcher/launcher.rkt @@ -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)) diff --git a/racket/collects/racket/private/tethered-installer.rkt b/racket/collects/racket/private/tethered-installer.rkt index f033e946a3..e95f0c2940 100644 --- a/racket/collects/racket/private/tethered-installer.rkt +++ b/racket/collects/racket/private/tethered-installer.rkt @@ -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))))))) diff --git a/racket/collects/setup/cross-system.rkt b/racket/collects/setup/cross-system.rkt index 9acc4d6982..22de94f89b 100644 --- a/racket/collects/setup/cross-system.rkt +++ b/racket/collects/setup/cross-system.rkt @@ -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 diff --git a/racket/collects/setup/dirs.rkt b/racket/collects/setup/dirs.rkt index 4d93a7e25f..3721a8fabe 100644 --- a/racket/collects/setup/dirs.rkt +++ b/racket/collects/setup/dirs.rkt @@ -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 diff --git a/racket/collects/setup/main-doc.rkt b/racket/collects/setup/main-doc.rkt index e548a08fd9..ce5c5de3a8 100644 --- a/racket/collects/setup/main-doc.rkt +++ b/racket/collects/setup/main-doc.rkt @@ -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)) diff --git a/racket/collects/setup/path-relativize.rkt b/racket/collects/setup/path-relativize.rkt index 4a02adf8a7..a2e4b134da 100644 --- a/racket/collects/setup/path-relativize.rkt +++ b/racket/collects/setup/path-relativize.rkt @@ -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 # 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)] diff --git a/racket/collects/setup/private/dirs.rkt b/racket/collects/setup/private/dirs.rkt index e0e2abc318..745e9c0f59 100644 --- a/racket/collects/setup/private/dirs.rkt +++ b/racket/collects/setup/private/dirs.rkt @@ -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 diff --git a/racket/collects/setup/setup-core.rkt b/racket/collects/setup/setup-core.rkt index 0674bdc9f9..dc0fc391c8 100755 --- a/racket/collects/setup/setup-core.rkt +++ b/racket/collects/setup/setup-core.rkt @@ -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 diff --git a/racket/collects/setup/variant.rkt b/racket/collects/setup/variant.rkt index 9c9b3e6fa2..81da6f5701 100644 --- a/racket/collects/setup/variant.rkt +++ b/racket/collects/setup/variant.rkt @@ -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))) diff --git a/racket/src/start/config.inc b/racket/src/start/config.inc index 69dcf83eeb..00225f3215 100644 --- a/racket/src/start/config.inc +++ b/racket/src/start/config.inc @@ -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; diff --git a/racket/src/start/ustart.c b/racket/src/start/ustart.c index a2a730403f..866dec6bc2 100644 --- a/racket/src/start/ustart.c +++ b/racket/src/start/ustart.c @@ -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--) {