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

user paths depend on name (not always version); no `shared' pkg scope

Browse Source 
An installation has a name (via the configuration file "config.rktd")
that defaults to the version string. The name, instead of the
Racket version, is used for forming the path to the user "collects"
directory, user packages, and so on. The `user' package scope is
thus user- and installation-name-specific (instead of user- and
version-specific).

Remove `shared' package and link scope, since the notion of
installation names generalizes the concept (a set of installations
can be given the same name) and fits it into `user' scope.
This commit is contained in:
Matthew Flatt 2013-07-25 20:24:52 -06:00
parent e0bab441a8
commit afe8c37a2a
25 changed files with 1140 additions and 1222 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

1
pkgs/drracket-pkgs/drracket/pkg/gui/by-installed.rkt
View File

@ -20,7 +20,6 @@
[else [else
(case a (case a
[(installation) #t] [(installation) #t]
[(user) (eq? b 'shared)]
[else #f])])) [else #f])]))
(define (ipkg<? a b) (define (ipkg<? a b)

13
pkgs/drracket-pkgs/drracket/pkg/gui/by-source.rkt
View File

@ -38,7 +38,6 @@
(define sc-install-pkg-scope-label (string-constant install-pkg-scope-label)) (define sc-install-pkg-scope-label (string-constant install-pkg-scope-label))
(define sc-install-pkg-installation (string-constant install-pkg-installation)) (define sc-install-pkg-installation (string-constant install-pkg-installation))
(define sc-install-pkg-user (string-constant install-pkg-user)) (define sc-install-pkg-user (string-constant install-pkg-user))
(define sc-install-pkg-shared (string-constant install-pkg-shared))
(define sc-install-pkg-set-as-default (string-constant install-pkg-set-as-default)) (define sc-install-pkg-set-as-default (string-constant install-pkg-set-as-default))
(define sc-install-pkg-scope-is (string-constant install-pkg-scope-is)) (define sc-install-pkg-scope-is (string-constant install-pkg-scope-is))
@ -184,13 +183,11 @@
[callback (λ (x y) (adjust-all))] [callback (λ (x y) (adjust-all))]
[choices (list sc-install-pkg-default [choices (list sc-install-pkg-default
sc-install-pkg-installation sc-install-pkg-installation
sc-install-pkg-user sc-install-pkg-user)]))
sc-install-pkg-shared)]))
(define/private (selected-scope) (case (send scope-choice get-selection) (define/private (selected-scope) (case (send scope-choice get-selection)
[(0) (default-pkg-scope)] [(0) (default-pkg-scope)]
[(1) 'installation] [(1) 'installation]
[(2) 'user] [(2) 'user]))
[(3) 'shared]))
(define scope-default-button (new button% (define scope-default-button (new button%
[label sc-install-pkg-set-as-default] [label sc-install-pkg-set-as-default]
[font small-control-font] [font small-control-font]
@ -331,14 +328,12 @@
(send scope-msg set-label (format sc-install-pkg-scope-is (send scope-msg set-label (format sc-install-pkg-scope-is
(case (selected-scope) (case (selected-scope)
[(installation) sc-install-pkg-installation] [(installation) sc-install-pkg-installation]
[(user) sc-install-pkg-user] [(user) sc-install-pkg-user])))
[(shared) sc-install-pkg-shared])))
(define is-default? (let ([v (send scope-choice get-selection)]) (define is-default? (let ([v (send scope-choice get-selection)])
(or (zero? v) (or (zero? v)
(= v (case (default-pkg-scope) (= v (case (default-pkg-scope)
[(installation) 1] [(installation) 1]
[(user) 2] [(user) 2])))))
[(shared) 3])))))
(define deleted? (not (member scope-default-button (send scope-panel get-children)))) (define deleted? (not (member scope-default-button (send scope-panel get-children))))
(unless (equal? is-default? deleted?) (unless (equal? is-default? deleted?)
(if is-default? (if is-default?

2
pkgs/drracket-pkgs/drracket/pkg/gui/common.rkt
View File

@ -40,4 +40,4 @@
(if (equal? d main) (if (equal? d main)
'installation 'installation
d)))) d))))
'(user shared))) '(user)))

13
pkgs/racket-pkgs/racket-doc/pkg/scribblings/lib.scrbl
View File

@ -32,13 +32,14 @@ that are documented to require the lock. Other functions from
@racketmodname[pkg/lib] take the lock as needed.} @racketmodname[pkg/lib] take the lock as needed.}
@deftogether[( @deftogether[(
@defparam[current-pkg-scope scope (or/c 'installation 'user 'shared @defparam[current-pkg-scope scope (or/c 'installation 'user
(and/c path? complete-path?))] (and/c path? complete-path?))]
@defparam[current-pkg-scope-version s string?] @defparam[current-pkg-scope-version s string?]
)]{ )]{
Parameters that together determine @tech{package scope} for management Parameters that determine @tech{package scope} for management
operations and the version for version-specific scope.} operations and, in the case of @racket['user] scope, the relevant
installation name/version.}
@defparam[current-pkg-error err procedure?]{ @defparam[current-pkg-error err procedure?]{
@ -75,13 +76,13 @@ Returns the directory that holds the installation of the installed
is installed.} is installed.}
@defproc[(default-pkg-scope) (or/c 'installation 'user 'shared @defproc[(default-pkg-scope) (or/c 'installation 'user
(and/c path? complete-path?))]{ (and/c path? complete-path?))]{
Returns the user's configured default @tech{package scope}.} Returns the user's configured default @tech{package scope}.}
@defproc[(installed-pkg-names [#:scope scope (or/c #f 'installation 'user 'shared @defproc[(installed-pkg-names [#:scope scope (or/c #f 'installation 'user
(and/c path? complete-path?))]) (and/c path? complete-path?))])
(listof string?)]{ (listof string?)]{
@ -90,7 +91,7 @@ scope}, where @racket[#f] indicates the user's default @tech{package
scope}.} scope}.}
@defproc[(installed-pkg-table [#:scope scope (or/c #f 'installation 'user 'shared @defproc[(installed-pkg-table [#:scope scope (or/c #f 'installation 'user
(and/c path? complete-path?))]) (and/c path? complete-path?))])
(hash/c string? pkg-info?)]{ (hash/c string? pkg-info?)]{

54
pkgs/racket-pkgs/racket-doc/pkg/scribblings/pkg.scrbl
View File

@ -243,17 +243,15 @@ the version is part of the source. A @tech{single-collection package}
can be a @tech{package update} of a @tech{multi-collection package} can be a @tech{package update} of a @tech{multi-collection package}
and vice versa. and vice versa.
A @deftech{package scope} determines the effect of package installations, A @deftech{package scope} determines the effect of package
updates, @|etc|, with respect to different users, Racket versions, and installations, updates, @|etc|, with respect to different users and
Racket installations. The default @tech{package scope} can be configured, but it is Racket installations. The default @tech{package scope} can be
normally @exec{user}, which is user-specific and version-specific; configured, but it is normally @exec{user}, which makes actions
that is, package installation makes the package visible only for the specific to both the current user and the installation's name/version
installing user and with the installing version of Racket. The (in the sense of @racket[get-installation-name]). The
@exec{installation} scope means that package installation makes the @exec{installation} scope means that package operations affect
package visible to all users of the specific Racket installation that all users of the Racket installation.
is used to install the package. The @exec{shared} scope means Finally, a directory path can be used as a @tech{package scope}, in which case
user-specific, but for all versions and installations of Racket.
Finally, a directory path can be used as a package scope, in which case
package operations affect the set of packages installations in the package operations affect the set of packages installations in the
directory (and an installation can be configured to include the directory (and an installation can be configured to include the
directory in its search path for installed packages). directory in its search path for installed packages).
@ -325,14 +323,12 @@ sub-sub-commands:
@item{@DFlag{scope} @nonterm{scope} --- Selects the @tech{package scope} for installation, where @nonterm{scope} is one of @item{@DFlag{scope} @nonterm{scope} --- Selects the @tech{package scope} for installation, where @nonterm{scope} is one of
@itemlist[ @itemlist[
@item{@exec{installation} --- Install packages for all users of a Racket installation, rather than user-specific.} @item{@exec{installation} --- Install packages for all users of a Racket installation, rather than user-specific.}
@item{@exec{user} --- Install packages as user-specific and Racket version-specific.} @item{@exec{user} --- Install packages for the current user and current installation's name/version.}
@item{@exec{shared} --- Install packages as user-specific, but for all Racket versions.}
] ]
The default package scope is normally @exec{user}, but it can be configured with The default package scope is normally @exec{user}, but it can be configured with
@command-ref{config}@exec{ --set default-scope @nonterm{scope}}.} @command-ref{config}@exec{ --set default-scope @nonterm{scope}}.}
@item{@Flag{i} or @DFlag{installation} --- Shorthand for @exec{--scope installation}.} @item{@Flag{i} or @DFlag{installation} --- Shorthand for @exec{--scope installation}.}
@item{@Flag{u} or @DFlag{user} --- Shorthand for @exec{--scope user}.} @item{@Flag{u} or @DFlag{user} --- Shorthand for @exec{--scope user}.}
@item{@Flag{s} or @DFlag{shared} --- Shorthand for @exec{--scope shared}.}
@item{@DFlag{scope-dir} @nonterm{dir} --- Select @nonterm{dir} as the @tech{package scope}.} @item{@DFlag{scope-dir} @nonterm{dir} --- Select @nonterm{dir} as the @tech{package scope}.}
@item{@DFlag{catalog} @nonterm{catalog} --- Use @nonterm{catalog} instead of of the currently configured @item{@DFlag{catalog} @nonterm{catalog} --- Use @nonterm{catalog} instead of of the currently configured
@ -363,7 +359,6 @@ this command fails without installing any of the @nonterm{pkg}s
@item{@DFlag{scope} @nonterm{scope} --- Selects a @tech{package scope}, the same as for @command-ref{install}.} @item{@DFlag{scope} @nonterm{scope} --- Selects a @tech{package scope}, the same as for @command-ref{install}.}
@item{@Flag{i} or @DFlag{installation} --- Shorthand for @exec{--scope installation}.} @item{@Flag{i} or @DFlag{installation} --- Shorthand for @exec{--scope installation}.}
@item{@Flag{u} or @DFlag{user} --- Shorthand for @exec{--scope user}.} @item{@Flag{u} or @DFlag{user} --- Shorthand for @exec{--scope user}.}
@item{@Flag{s} or @DFlag{shared} --- Shorthand for @exec{--scope shared}.}
@item{@DFlag{scope-dir} @nonterm{dir} --- Selects @nonterm{dir} as the @tech{package scope}, the same as for @command-ref{install}.} @item{@DFlag{scope-dir} @nonterm{dir} --- Selects @nonterm{dir} as the @tech{package scope}, the same as for @command-ref{install}.}
@item{@DFlag{no-setup} --- Same as for @command-ref{install}.} @item{@DFlag{no-setup} --- Same as for @command-ref{install}.}
@item{@DFlag{binary} --- Same as for @command-ref{install}.} @item{@DFlag{binary} --- Same as for @command-ref{install}.}
@ -387,7 +382,6 @@ removing any of the @nonterm{pkg}s.
@item{@DFlag{scope} @nonterm{scope} --- Selects a @tech{package scope}, the same as for @command-ref{install}.} @item{@DFlag{scope} @nonterm{scope} --- Selects a @tech{package scope}, the same as for @command-ref{install}.}
@item{@Flag{i} or @DFlag{installation} --- Shorthand for @exec{--scope installation}.} @item{@Flag{i} or @DFlag{installation} --- Shorthand for @exec{--scope installation}.}
@item{@Flag{u} or @DFlag{user} --- Shorthand for @exec{--scope user}.} @item{@Flag{u} or @DFlag{user} --- Shorthand for @exec{--scope user}.}
@item{@Flag{s} or @DFlag{shared} --- Shorthand for @exec{--scope shared}.}
@item{@DFlag{scope-dir} @nonterm{dir} --- Selects @nonterm{dir} as the @tech{package scope}, the same as for @command-ref{install}.} @item{@DFlag{scope-dir} @nonterm{dir} --- Selects @nonterm{dir} as the @tech{package scope}, the same as for @command-ref{install}.}
@item{@DFlag{no-setup} --- Same as for @command-ref{install}.} @item{@DFlag{no-setup} --- Same as for @command-ref{install}.}
@item{@DFlag{jobs} @nonterm{n} or @Flag{j} @nonterm{n} --- Same as for @command-ref{install}.} @item{@DFlag{jobs} @nonterm{n} or @Flag{j} @nonterm{n} --- Same as for @command-ref{install}.}
@ -395,8 +389,7 @@ removing any of the @nonterm{pkg}s.
} }
@item{@command/toc{show} @nonterm{option} ... --- Print information about currently installed packages. @item{@command/toc{show} @nonterm{option} ... --- Print information about currently installed packages.
By default, packages are shown for all installation modes (installation-wide, By default, packages are shown for all @tech{package scopes}, but only for packages
user- and Racket-version-specific, and user-specific all-version), but only for packages
not marked as auto-installed to fulfill dependencies. not marked as auto-installed to fulfill dependencies.
The @exec{show} sub-command accepts The @exec{show} sub-command accepts
@ -410,15 +403,15 @@ removing any of the @nonterm{pkg}s.
@item{@DFlag{scope} @nonterm{scope} --- Shows only packages in @nonterm{scope}, which is one of @item{@DFlag{scope} @nonterm{scope} --- Shows only packages in @nonterm{scope}, which is one of
@itemlist[ @itemlist[
@item{@exec{installation} --- Show only installation-wide packages.} @item{@exec{installation} --- Show only installation-wide packages.}
@item{@exec{user} --- Show only user-specific, version-specific packages.} @item{@exec{user} --- Show only user-specific packages for the current installation's name/version
@item{@exec{shared} --- Show only user-specific, all-version packages.} or the name/version specified with @DFlag{version} or @Flag{v}.}
] ]
The default is to show packages for all @tech{package scopes}.} The default is to show packages for all @tech{package scopes}.}
@item{@Flag{i} or @DFlag{installation} --- Shorthand for @exec{--scope installation}.} @item{@Flag{i} or @DFlag{installation} --- Shorthand for @exec{--scope installation}.}
@item{@Flag{u} or @DFlag{user} --- Shorthand for @exec{--scope user}.} @item{@Flag{u} or @DFlag{user} --- Shorthand for @exec{--scope user}.}
@item{@Flag{s} or @DFlag{shared} --- Shorthand for @exec{--scope shared}.}
@item{@DFlag{scope-dir} @nonterm{dir} --- Shows only packages installed in @nonterm{dir}.} @item{@DFlag{scope-dir} @nonterm{dir} --- Shows only packages installed in @nonterm{dir}.}
@item{@DFlag{version} @nonterm{vers} or @Flag{v} @nonterm{vers} --- Show only user-specific packages for Racket version @nonterm{vers}.} @item{@DFlag{version} @nonterm{vers} or @Flag{v} @nonterm{vers} --- Show only user-specific packages for
the installation name/version @nonterm{vers}.}
] ]
} }
@ -462,20 +455,17 @@ View and modify configuration of the package manager itself, with the following
@item{@DFlag{set} --- Sets an option, rather than printing it.} @item{@DFlag{set} --- Sets an option, rather than printing it.}
@item{@DFlag{scope} @nonterm{scope} --- Selects a @tech{package scope}, the same as for @command-ref{install}. @item{@DFlag{scope} @nonterm{scope} --- Selects a @tech{package scope}, the same as for @command-ref{install}.
A configuration value set at @exec{installation} scope serves A configuration value set at @exec{installation} scope serves
as the default value at @exec{shared} scope, and
a configuration value set at @exec{shared} scope serves
as the default value at @exec{user} scope.} as the default value at @exec{user} scope.}
@item{@Flag{i} or @DFlag{installation} --- Shorthand for @exec{--scope installation}.} @item{@Flag{i} or @DFlag{installation} --- Shorthand for @exec{--scope installation}.}
@item{@Flag{u} or @DFlag{user} --- Shorthand for @exec{--scope user}.} @item{@Flag{u} or @DFlag{user} --- Shorthand for @exec{--scope user}.}
@item{@Flag{s} or @DFlag{shared} --- Shorthand for @exec{--scope shared}.}
] ]
The valid keys are: The valid keys are:
@itemlist[ @itemlist[
@item{@exec{catalogs} --- A list of URLs for @tech{package catalogs}.} @item{@exec{catalogs} --- A list of URLs for @tech{package catalogs}.}
@item{@exec{default-scope} --- Either @exec{installation}, @exec{user}, or @exec{shared}. @item{@exec{default-scope} --- Either @exec{installation} or @exec{user}.
The value of this key at @exec{user} scope (possibly defaulting from The value of this key at @exec{user} scope (possibly defaulting from
@exec{shared} or @exec{installation} scope) is @exec{installation} scope) is
the default @tech{package scope} for all @exec{raco pkg} commands the default @tech{package scope} for all @exec{raco pkg} commands
(even @command{config}, which is consistent but potentially confusing).} (even @command{config}, which is consistent but potentially confusing).}
] ]
@ -930,13 +920,9 @@ and rebuilt.
If you change the default @tech{package scope}, you can use the If you change the default @tech{package scope}, you can use the
@Flag{u} or @DFlag{user} flag with a specific @exec{raco pkg} command @Flag{u} or @DFlag{user} flag with a specific @exec{raco pkg} command
to perform the command with user- and version-specific @tech{package to perform the command with user-specific @tech{package scope}.
scope}. User-specific scope is also specific for a Racket installation
name, where an installation name is typically a Racket version.
Finally, you can use the @Flag{s} or @DFlag{shared} flag
with @exec{raco pkg} commands to install user-specific packages that
apply to all Racket versions that you run. (In contrast, @|Planet1|
requires reinstallation of all packages every version change.)
@subsection{Where and how are packages installed?} @subsection{Where and how are packages installed?}

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

@ -90,6 +90,11 @@ directory:
path for resolving package names; an @racket[#f] in the list path for resolving package names; an @racket[#f] in the list
is replaced with the default search path.} is replaced with the default search path.}
@item{@racket['installation-name] --- a string for the installation
name, which is used for packages in @exec{user}
@tech[#:doc '(lib "pkg/scribblings/pkg.scrbl")]{package
scope}; the default is @racket[(version)].}
@item{@racket['absolute-installation?] --- a boolean that is @item{@racket['absolute-installation?] --- a boolean that is
@racket[#t] if the installation uses absolute path names, @racket[#t] if the installation uses absolute path names,
@racket[#f] otherwise.} @racket[#f] otherwise.}

42
pkgs/racket-pkgs/racket-doc/scribblings/raco/link.scrbl
View File

@ -4,7 +4,8 @@
"common.rkt" "common.rkt"
(for-label racket/base (for-label racket/base
racket/contract racket/contract
setup/link)) setup/link
setup/dirs))
@title[#:tag "link"]{@exec{raco link}: Library Collection Links} @title[#:tag "link"]{@exec{raco link}: Library Collection Links}
@ -55,7 +56,7 @@ Full command-line options:
any other command-line arguments are provided that modify the any other command-line arguments are provided that modify the
link table, the table is shown after modifications. If no link table, the table is shown after modifications. If no
directory arguments are provided, and if none of @Flag{u}, directory arguments are provided, and if none of @Flag{u},
@DFlag{user}, @Flag{s}, @DFlag{shared}, @Flag{i}, @DFlag{installation}, @Flag{f}, or @DFlag{user}, @Flag{i}, @DFlag{installation}, @Flag{f}, or
@DFlag{file} are specified, then the link table is shown for @DFlag{file} are specified, then the link table is shown for
all user-specific and installation-wide @tech[#:doc all user-specific and installation-wide @tech[#:doc
reference-doc]{collection links files}.} reference-doc]{collection links files}.}
@ -86,7 +87,8 @@ Full command-line options:
@nonterm{regexp} --- Sets a version regexp that limits the link @nonterm{regexp} --- Sets a version regexp that limits the link
to use only by Racket versions (as reported by to use only by Racket versions (as reported by
@racket[version]) matching @nonterm{regexp}. This flag @racket[version]) matching @nonterm{regexp}. This flag
is normally used with @Flag{s} or @DFlag{shared}. When the @Flag{r} is normally used with @Flag{u} or @DFlag{user} with installations
that have different versions but the same installation name. When the @Flag{r}
or @DFlag{remove} flag is also used, only links with a or @DFlag{remove} flag is also used, only links with a
version regexp matching @nonterm{regexp} are removed.} version regexp matching @nonterm{regexp} are removed.}
@ -94,24 +96,17 @@ Full command-line options:
of add mode.} of add mode.}
@item{@Flag{u} or @DFlag{user} --- Limits listing and removal @item{@Flag{u} or @DFlag{user} --- Limits listing and removal
of links to the user- and version-specific @tech[#:doc of links to the user-specific @tech[#:doc
reference-doc]{collection links file} and not the all-version or reference-doc]{collection links file} and not the
collection-wide @tech[#:doc reference-doc]{collection links installation-wide @tech[#:doc reference-doc]{collection links
file}. This flag is mutually exclusive with @Flag{s}, @DFlag{shared}, @Flag{i}, file}. This flag is mutually exclusive with @Flag{i},
@DFlag{installation}, @Flag{f}, and @DFlag{file}.}
@item{@Flag{s} or @DFlag{shared} --- Limits listing and removal
of links to the user-specific, all-version @tech[#:doc
reference-doc]{collection links file} and not the version-specific or
collection-wide @tech[#:doc reference-doc]{collection links
file}. This flag is mutually exclusive with @Flag{u}, @DFlag{user}, @Flag{i},
@DFlag{installation}, @Flag{f}, and @DFlag{file}.} @DFlag{installation}, @Flag{f}, and @DFlag{file}.}
@item{@Flag{i} or @DFlag{installation} --- Reads and writes links in @item{@Flag{i} or @DFlag{installation} --- Reads and writes links in
installation-wide @tech[#:doc reference-doc]{collection links installation-wide @tech[#:doc reference-doc]{collection links
file} and not the user-specific @tech[#:doc file} and not the user-specific @tech[#:doc
reference-doc]{collection links file}. This flag is mutually reference-doc]{collection links file}. This flag is mutually
exclusive with @Flag{u}, @DFlag{user}, @Flag{s}, @DFlag{shared}, @Flag{f}, and exclusive with @Flag{u}, @DFlag{user}, @Flag{f}, and
@DFlag{file}.} @DFlag{file}.}
@item{@Flag{f} @nonterm{file} or @DFlag{file} @nonterm{file} --- @item{@Flag{f} @nonterm{file} or @DFlag{file} @nonterm{file} ---
@ -120,6 +115,11 @@ Full command-line options:
file}. This flag is mutually exclusive with @Flag{u}, file}. This flag is mutually exclusive with @Flag{u},
@DFlag{user}, @Flag{s}, @DFlag{shared}, @Flag{i}, and @DFlag{installation}.} @DFlag{user}, @Flag{s}, @DFlag{shared}, @Flag{i}, and @DFlag{installation}.}
@item{@Flag{v} @nonterm{vers} or @DFlag{version} @nonterm{vers} ---
Selects @nonterm{vers} as relevant installation name for
operations on the user-specific @tech[#:doc
reference-doc]{collection links file}.}
@item{@DFlag{repair} --- Enables repairs to the existing file content @item{@DFlag{repair} --- Enables repairs to the existing file content
when the content is erroneous. The file is repaired by deleting when the content is erroneous. The file is repaired by deleting
individual links when possible.} individual links when possible.}
@ -134,7 +134,7 @@ Full command-line options:
@defproc[(links [dir path?] ... @defproc[(links [dir path?] ...
[#:user? user? any/c #t] [#:user? user? any/c #t]
[#:shared? shared? any/c #t] [#:user-version user-version string? (get-installation-name)]
[#:file file (or/c path-string? #f) #f] [#:file file (or/c path-string? #f) #f]
[#:name name (or/c string? #f) #f] [#:name name (or/c string? #f) #f]
[#:root? root? any/c #f] [#:root? root? any/c #f]
@ -149,11 +149,11 @@ Full command-line options:
A function version of the @exec{raco link} command that always works A function version of the @exec{raco link} command that always works
on a single file---either @racket[file] if it is a path string, the on a single file---either @racket[file] if it is a path string, the
user- and version-specific @tech[#:doc reference-doc]{collection links file} if user--specific @tech[#:doc reference-doc]{collection links file} if
@racket[user?] is true and @racket[shared?] is false, the @racket[user?] is true, or the installation-wide @tech[#:doc
user-specific, all-version @tech[#:doc reference-doc]{collection links file} if reference-doc]{collection links file} otherwise. If @racket[user?]
@racket[shared?] is true, or the installation-wide @tech[#:doc is true, then @racket[user-version] determines the relevant
reference-doc]{collection links file} otherwise. installation name (defaulting to the current installation's name).
The @racket[static-root?] flag value is ignored unless @racket[root?] The @racket[static-root?] flag value is ignored unless @racket[root?]
is true and @racket[remove?] is false, in which case each given is true and @racket[remove?] is false, in which case each given

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

@ -991,16 +991,11 @@ v
installation scope; the directory indicated by the returned path may installation scope; the directory indicated by the returned path may
or may not exist.} or may not exist.}
@defproc[(find-user-pkgs-dir) path?]{ @defproc[(find-user-pkgs-dir [vers string? (get-installation-name)]) path?]{
Returns a path to the directory containing packages with Returns a path to the directory containing packages with
user- and version-specific scope; the directory indicated by user-specific scope for installation name @racket[vers]; the directory indicated by
the returned path may or may not exist.} the returned path may or may not exist.}
@defproc[(find-shared-pkgs-dir) path?]{
Returns a path to the directory containing packages with
user-specific, all-version scope; the directory indicated by the
returned path may or may not exist.}
@defproc[(get-pkgs-search-dirs) (listof path?)]{ @defproc[(get-pkgs-search-dirs) (listof path?)]{
Returns a list of paths to the directories containing packages in Returns a list of paths to the directories containing packages in
installation scope. (Normally, the result includes the result of installation scope. (Normally, the result includes the result of
@ -1104,6 +1099,11 @@ v
Returns a string that is used by the documentation system, augmented Returns a string that is used by the documentation system, augmented
with a version and search-key query, for remote documentation links.} with a version and search-key query, for remote documentation links.}
@defproc[(get-installation-name) string?]{ Returns the current
installation's name, which is often @racket[(version)] but can be
configured via @racket['installation-name] in @filepath{config.rktd}
(see @secref["config-file"]).}
@defthing[absolute-installation? boolean?]{ @defthing[absolute-installation? boolean?]{
A binary boolean flag that is true if this installation is using A binary boolean flag that is true if this installation is using
absolute path names.} absolute path names.}

15
pkgs/racket-pkgs/racket-doc/scribblings/reference/collects.scrbl
View File

@ -91,7 +91,7 @@ Produces a list of paths as follows:
@itemize[ @itemize[
@item{The path produced by @racket[(build-path (find-system-path @item{The path produced by @racket[(build-path (find-system-path
'addon-dir) (version) "collects")] is the first element of the 'addon-dir) (get-installation-name) "collects")] is the first element of the
default collection path list, unless the value of the default collection path list, unless the value of the
@racket[use-user-specific-search-paths] parameter is @racket[#f].} @racket[use-user-specific-search-paths] parameter is @racket[#f].}
@ -197,17 +197,14 @@ The @deftech{collection links files} are used by
default @tech{module name resolver} to locate collections before default @tech{module name resolver} to locate collections before
trying the @racket[(current-library-collection-paths)] search trying the @racket[(current-library-collection-paths)] search
path, but only if the @racket[use-collection-link-paths] parameter is set to path, but only if the @racket[use-collection-link-paths] parameter is set to
@racket[#t]. Furthermore, a user- and version-specific @tech{collection links file} takes @racket[#t]. Furthermore, a user-specific @tech{collection links file} takes
precedence over a user-specific and all-version @tech{collection links file}, precedence over an installation-wide @tech{collection links file}.
which in turn takes precedence over an installation-wide @tech{collection links file}. The user-specific @tech{collection links file} is used only if the
The user-specific @tech{collection links files} are used only if the
@racket[use-user-specific-search-paths] parameter is set to @racket[use-user-specific-search-paths] parameter is set to
@racket[#t]. @racket[#t].
The path of the user- and version-specific @tech{collection links file} is The path of the user--specific @tech{collection links file} is
@racket[(build-path (find-system-path 'addon-dir) (version) "links.rktd")]. @racket[(build-path (find-system-path 'addon-dir) (get-installation-name) "links.rktd")].
The path of the user-specific and all-version @tech{collection links file} is
@racket[(build-path (find-system-path 'addon-dir) "links.rktd")].
The path of the installation-wide @tech{collection links file} is The path of the installation-wide @tech{collection links file} is
@racket[(build-path (find-config-dir) "links.rktd")]. @racket[(build-path (find-config-dir) "links.rktd")].
Each @tech{collection links file} is cached by Racket, but Each @tech{collection links file} is cached by Racket, but

20
pkgs/racket-pkgs/racket-test/tests/pkg/tests-config.rkt
View File

@ -7,20 +7,12 @@
(shelly-case (shelly-case
"reading and writing configs" "reading and writing configs"
$ "raco pkg config catalogs" =stdout> "https://pkg.racket-lang.org\nhttps://planet-compat.racket-lang.org\n" $ "raco pkg config catalogs" =stdout> "https://pkg.racket-lang.org\nhttps://planet-compat.racket-lang.org\n"
$ "raco pkg config -s --set catalogs http://localhost:9000" $ "raco pkg config -u --set catalogs http://localhost:9000"
$ "raco pkg config -s catalogs" =stdout> "http://localhost:9000\n" $ "raco pkg config -u catalogs" =stdout> "http://localhost:9000\n"
;; shared value inherited as user:
$ "raco pkg config catalogs" =stdout> "http://localhost:9000\n"
;; user separate from shared:
$ "raco pkg config --set -u catalogs http://localhost:0999"
$ "raco pkg config -u catalogs" =stdout> "http://localhost:0999\n"
$ "raco pkg config -s catalogs" =stdout> "http://localhost:9000\n"
;; can set default scope: ;; can set default scope:
$ "raco pkg config --set -u default-scope shared" $ "raco pkg config --set -u default-scope installation"
$ "raco pkg config -u default-scope" =stdout> "shared\n" $ "raco pkg config -u default-scope" =stdout> "installation\n"
$ "raco pkg config -s default-scope" =stdout> "user\n" $ "raco pkg config -i default-scope" =stdout> "user\n"
$ "raco pkg config default-scope" =stdout> "user\n" $ "raco pkg config default-scope" =stdout> "user\n"
$ "raco pkg config catalogs" =stdout> "http://localhost:9000\n"))) $ "raco pkg config -u catalogs" =stdout> "http://localhost:9000\n")))

22
pkgs/racket-pkgs/racket-test/tests/pkg/tests-remove.rkt
View File

@ -20,7 +20,7 @@
(shelly-case (shelly-case
"remove and show" "remove and show"
(shelly-case "remove of not installed package fails" (shelly-case "remove of not installed package fails"
$ "raco pkg show -u" =stdout> " [none]\n" $ "raco pkg show -u -a" =stdout> " [none]\n"
$ "raco pkg remove not-there" =exit> 1) $ "raco pkg remove not-there" =exit> 1)
(shelly-install "remove test" (shelly-install "remove test"
"test-pkgs/pkg-test1.zip") "test-pkgs/pkg-test1.zip")
@ -29,12 +29,12 @@
"pkg-test1 pkg-test1") "pkg-test1 pkg-test1")
(shelly-install "remove of dep fails" (shelly-install "remove of dep fails"
"test-pkgs/pkg-test1.zip" "test-pkgs/pkg-test1.zip"
$ "raco pkg show -u" =stdout> #rx"Package\\[\\*=auto\\] +Checksum +Source\npkg-test1 +[a-f0-9]+ +\\(file .+tests/pkg/test-pkgs/pkg-test1.zip\\)\n" $ "raco pkg show -u -a" =stdout> #rx"Package\\[\\*=auto\\] +Checksum +Source\npkg-test1 +[a-f0-9]+ +\\(file .+tests/pkg/test-pkgs/pkg-test1.zip\\)\n"
$ "raco pkg install test-pkgs/pkg-test2.zip" $ "raco pkg install test-pkgs/pkg-test2.zip"
$ "raco pkg show -u" =stdout> #rx"Package\\[\\*=auto\\] +Checksum +Source\npkg-test1 +[a-f0-9]+ +\\(file .+tests/pkg/test-pkgs/pkg-test1.zip\\)\npkg-test2 +[a-f0-9]+ +\\(file .+tests/pkg/test-pkgs/pkg-test2.zip\\)\n" $ "raco pkg show -u -a" =stdout> #rx"Package\\[\\*=auto\\] +Checksum +Source\npkg-test1 +[a-f0-9]+ +\\(file .+tests/pkg/test-pkgs/pkg-test1.zip\\)\npkg-test2 +[a-f0-9]+ +\\(file .+tests/pkg/test-pkgs/pkg-test2.zip\\)\n"
$ "raco pkg remove pkg-test1" =exit> 1 =stderr> #rx"pkg-test1 \\(required by: \\(pkg-test2\\)\\)" $ "raco pkg remove pkg-test1" =exit> 1 =stderr> #rx"pkg-test1 \\(required by: \\(pkg-test2\\)\\)"
$ "raco pkg remove pkg-test2" $ "raco pkg remove pkg-test2"
$ "raco pkg show -u" =stdout> #rx"Package\\[\\*=auto\\] +Checksum +Source\npkg-test1 +[a-f0-9]+ +\\(file .+tests/pkg/test-pkgs/pkg-test1.zip\\)\n") $ "raco pkg show -u -a" =stdout> #rx"Package\\[\\*=auto\\] +Checksum +Source\npkg-test1 +[a-f0-9]+ +\\(file .+tests/pkg/test-pkgs/pkg-test1.zip\\)\n")
(shelly-install "remove of dep can be forced" (shelly-install "remove of dep can be forced"
"test-pkgs/pkg-test1.zip" "test-pkgs/pkg-test1.zip"
$ "raco pkg install test-pkgs/pkg-test2.zip" $ "raco pkg install test-pkgs/pkg-test2.zip"
@ -62,21 +62,21 @@
$ "racket -e '(require pkg-test1)'" =exit> 1 $ "racket -e '(require pkg-test1)'" =exit> 1
$ "racket -e '(require pkg-test2)'" =exit> 1 $ "racket -e '(require pkg-test2)'" =exit> 1
$ "raco pkg install --deps search-auto test-pkgs/pkg-test2.zip" =exit> 0 $ "raco pkg install --deps search-auto test-pkgs/pkg-test2.zip" =exit> 0
$ "raco pkg show -u" =stdout> #rx"Package\\[\\*=auto\\] +Checksum +Source\npkg-test1\\* +[a-f0-9]+ +\\(catalog pkg-test1\\)\npkg-test2 +[a-f0-9]+ +\\(file .+tests/pkg/test-pkgs/pkg-test2.zip\\)\n" $ "raco pkg show -u -a" =stdout> #rx"Package\\[\\*=auto\\] +Checksum +Source\npkg-test1\\* +[a-f0-9]+ +\\(catalog pkg-test1\\)\npkg-test2 +[a-f0-9]+ +\\(file .+tests/pkg/test-pkgs/pkg-test2.zip\\)\n"
$ "racket -e '(require pkg-test1)'" =exit> 0 $ "racket -e '(require pkg-test1)'" =exit> 0
$ "racket -e '(require pkg-test2)'" =exit> 0 $ "racket -e '(require pkg-test2)'" =exit> 0
$ "racket -e '(require pkg-test2/contains-dep)'" =exit> 0 $ "racket -e '(require pkg-test2/contains-dep)'" =exit> 0
$ "raco pkg remove pkg-test2" $ "raco pkg remove pkg-test2"
$ "raco pkg show -u" =stdout> #rx"Package\\[\\*=auto\\] +Checksum +Source\npkg-test1\\* +[a-f0-9]+ +\\(catalog pkg-test1\\)\n" $ "raco pkg show -u -a" =stdout> #rx"Package\\[\\*=auto\\] +Checksum +Source\npkg-test1\\* +[a-f0-9]+ +\\(catalog pkg-test1\\)\n"
$ "racket -e '(require pkg-test1)'" =exit> 0 $ "racket -e '(require pkg-test1)'" =exit> 0
$ "raco pkg remove --auto" $ "raco pkg remove --auto"
$ "raco pkg show -u" =stdout> " [none]\n" $ "raco pkg show -u -a" =stdout> " [none]\n"
$ "racket -e '(require pkg-test1)'" =exit> 1 $ "racket -e '(require pkg-test1)'" =exit> 1
$ "racket -e '(require pkg-test2)'" =exit> 1)) $ "racket -e '(require pkg-test2)'" =exit> 1))
(with-fake-root (with-fake-root
(shelly-case (shelly-case
"different scope error" "different scope error"
$ "raco pkg install --shared test-pkgs/pkg-test1.zip" =exit> 0 $ "raco pkg install test-pkgs/pkg-test1.zip" =exit> 0
$ "raco pkg remove pkg-test1" =exit> 1 $ "raco pkg remove --installation pkg-test1" =exit> 1
=stderr> #rx"package installed in a different scope: shared" =stderr> #rx"package installed in a different scope: user"
$ "raco pkg remove --shared pkg-test1"))))) $ "raco pkg remove pkg-test1")))))

8
pkgs/racket-pkgs/racket-test/tests/pkg/tests-update-auto.rkt
View File

@ -46,12 +46,12 @@
'source 'source
"http://localhost:9999/pkg-a-first.plt")) "http://localhost:9999/pkg-a-first.plt"))
$ "raco pkg install --deps search-auto pkg-b" =exit> 0 <input= "y\n" $ "raco pkg install --deps search-auto pkg-b" =exit> 0 <input= "y\n"
$ "raco pkg show -u" =stdout> #rx"Package\\[\\*=auto\\] +Checksum +Source\npkg-a\\* +[a-f0-9]+ \\(catalog pkg-a\\)\npkg-b +[a-f0-9]+ +\\(catalog pkg-b\\)\n" $ "raco pkg show -u -a" =stdout> #rx"Package\\[\\*=auto\\] +Checksum +Source\npkg-a\\* +[a-f0-9]+ \\(catalog pkg-a\\)\npkg-b +[a-f0-9]+ +\\(catalog pkg-b\\)\n"
$ "racket -e '(require pkg-b)'" =exit> 43 $ "racket -e '(require pkg-b)'" =exit> 43
$ "racket -e '(require pkg-a)'" =exit> 0 $ "racket -e '(require pkg-a)'" =exit> 0
;; remove auto doesn't do anything because everything is needed ;; remove auto doesn't do anything because everything is needed
$ "raco pkg remove --auto" $ "raco pkg remove --auto"
$ "raco pkg show -u" =stdout> #rx"Package\\[\\*=auto\\] +Checksum +Source\npkg-a\\* +[a-f0-9]+ \\(catalog pkg-a\\)\npkg-b +[a-f0-9]+ +\\(catalog pkg-b\\)\n" $ "raco pkg show -u -a" =stdout> #rx"Package\\[\\*=auto\\] +Checksum +Source\npkg-a\\* +[a-f0-9]+ \\(catalog pkg-a\\)\npkg-b +[a-f0-9]+ +\\(catalog pkg-b\\)\n"
$ "racket -e '(require pkg-b)'" =exit> 43 $ "racket -e '(require pkg-b)'" =exit> 43
$ "racket -e '(require pkg-a)'" =exit> 0 $ "racket -e '(require pkg-a)'" =exit> 0
;; pkg-a is now an auto ;; pkg-a is now an auto
@ -63,9 +63,9 @@
$ "raco pkg update -a" =exit> 0 $ "raco pkg update -a" =exit> 0
$ "racket -e '(require pkg-a)'" =exit> 43 $ "racket -e '(require pkg-a)'" =exit> 43
$ "raco pkg remove pkg-b" $ "raco pkg remove pkg-b"
$ "raco pkg show -u" =stdout> #rx"Package\\[\\*=auto\\] +Checksum +Source\npkg-a\\* +[a-f0-9]+ +\\(catalog pkg-a\\)\n" $ "raco pkg show -u -a" =stdout> #rx"Package\\[\\*=auto\\] +Checksum +Source\npkg-a\\* +[a-f0-9]+ +\\(catalog pkg-a\\)\n"
$ "racket -e '(require pkg-b)'" =exit> 1 $ "racket -e '(require pkg-b)'" =exit> 1
;; pkg-a is now not needed ;; pkg-a is now not needed
$ "raco pkg remove --auto" $ "raco pkg remove --auto"
$ "raco pkg show -u" =stdout> " [none]\n" $ "raco pkg show -u -a" =stdout> " [none]\n"
$ "racket -e '(require pkg-a)'" =exit> 1))) $ "racket -e '(require pkg-a)'" =exit> 1)))

4
pkgs/sandbox-lib/racket/sandbox.rkt
View File

@ -930,13 +930,11 @@
#:when (file-exists? f)) #:when (file-exists? f))
(links #:root? #t #:file f))) (links #:root? #t #:file f)))
(links #:root? #t #:user? #t) (links #:root? #t #:user? #t)
(links #:root? #t #:shared? #t)
(apply append (apply append
(for/list ([f (get-links-search-files)] (for/list ([f (get-links-search-files)]
#:when (file-exists? f)) #:when (file-exists? f))
(map cdr (links #:file f #:with-path? #t)))) (map cdr (links #:file f #:with-path? #t))))
(map cdr (links #:user? #t #:with-path? #t)) (map cdr (links #:user? #t #:with-path? #t))))
(map cdr (links #:shared? #t #:with-path? #t))))
(read-bytecode ,(PLANET-BASE-DIR)) (read-bytecode ,(PLANET-BASE-DIR))
(exists ,(find-system-path 'addon-dir)) (exists ,(find-system-path 'addon-dir))
(read ,(build-path (find-system-path 'addon-dir) "links.rktd")) (read ,(build-path (find-system-path 'addon-dir) "links.rktd"))

43
racket/collects/pkg/lib.rkt
View File

@ -35,7 +35,7 @@
(define current-pkg-scope (define current-pkg-scope
(make-parameter 'user)) (make-parameter 'user))
(define current-pkg-scope-version (define current-pkg-scope-version
(make-parameter (version))) (make-parameter (get-installation-name)))
(define current-pkg-error (define current-pkg-error
(make-parameter (lambda args (apply error 'pkg args)))) (make-parameter (lambda args (apply error 'pkg args))))
(define current-no-pkg-db (define current-no-pkg-db
@ -409,13 +409,9 @@
(for*/hash ([dir (in-list (get-pkgs-search-dirs))] (for*/hash ([dir (in-list (get-pkgs-search-dirs))]
[(k v) (read-pkgs-db dir)]) [(k v) (read-pkgs-db dir)])
(values k v))] (values k v))]
[(shared)
(define db (read-pkgs-db 'shared))
(for/fold ([ht (merge-next-pkg-dbs 'installation)]) ([(k v) (in-hash db)])
(hash-set ht k v))]
[(user) [(user)
(define db (read-pkgs-db 'user)) (define db (read-pkgs-db 'user))
(for/fold ([ht (merge-next-pkg-dbs 'shared)]) ([(k v) (in-hash db)]) (for/fold ([ht (merge-next-pkg-dbs 'installation)]) ([(k v) (in-hash db)])
(hash-set ht k v))]))) (hash-set ht k v))])))
(define (package-info pkg-name [fail? #t] #:db [given-db #f]) (define (package-info pkg-name [fail? #t] #:db [given-db #f])
@ -430,7 +426,6 @@
(pkg-not-installed pkg-name db)])) (pkg-not-installed pkg-name db)]))
;; return the current scope as a string ;; return the current scope as a string
;; -> (or/c "user" "shared" "installation")
(define (current-scope->string) (define (current-scope->string)
(define scope (current-pkg-scope)) (define scope (current-pkg-scope))
(cond (cond
@ -446,22 +441,17 @@
(define user-db (define user-db
(parameterize ([current-pkg-scope 'user]) (parameterize ([current-pkg-scope 'user])
(read-pkg-db))) (read-pkg-db)))
(define shared-db
(parameterize ([current-pkg-scope 'shared])
(read-pkg-db)))
;; see if the package is installed in any scope ;; see if the package is installed in any scope
(define-values (in-install? in-user? in-shared?) (define-values (in-install? in-user?)
(values (values
(and (hash-ref installation-db pkg-name #f) (and (hash-ref installation-db pkg-name #f)
"--installation") "--installation")
(and (hash-ref user-db pkg-name #f) (and (hash-ref user-db pkg-name #f)
"--user") "--user")))
(and (hash-ref shared-db pkg-name #f)
"--shared")))
(define not-installed-msg (define not-installed-msg
(cond [(or in-user? in-install? in-shared?) (cond [(or in-user? in-install?)
=> =>
(λ (scope-str) (λ (scope-str)
(~a "could not remove package\n" (~a "could not remove package\n"
@ -510,9 +500,7 @@
;; Hard-wided: ;; Hard-wided:
(get-default) (get-default)
;; Enclosing: ;; Enclosing:
(parameterize ([current-pkg-scope (if (eq? s 'user) (parameterize ([current-pkg-scope 'installation])
'shared
'installation)])
(read-pkg-cfg/def k)))] (read-pkg-cfg/def k)))]
[else [else
(match k (match k
@ -535,7 +523,6 @@
(define (default-pkg-scope) (define (default-pkg-scope)
(match (default-pkg-scope-as-string) (match (default-pkg-scope-as-string)
["installation" 'installation] ["installation" 'installation]
["shared" 'shared]
[else 'user])) [else 'user]))
(define (default-pkg-scope-as-string) (define (default-pkg-scope-as-string)
(read-pkg-cfg/def 'default-scope)) (read-pkg-cfg/def 'default-scope))
@ -568,7 +555,7 @@
(if (path? current-scope) (if (path? current-scope)
(list current-scope) (list current-scope)
(member current-scope (member current-scope
(append '(user shared) (append '(user)
(let ([main (find-pkgs-dir)]) (let ([main (find-pkgs-dir)])
(for/list ([d (get-pkgs-search-dirs)]) (for/list ([d (get-pkgs-search-dirs)])
(if (equal? d main) (if (equal? d main)
@ -603,21 +590,17 @@
(define scope (current-pkg-scope)) (define scope (current-pkg-scope))
(define user? (not (or (eq? scope 'installation) (define user? (not (or (eq? scope 'installation)
(path? scope)))) (path? scope))))
(define shared? (and user?
(eq? (current-pkg-scope) 'shared)))
(match orig-pkg (match orig-pkg
[`(,(or 'link 'static-link) ,_) [`(,(or 'link 'static-link) ,_)
(links pkg-dir (links pkg-dir
#:remove? #t #:remove? #t
#:user? user? #:user? user?
#:shared? shared?
#:file (scope->links-file scope) #:file (scope->links-file scope)
#:root? (not (sc-pkg-info? pi)))] #:root? (not (sc-pkg-info? pi)))]
[_ [_
(links pkg-dir (links pkg-dir
#:remove? #t #:remove? #t
#:user? user? #:user? user?
#:shared? shared?
#:file (scope->links-file scope) #:file (scope->links-file scope)
#:root? (not (sc-pkg-info? pi))) #:root? (not (sc-pkg-info? pi)))
(delete-directory/files pkg-dir)])) (delete-directory/files pkg-dir)]))
@ -1323,7 +1306,6 @@
#:name single-collect #:name single-collect
#:user? (not (or (eq? 'installation scope) #:user? (not (or (eq? 'installation scope)
(path? scope))) (path? scope)))
#:shared? (eq? 'shared scope)
#:file (scope->links-file scope) #:file (scope->links-file scope)
#:root? (not single-collect) #:root? (not single-collect)
#:static-root? (and (pair? orig-pkg) #:static-root? (and (pair? orig-pkg)
@ -1641,11 +1623,11 @@
[(list* (and key "catalogs") val) [(list* (and key "catalogs") val)
(update-pkg-cfg! 'catalogs val)] (update-pkg-cfg! 'catalogs val)]
[(list (and key "default-scope") val) [(list (and key "default-scope") val)
(unless (member val '("installation" "user" "shared")) (unless (member val '("installation" "user"))
(pkg-error (~a "invalid value for config key\n" (pkg-error (~a "invalid value for config key\n"
" config key: ~a\n" " config key: ~a\n"
" given value: ~a\n" " given value: ~a\n"
" valid values: installation, user, or shared") " valid values: installation, user")
key key
val)) val))
(update-pkg-cfg! 'default-scope val)] (update-pkg-cfg! 'default-scope val)]
@ -1784,10 +1766,9 @@
(parameterize ([current-pkg-scope scope]) (parameterize ([current-pkg-scope scope])
(with-pkg-lock/read-only (with-pkg-lock/read-only
(pkg-directory* dir-or-name)))) (pkg-directory* dir-or-name))))
(define dir (or (get-dir 'user) (define dir (get-dir 'user))
(get-dir 'shared)))
(unless dir (unless dir
(pkg-error (~a "package not installed in user or shared scope\n" (pkg-error (~a "package not installed in user scope\n"
" package name: ~a" " package name: ~a"
(if (get-dir 'installation) (if (get-dir 'installation)
"\n installed in scope: installation" "\n installed in scope: installation"
@ -2258,7 +2239,7 @@
(or/c #f 'fail 'force 'search-ask 'search-auto)) (or/c #f 'fail 'force 'search-ask 'search-auto))
(define package-scope/c (define package-scope/c
(or/c 'installation 'user 'shared (or/c 'installation 'user
(and/c path? complete-path?))) (and/c path? complete-path?)))
(provide (provide

60
racket/collects/pkg/main.rkt
View File

@ -1,6 +1,5 @@
#lang racket/base #lang racket/base
(require (only-in racket/base [version r:version]) (require racket/function
racket/function
racket/list racket/list
raco/command-name raco/command-name
setup/dirs setup/dirs
@ -31,15 +30,14 @@
(string->symbol (format "~a ~a" (short-program+command-name) cmd)) (string->symbol (format "~a ~a" (short-program+command-name) cmd))
args)) args))
(define (call-with-package-scope who given-scope scope-dir installation shared user thunk) (define (call-with-package-scope who given-scope scope-dir installation user thunk)
(define scope (define scope
(case given-scope (case given-scope
[(installation user shared) given-scope] [(installation user) given-scope]
[else [else
(cond (cond
[installation 'installation] [installation 'installation]
[user 'user] [user 'user]
[shared 'shared]
[scope-dir (path->complete-path scope-dir)] [scope-dir (path->complete-path scope-dir)]
[else (default-pkg-scope)])])) [else (default-pkg-scope)])]))
(parameterize ([current-pkg-scope scope] (parameterize ([current-pkg-scope scope]
@ -83,14 +81,12 @@
#:once-each #:once-each
[#:bool skip-installed () ("Skip a <pkg-source> if already installed")] [#:bool skip-installed () ("Skip a <pkg-source> if already installed")]
#:once-any #:once-any
[(#:sym scope [installation user shared] #f) scope () [(#:sym scope [installation user] #f) scope ()
("Select package <scope>, one of" ("Select package <scope>, one of"
" installation: Install for all users of the Racket installation" " installation: Install for all users of the Racket installation"
" user: Install as user- and version-specific" " user: Install as user-specific for an installation version/name")]
" shared: Install as user-specific but shared for all Racket versions")]
[#:bool installation ("-i") "Shorthand for `--scope installation'"] [#:bool installation ("-i") "Shorthand for `--scope installation'"]
[#:bool user ("-u") "Shorthand for `--scope user'"] [#:bool user ("-u") "Shorthand for `--scope user'"]
[#:bool shared ("-s") "Shorthand for `--scope shared'"]
[(#:str dir #f) scope-dir () "Install for package scope <dir>"] [(#:str dir #f) scope-dir () "Install for package scope <dir>"]
#:once-each #:once-each
[(#:str catalog #f) catalog () "Use <catalog> instead of configured catalogs"] [(#:str catalog #f) catalog () "Use <catalog> instead of configured catalogs"]
@ -100,7 +96,7 @@
#:args pkg-source #:args pkg-source
(call-with-package-scope (call-with-package-scope
'install 'install
scope scope-dir installation shared user scope scope-dir installation user
(lambda () (lambda ()
(unless (or (not name) (package-source->name name)) (unless (or (not name) (package-source->name name))
((current-pkg-error) (format "~e is an invalid package name" name))) ((current-pkg-error) (format "~e is an invalid package name" name)))
@ -135,14 +131,12 @@
" search-auto: like 'search-ask' but does not ask for permission to install")] " search-auto: like 'search-ask' but does not ask for permission to install")]
[#:bool update-deps () "Check named packages' dependencies for updates"] [#:bool update-deps () "Check named packages' dependencies for updates"]
#:once-any #:once-any
[(#:sym scope [installation user shared] #f) scope () [(#:sym scope [installation user] #f) scope ()
("Select package scope, one of" ("Select package scope, one of"
" installation: Update only for all users of the Racket installation" " installation: Update only for all users of the Racket installation"
" user: Update only user- and version-specific packages" " user: Update only user-specific for an installation version/name")]
" shared: Update only user-specific packages for all Racket versions")]
[#:bool installation ("-i") "Shorthand for `--scope installation'"] [#:bool installation ("-i") "Shorthand for `--scope installation'"]
[#:bool user ("-u") "Shorthand for `--scope user'"] [#:bool user ("-u") "Shorthand for `--scope user'"]
[#:bool shared ("-s") "Shorthand for `--scope shared'"]
[(#:str dir #f) scope-dir () "Update for package scope <dir>"] [(#:str dir #f) scope-dir () "Update for package scope <dir>"]
#:once-any #:once-any
[#:bool source () ("Strip built elements of the package before installing")] [#:bool source () ("Strip built elements of the package before installing")]
@ -154,7 +148,7 @@
#:args pkg #:args pkg
(call-with-package-scope (call-with-package-scope
'update 'update
scope scope-dir installation shared user scope scope-dir installation user
(lambda () (lambda ()
(define setup-collects (define setup-collects
(with-pkg-lock (with-pkg-lock
@ -170,14 +164,12 @@
[#:bool force () "Force removal of packages"] [#:bool force () "Force removal of packages"]
[#:bool auto () "Remove automatically installed packages with no dependencies"] [#:bool auto () "Remove automatically installed packages with no dependencies"]
#:once-any #:once-any
[(#:sym scope [installation user shared] #f) scope () [(#:sym scope [installation user] #f) scope ()
("Select package <scope>, one of" ("Select package <scope>, one of"
" installation: Remove packages for all users of the Racket installation" " installation: Remove packages for all users of the Racket installation"
" user: Remove user- and version-specific packages" " user: Remove user-specific for an installation version/name")]
" shared: Remove user-specific packages for all Racket versions")]
[#:bool installation ("-i") "Shorthand for `--scope installation'"] [#:bool installation ("-i") "Shorthand for `--scope installation'"]
[#:bool user ("-u") "Shorthand for `--scope user'"] [#:bool user ("-u") "Shorthand for `--scope user'"]
[#:bool shared ("-s") "Shorthand for `--scope shared'"]
[(#:str dir #f) scope-dir () "Remove for package scope <dir>"] [(#:str dir #f) scope-dir () "Remove for package scope <dir>"]
#:once-each #:once-each
[#:bool no-setup () ("Don't run `raco setup' after changing packages (usually" [#:bool no-setup () ("Don't run `raco setup' after changing packages (usually"
@ -186,7 +178,7 @@
#:args pkg #:args pkg
(call-with-package-scope (call-with-package-scope
'remove 'remove
scope scope-dir installation shared user scope scope-dir installation user
(lambda () (lambda ()
(define setup-collects (define setup-collects
(with-pkg-lock (with-pkg-lock
@ -200,24 +192,21 @@
[#:bool all ("-a") "Show auto-installed packages, too"] [#:bool all ("-a") "Show auto-installed packages, too"]
[#:bool dir ("-d") "Show the directory where the package is installed"] [#:bool dir ("-d") "Show the directory where the package is installed"]
#:once-any #:once-any
[(#:sym scope [installation user shared] #f) scope () [(#:sym scope [installation user] #f) scope ()
("Show only for package <scope>, one of" ("Show only for package <scope>, one of"
" installation: Show only for all users of the Racket installation" " installation: Show only for all users of the Racket installation"
" user: Show only user- and version-specific" " user: Show only user-specific for an installation version/name")]
" shared: Show only user-specific for all Racket versions")] [(#:str vers #f) version ("-v") "Show user-specific for installation <vers>"]
[(#:str vers #f) version ("-v") "Show only user-specific for Racket <vers>"]
[#:bool installation ("-i") "Shorthand for `--scope installation'"] [#:bool installation ("-i") "Shorthand for `--scope installation'"]
[#:bool user ("-u") "Shorthand for `--scope user'"] [#:bool user ("-u") "Shorthand for `--scope user'"]
[#:bool shared ("-s") "Shorthand for `--scope shared'"]
[(#:str dir #f) scope-dir () "Show only for package scope <dir>"] [(#:str dir #f) scope-dir () "Show only for package scope <dir>"]
#:args () #:args ()
(define only-mode (case scope (define only-mode (case scope
[(installation user shared) scope] [(installation user) scope]
[else [else
(cond (cond
[scope-dir (path->complete-path scope-dir)] [scope-dir (path->complete-path scope-dir)]
[installation 'installation] [installation 'installation]
[shared 'shared]
[user 'user] [user 'user]
[else (if version 'user #f)])])) [else (if version 'user #f)])]))
(for ([mode (if only-mode (for ([mode (if only-mode
@ -228,18 +217,17 @@
(if (equal? d main) (if (equal? d main)
'installation 'installation
d)))) d))))
'(shared user)))]) '(user)))])
(when (or (equal? mode only-mode) (not only-mode)) (when (or (equal? mode only-mode) (not only-mode))
(unless only-mode (unless only-mode
(printf "~a\n" (case mode (printf "~a\n" (case mode
[(installation) "Installation-wide:"] [(installation) "Installation-wide:"]
[(shared) "User-specific, all-version:"] [(user) (format "User-specific for installation ~s:"
[(user) (format "User-specific, version-specific (~a):" (or version (get-installation-name)))]
(or version (r:version)))]
[else (format "~a:" mode)]))) [else (format "~a:" mode)])))
(parameterize ([current-pkg-scope mode] (parameterize ([current-pkg-scope mode]
[current-pkg-error (pkg-error 'show)] [current-pkg-error (pkg-error 'show)]
[current-pkg-scope-version (or version (r:version))]) [current-pkg-scope-version (or version (get-installation-name))])
(with-pkg-lock/read-only (with-pkg-lock/read-only
(pkg-show (if only-mode "" " ") (pkg-show (if only-mode "" " ")
#:auto? all #:auto? all
@ -280,18 +268,16 @@
#:once-each #:once-each
[#:bool set () "Completely replace the value"] [#:bool set () "Completely replace the value"]
#:once-any #:once-any
[(#:sym scope [installation user shared] #f) scope () [(#:sym scope [installation user] #f) scope ()
("Select configuration <scope>, one of" ("Select configuration <scope>, one of"
" installation: Operate on the installation-wide package configuration" " installation: Operate on the installation-wide package configuration"
" user: Operate on the user-specific, version-specific package configuration" " user: Operate on the user-specific for an installation name")]
" shared: Operate on the user-specific all-version package configuration")]
[#:bool installation ("-i") "Shorthand for `--scope installation'"] [#:bool installation ("-i") "Shorthand for `--scope installation'"]
[#:bool user ("-u") "Shorthand for `--scope user'"] [#:bool user ("-u") "Shorthand for `--scope user'"]
[#:bool shared ("-s") "Shorthand for `--scope shared'"]
#:args key/val #:args key/val
(call-with-package-scope (call-with-package-scope
'config 'config
scope #f installation shared user scope #f installation user
(lambda () (lambda ()
(if set (if set
(with-pkg-lock (with-pkg-lock

6
racket/collects/pkg/path.rkt
View File

@ -15,13 +15,12 @@
(define (check-scope who scope) (define (check-scope who scope)
(unless (or (eq? scope 'user) (unless (or (eq? scope 'user)
(eq? scope 'shared)
(eq? scope 'installation) (eq? scope 'installation)
(and (path? scope) (and (path? scope)
(complete-path? scope))) (complete-path? scope)))
(raise-argument-error (raise-argument-error
who who
"(or/c 'user 'shared 'installation (and/c path? complete-path?))" "(or/c 'user 'installation (and/c path? complete-path?))"
scope))) scope)))
(define (get-pkgs-dir scope [user-version (version)]) (define (get-pkgs-dir scope [user-version (version)])
@ -33,7 +32,6 @@
(case scope (case scope
[(installation) (find-pkgs-dir)] [(installation) (find-pkgs-dir)]
[(user) (find-user-pkgs-dir user-version)] [(user) (find-user-pkgs-dir user-version)]
[(shared) (find-shared-pkgs-dir)]
[else (error "unknown package scope")]))) [else (error "unknown package scope")])))
(define (read-pkg-file-hash file) (define (read-pkg-file-hash file)
@ -87,7 +85,7 @@
(define (build-path* l) (define (build-path* l)
(if (null? l) 'same (apply build-path l))) (if (null? l) 'same (apply build-path l)))
(for/fold ([pkg #f] [subpath #f] [collect #f]) (for/fold ([pkg #f] [subpath #f] [collect #f])
([scope (in-list (list* 'user 'shared ([scope (in-list (list* 'user
(get-pkgs-search-dirs)))] (get-pkgs-search-dirs)))]
#:when (not pkg)) #:when (not pkg))
(define d (or (and cache (define d (or (and cache

5
racket/collects/racket/HISTORY.txt
View File

@ -1,3 +1,8 @@
Version 5.90.0.3
Base user directoy paths on an installation name instead
of the Racket version string
Remove "shared" links and package scope
Version 5.90.0.2 Version 5.90.0.2
Added #%declare Added #%declare
Cross-phase persistent modules must be declared with Cross-phase persistent modules must be declared with

20
racket/collects/setup/commands/link.rkt
View File

@ -14,7 +14,7 @@
(define show-mode (make-parameter #f)) (define show-mode (make-parameter #f))
(define install-only (make-parameter #f)) (define install-only (make-parameter #f))
(define user-only (make-parameter #f)) (define user-only (make-parameter #f))
(define user-shared (make-parameter #f)) (define user-version (make-parameter #f))
(define link-symbol (string->symbol (short-program+command-name))) (define link-symbol (string->symbol (short-program+command-name)))
@ -42,16 +42,16 @@
[("-r" "--remove") "Remove links for the specified directories" [("-r" "--remove") "Remove links for the specified directories"
(remove-mode #t)] (remove-mode #t)]
#:once-any #:once-any
[("-u" "--user") "Adjust/list user-specific, version-specific links" [("-u" "--user") "Adjust/list user-specific links for an installation name/version"
(user-only #t)] (user-only #t)]
[("-s" "--shared") "Adjust/list user-specific links"
(user-only #t)
(user-shared #t)]
[("-i" "--installation") "Adjust/list installation-wide links" [("-i" "--installation") "Adjust/list installation-wide links"
(install-only #t)] (install-only #t)]
[("-f" "--file") file "Select an alternate link file" [("-f" "--file") file "Select an alternate link file"
(link-file (path->complete-path file))] (link-file (path->complete-path file))]
#:once-each #:once-each
[("-v" "--version") vers "Adjust/list user-specific links for <vers>"
(user-only #t)
(user-version vers)]
[("--repair") "Enable repair mode to fix existing links" [("--repair") "Enable repair mode to fix existing links"
(repair-mode #t)] (repair-mode #t)]
#:args #:args
@ -67,20 +67,19 @@
(and (null? dirs) (and (null? dirs)
(show-mode) (show-mode)
(not (user-only)) (not (user-only))
(not (user-shared))
(not (install-only)) (not (install-only))
(not (link-file)))) (not (link-file))))
(when show-all? (when show-all?
(printf "User-specific, version-specific links:\n")) (printf "User-specific, version-specific links:\n"))
(define (go user? shared?) (define (go user? vers)
(apply links (apply links
dirs dirs
#:root? (root-mode) #:root? (root-mode)
#:static-root? (static-root-mode) #:static-root? (static-root-mode)
#:user? user? #:user? user?
#:shared? shared? #:user-version (or vers (get-installation-name))
#:file (link-file) #:file (link-file)
#:name (link-name) #:name (link-name)
#:version-regexp (link-version) #:version-regexp (link-version)
@ -92,15 +91,14 @@
(define l1 (define l1
(go (not (install-only)) (go (not (install-only))
(user-shared))) (user-version)))
(define l2 (define l2
(if (and (not (or (user-only) (if (and (not (or (user-only)
(user-shared)
(install-only))) (install-only)))
(remove-mode)) (remove-mode))
(append (append
(go #f #f) (go #f #f)
(go #t #t)) (go #t (user-version)))
null)) null))
(when show-all? (when show-all?

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

@ -84,17 +84,21 @@
(define-config config:3m-suffix '3m-suffix values) (define-config config:3m-suffix '3m-suffix values)
(define-config config:absolute-installation? 'absolute-installation? (lambda (x) (and x #t))) (define-config config:absolute-installation? 'absolute-installation? (lambda (x) (and x #t)))
(define-config config:doc-search-url 'doc-search-url values) (define-config config:doc-search-url 'doc-search-url values)
(define-config config:installation-name 'installation-name values)
(provide get-absolute-installation? (provide get-absolute-installation?
get-cgc-suffix get-cgc-suffix
get-3m-suffix get-3m-suffix
get-doc-search-url) get-doc-search-url
get-installation-name)
(define (get-absolute-installation?) (force config:absolute-installation?)) (define (get-absolute-installation?) (force config:absolute-installation?))
(define (get-cgc-suffix) (force config:cgc-suffix)) (define (get-cgc-suffix) (force config:cgc-suffix))
(define (get-3m-suffix) (force config:3m-suffix)) (define (get-3m-suffix) (force config:3m-suffix))
(define (get-doc-search-url) (or (force config:doc-search-url) (define (get-doc-search-url) (or (force config:doc-search-url)
"http://docs.racket-lang.org")) "http://docs.racket-lang.org"))
(define (get-installation-name) (or (force config:installation-name)
(version)))
;; ---------------------------------------- ;; ----------------------------------------
;; "collects" ;; "collects"
@ -112,7 +116,7 @@
(combine-search (force config:collects-search-dirs) (combine-search (force config:collects-search-dirs)
(list (find-collects-dir)))) (list (find-collects-dir))))
(define user-collects-dir (define user-collects-dir
(delay (build-path (system-path* 'addon-dir) (version) "collects"))) (delay (build-path (system-path* 'addon-dir) (get-installation-name) "collects")))
(define (find-user-collects-dir) (define (find-user-collects-dir)
(force user-collects-dir)) (force user-collects-dir))
(define (get-collects-search-dirs) (define (get-collects-search-dirs)
@ -180,7 +184,7 @@
(define-finder provide config:id id get-false default) (define-finder provide config:id id get-false default)
(provide user-id) (provide user-id)
(define user-dir (define user-dir
(delay (build-path (system-path* 'addon-dir) (version) default))) (delay (build-path (system-path* 'addon-dir) (get-installation-name) default)))
(define (user-id) (define (user-id)
(force user-dir)))])) (force user-dir)))]))
@ -361,12 +365,8 @@
get-pkgs-search-dirs get-pkgs-search-dirs
(chain-to (lambda () (build-path (find-share-dir) "pkgs")))) (chain-to (lambda () (build-path (find-share-dir) "pkgs"))))
(provide find-user-pkgs-dir (provide find-user-pkgs-dir)
find-shared-pkgs-dir) (define (find-user-pkgs-dir [vers (get-installation-name)])
(define (find-user-pkgs-dir [vers (version)])
(build-path (find-system-path 'addon-dir) (build-path (find-system-path 'addon-dir)
vers vers
"pkgs")) "pkgs"))
(define (find-shared-pkgs-dir)
(build-path (find-system-path 'addon-dir)
"pkgs"))

9
racket/collects/setup/link.rkt
View File

@ -7,10 +7,11 @@
(define (links #:error [error error] (define (links #:error [error error]
#:user? [user? #t] #:user? [user? #t]
#:user-version [user-version (and user?
(get-installation-name))]
#:file [in-file #f] #:file [in-file #f]
#:name [name #f] #:name [name #f]
#:version-regexp [version-regexp #f] #:version-regexp [version-regexp #f]
#:shared? [shared? #f]
#:root? [root? #f] #:root? [root? #f]
#:static-root? [static-root? #f] #:static-root? [static-root? #f]
#:remove? [remove? #f] #:remove? [remove? #f]
@ -28,10 +29,8 @@
(check-name name)) (check-name name))
(define file (or in-file (define file (or in-file
(if (or user? shared?) (if user?
(if shared? (build-path (find-system-path 'addon-dir) user-version "links.rktd")
(build-path (find-system-path 'addon-dir) "links.rktd")
(build-path (find-system-path 'addon-dir) (version) "links.rktd"))
(find-links-file)))) (find-links-file))))
(define need-repair? #f) (define need-repair? #f)

19
racket/collects/setup/setup-unit.rkt
View File

@ -387,16 +387,15 @@
#:info-path info-path #:info-path info-path
#:info-path-mode 'abs-in-relative #:info-path-mode 'abs-in-relative
#:omit-root 'dir)) #:omit-root 'dir))
(for ([shared? (in-list '(#t #f))]) (for ([c+p (in-list (links #:with-path? #t))])
(for ([c+p (in-list (links #:shared? shared? #:with-path? #t))]) (cc! (list (string->path (car c+p)))
(cc! (list (string->path (car c+p))) #:path (cdr c+p)))
#:path (cdr c+p))) (for ([cp (in-list (links #:root? #t))]
(for ([cp (in-list (links #:shared? shared? #:root? #t))] #:when (directory-exists? cp)
#:when (directory-exists? cp) [collection (directory-list cp)]
[collection (directory-list cp)] #:unless (skip-collection-directory? collection)
#:unless (skip-collection-directory? collection) #:when (directory-exists? (build-path cp collection)))
#:when (directory-exists? (build-path cp collection))) (cc! (list collection) #:path (build-path cp collection))))
(cc! (list collection) #:path (build-path cp collection)))))
;; `all-collections' lists all top-level collections (not from Planet): ;; `all-collections' lists all top-level collections (not from Planet):
(define all-collections (define all-collections

1820
racket/src/racket/src/cstartup.inc
View File

File diff suppressed because it is too large Load Diff

4
racket/src/racket/src/schvers.h
View File

@ -13,12 +13,12 @@
consistently.) consistently.)
*/ */
#define MZSCHEME_VERSION "5.90.0.2" #define MZSCHEME_VERSION "5.90.0.3"
#define MZSCHEME_VERSION_X 5 #define MZSCHEME_VERSION_X 5
#define MZSCHEME_VERSION_Y 90 #define MZSCHEME_VERSION_Y 90
#define MZSCHEME_VERSION_Z 0 #define MZSCHEME_VERSION_Z 0
#define MZSCHEME_VERSION_W 2 #define MZSCHEME_VERSION_W 3
#define MZSCHEME_VERSION_MAJOR ((MZSCHEME_VERSION_X * 100) + MZSCHEME_VERSION_Y) #define MZSCHEME_VERSION_MAJOR ((MZSCHEME_VERSION_X * 100) + MZSCHEME_VERSION_Y)
#define MZSCHEME_VERSION_MINOR ((MZSCHEME_VERSION_Z * 1000) + MZSCHEME_VERSION_W) #define MZSCHEME_VERSION_MINOR ((MZSCHEME_VERSION_Z * 1000) + MZSCHEME_VERSION_W)

53
racket/src/racket/src/startup.inc
View File

@ -363,15 +363,6 @@
"(find-col-file fail" "(find-col-file fail"
" collection collection-path" " collection collection-path"
" file-name)))" " file-name)))"
"(define-values(user-links-path)(build-path(find-system-path 'addon-dir)"
"(version)"
" \"links.rktd\"))"
"(define-values(user-links-cache)(make-hasheq))"
"(define-values(user-links-stamp) #f)"
"(define-values(shared-links-path)(build-path(find-system-path 'addon-dir)"
" \"links.rktd\"))"
"(define-values(shared-links-cache)(make-hasheq))"
"(define-values(shared-links-stamp) #f)"
"(define-values(find-config-dir)" "(define-values(find-config-dir)"
"(lambda()" "(lambda()"
"(let((c(find-system-path 'config-dir)))" "(let((c(find-system-path 'config-dir)))"
@ -393,6 +384,11 @@
"(lambda()" "(lambda()"
"(call-with-default-reading-parameterization read))))" "(call-with-default-reading-parameterization read))))"
" #hash()))))" " #hash()))))"
"(define-values(get-installation-name)"
"(lambda(config-table)"
"(hash-ref config-table"
" 'installation-name "
"(version))))"
"(define-values(coerce-to-path)" "(define-values(coerce-to-path)"
"(lambda(p)" "(lambda(p)"
"(cond" "(cond"
@ -430,7 +426,7 @@
"((not(car l))(append orig-l(loop(cdr l))))" "((not(car l))(append orig-l(loop(cdr l))))"
"(else(cons(coerce-to-path(car l))(loop(cdr l))))))" "(else(cons(coerce-to-path(car l))(loop(cdr l))))))"
" orig-l))))" " orig-l))))"
"(define-values(links-paths)(find-links-path!" "(define-values(all-links-paths)(find-links-path!"
"(lambda()" "(lambda()"
"(let*((d(find-config-dir))" "(let*((d(find-config-dir))"
"(ht(get-config-table d))" "(ht(get-config-table d))"
@ -439,11 +435,18 @@
"(build-path(or(hash-ref ht 'share-dir #f)" "(build-path(or(hash-ref ht 'share-dir #f)"
" (build-path 'up \"share\"))" " (build-path 'up \"share\"))"
" \"links.rktd\")))))" " \"links.rktd\")))))"
"(list->vector" "(cons(list->vector"
"(add-config-search" "(add-config-search"
" ht" " ht"
" 'links-search-files" " 'links-search-files"
"(list lf)))))))" "(list lf)))"
"(build-path(find-system-path 'addon-dir)"
"(get-installation-name ht)"
" \"links.rktd\"))))))"
"(define-values(links-paths)(car all-links-paths))"
"(define-values(user-links-path)(cdr all-links-paths))"
"(define-values(user-links-cache)(make-hasheq))"
"(define-values(user-links-stamp) #f)"
"(define-values(links-caches)(make-vector(vector-length links-paths)(make-hasheq)))" "(define-values(links-caches)(make-vector(vector-length links-paths)(make-hasheq)))"
"(define-values(links-stamps)(make-vector(vector-length links-paths) #f))" "(define-values(links-stamps)(make-vector(vector-length links-paths) #f))"
"(define-values(stamp-prompt-tag)(make-continuation-prompt-tag 'stamp))" "(define-values(stamp-prompt-tag)(make-continuation-prompt-tag 'stamp))"
@ -504,7 +507,7 @@
"(or(not a)" "(or(not a)"
"(not(car a)))))" "(not(car a)))))"
"(define-values(get-linked-collections)" "(define-values(get-linked-collections)"
"(lambda(user? shared? ii)" "(lambda(user? ii)"
"(call/ec(lambda(esc)" "(call/ec(lambda(esc)"
"(define-values(make-handler)" "(define-values(make-handler)"
"(lambda(ts)" "(lambda(ts)"
@ -517,7 +520,6 @@
" \"error reading collection links file ~s: ~a\"" " \"error reading collection links file ~s: ~a\""
"(cond" "(cond"
"(user? user-links-path)" "(user? user-links-path)"
"(shared? shared-links-path)"
"(else(vector-ref links-paths ii)))" "(else(vector-ref links-paths ii)))"
"(exn-message exn))" "(exn-message exn))"
"(current-continuation-marks))))" "(current-continuation-marks))))"
@ -527,9 +529,6 @@
"(user?" "(user?"
"(set! user-links-cache(make-hasheq))" "(set! user-links-cache(make-hasheq))"
"(set! user-links-stamp ts))" "(set! user-links-stamp ts))"
"(shared?"
"(set! shared-links-cache(make-hasheq))"
"(set! shared-links-stamp ts))"
"(else" "(else"
"(vector-set! links-caches ii(make-hasheq))" "(vector-set! links-caches ii(make-hasheq))"
"(vector-set! links-stamps ii ts))))" "(vector-set! links-stamps ii ts))))"
@ -541,11 +540,9 @@
"(make-handler #f)" "(make-handler #f)"
"(let*((a-links-path(cond" "(let*((a-links-path(cond"
"(user? user-links-path)" "(user? user-links-path)"
"(shared? shared-links-path)"
"(else(vector-ref links-paths ii))))" "(else(vector-ref links-paths ii))))"
"(a-links-stamp(cond" "(a-links-stamp(cond"
"(user? user-links-stamp)" "(user? user-links-stamp)"
"(shared? shared-links-stamp)"
"(else(vector-ref links-stamps ii))))" "(else(vector-ref links-stamps ii))))"
"(ts(file->stamp a-links-path a-links-stamp)))" "(ts(file->stamp a-links-path a-links-stamp)))"
"(if(not(equal? ts a-links-stamp))" "(if(not(equal? ts a-links-stamp))"
@ -614,16 +611,12 @@
"(user?" "(user?"
"(set! user-links-cache ht)" "(set! user-links-cache ht)"
"(set! user-links-stamp ts))" "(set! user-links-stamp ts))"
"(shared?"
"(set! shared-links-cache ht)"
"(set! shared-links-stamp ts))"
"(else" "(else"
"(vector-set! links-caches ii ht)" "(vector-set! links-caches ii ht)"
"(vector-set! links-stamps ii ts)))" "(vector-set! links-stamps ii ts)))"
" ht)))))" " ht)))))"
"(cond" "(cond"
"(user? user-links-cache)" "(user? user-links-cache)"
"(shared? shared-links-cache)"
"(else(vector-ref links-caches ii))))))))))" "(else(vector-ref links-caches ii))))))))))"
"(define-values(normalize-collection-reference)" "(define-values(normalize-collection-reference)"
"(lambda(collection collection-path)" "(lambda(collection collection-path)"
@ -655,10 +648,7 @@
"(append" "(append"
"(if(and links?(use-user-specific-search-paths))" "(if(and links?(use-user-specific-search-paths))"
"(append" "(append"
"(let((ht(get-linked-collections #t #f 0)))" "(let((ht(get-linked-collections #t 0)))"
"(append(hash-ref ht sym null)"
"(hash-ref ht #f null)))"
"(let((ht(get-linked-collections #f #t 0)))"
"(append(hash-ref ht sym null)" "(append(hash-ref ht sym null)"
"(hash-ref ht #f null))))" "(hash-ref ht #f null))))"
" null)" " null)"
@ -666,7 +656,7 @@
"(let loop((ii 0))" "(let loop((ii 0))"
"(if(ii . >= .(vector-length links-paths))" "(if(ii . >= .(vector-length links-paths))"
" null" " null"
"(let((ht(get-linked-collections #f #f ii)))" "(let((ht(get-linked-collections #f ii)))"
"(append(hash-ref ht sym null)" "(append(hash-ref ht sym null)"
"(hash-ref ht #f null)" "(hash-ref ht #f null)"
"(loop(add1 ii))))))" "(loop(add1 ii))))))"
@ -808,7 +798,8 @@
"((extra-collects-dirs)(find-library-collection-paths extra-collects-dirs null))" "((extra-collects-dirs)(find-library-collection-paths extra-collects-dirs null))"
"((extra-collects-dirs post-collects-dirs)" "((extra-collects-dirs post-collects-dirs)"
"(let((user-too?(use-user-specific-search-paths))" "(let((user-too?(use-user-specific-search-paths))"
"(cons-if(lambda(f r)(if f(cons f r) r))))" "(cons-if(lambda(f r)(if f(cons f r) r)))"
"(config-table(get-config-table(find-config-dir))))"
"(path-list-string->path-list" "(path-list-string->path-list"
"(if user-too?" "(if user-too?"
"(let((c(environment-variables-ref(current-environment-variables)" "(let((c(environment-variables-ref(current-environment-variables)"
@ -818,12 +809,12 @@
" \"\"))" " \"\"))"
" \"\")" " \"\")"
"(add-config-search" "(add-config-search"
"(get-config-table(find-config-dir))" " config-table"
" 'collects-search-dirs" " 'collects-search-dirs"
"(cons-if" "(cons-if"
"(and user-too?" "(and user-too?"
"(build-path(find-system-path 'addon-dir)" "(build-path(find-system-path 'addon-dir)"
"(version)" "(get-installation-name config-table)"
" \"collects\"))" " \"collects\"))"
"(let loop((l(append" "(let loop((l(append"
" extra-collects-dirs" " extra-collects-dirs"

92
racket/src/racket/src/startup.rktl
View File

@ -430,17 +430,6 @@
collection collection-path collection collection-path
file-name))) file-name)))
(define-values (user-links-path) (build-path (find-system-path 'addon-dir)
(version)
"links.rktd"))
(define-values (user-links-cache) (make-hasheq))
(define-values (user-links-stamp) #f)
(define-values (shared-links-path) (build-path (find-system-path 'addon-dir)
"links.rktd"))
(define-values (shared-links-cache) (make-hasheq))
(define-values (shared-links-stamp) #f)
(define-values (find-config-dir) (define-values (find-config-dir)
(lambda () (lambda ()
(let ([c (find-system-path 'config-dir)]) (let ([c (find-system-path 'config-dir)])
@ -464,6 +453,12 @@
(call-with-default-reading-parameterization read)))) (call-with-default-reading-parameterization read))))
#hash())))) #hash()))))
(define-values (get-installation-name)
(lambda (config-table)
(hash-ref config-table
'installation-name
(version))))
(define-values (coerce-to-path) (define-values (coerce-to-path)
(lambda (p) (lambda (p)
(cond (cond
@ -495,7 +490,7 @@
(find-system-path 'orig-dir)))] (find-system-path 'orig-dir)))]
[else [else
(find-executable-path (find-system-path 'exec-file) collects-path #t)]))) (find-executable-path (find-system-path 'exec-file) collects-path #t)])))
(define-values (add-config-search) (define-values (add-config-search)
(lambda (ht key orig-l) (lambda (ht key orig-l)
(let ([l (hash-ref ht key #f)]) (let ([l (hash-ref ht key #f)])
@ -507,25 +502,34 @@
[else (cons (coerce-to-path (car l)) (loop (cdr l)))])) [else (cons (coerce-to-path (car l)) (loop (cdr l)))]))
orig-l)))) orig-l))))
(define-values (links-paths) (find-links-path! (define-values (all-links-paths) (find-links-path!
;; This thunk is called once per place, and the result ;; This thunk is called once per place, and the result
;; is remembered for later invocations. Otherwise, the ;; is remembered for later invocations. Otherwise, the
;; search for the config file can trip over filesystem ;; search for the config file can trip over filesystem
;; restrictions imposed by security guards. ;; restrictions imposed by security guards.
(lambda () (lambda ()
(let* ([d (find-config-dir)] (let* ([d (find-config-dir)]
[ht (get-config-table d)] [ht (get-config-table d)]
[lf (coerce-to-path [lf (coerce-to-path
(or (hash-ref ht 'links-file #f) (or (hash-ref ht 'links-file #f)
(build-path (or (hash-ref ht 'share-dir #f) (build-path (or (hash-ref ht 'share-dir #f)
(build-path 'up "share")) (build-path 'up "share"))
"links.rktd")))]) "links.rktd")))])
(list->vector (cons (list->vector
(add-config-search (add-config-search
ht ht
'links-search-files 'links-search-files
(list lf))))))) (list lf)))
(build-path (find-system-path 'addon-dir)
(get-installation-name ht)
"links.rktd"))))))
(define-values (links-paths) (car all-links-paths))
(define-values (user-links-path) (cdr all-links-paths))
(define-values (user-links-cache) (make-hasheq))
(define-values (user-links-stamp) #f)
(define-values (links-caches) (make-vector (vector-length links-paths) (make-hasheq))) (define-values (links-caches) (make-vector (vector-length links-paths) (make-hasheq)))
(define-values (links-stamps) (make-vector (vector-length links-paths) #f)) (define-values (links-stamps) (make-vector (vector-length links-paths) #f))
@ -595,7 +599,7 @@
(not (car a))))) (not (car a)))))
(define-values (get-linked-collections) (define-values (get-linked-collections)
(lambda (user? shared? ii) (lambda (user? ii)
(call/ec (lambda (esc) (call/ec (lambda (esc)
(define-values (make-handler) (define-values (make-handler)
(lambda (ts) (lambda (ts)
@ -608,7 +612,6 @@
"error reading collection links file ~s: ~a" "error reading collection links file ~s: ~a"
(cond (cond
[user? user-links-path] [user? user-links-path]
[shared? shared-links-path]
[else (vector-ref links-paths ii)]) [else (vector-ref links-paths ii)])
(exn-message exn)) (exn-message exn))
(current-continuation-marks)))) (current-continuation-marks))))
@ -618,9 +621,6 @@
[user? [user?
(set! user-links-cache (make-hasheq)) (set! user-links-cache (make-hasheq))
(set! user-links-stamp ts)] (set! user-links-stamp ts)]
[shared?
(set! shared-links-cache (make-hasheq))
(set! shared-links-stamp ts)]
[else [else
(vector-set! links-caches ii (make-hasheq)) (vector-set! links-caches ii (make-hasheq))
(vector-set! links-stamps ii ts)])) (vector-set! links-stamps ii ts)]))
@ -633,11 +633,9 @@
(make-handler #f) (make-handler #f)
(let* ([a-links-path (cond (let* ([a-links-path (cond
[user? user-links-path] [user? user-links-path]
[shared? shared-links-path]
[else (vector-ref links-paths ii)])] [else (vector-ref links-paths ii)])]
[a-links-stamp (cond [a-links-stamp (cond
[user? user-links-stamp] [user? user-links-stamp]
[shared? shared-links-stamp]
[else (vector-ref links-stamps ii)])] [else (vector-ref links-stamps ii)])]
[ts (file->stamp a-links-path a-links-stamp)]) [ts (file->stamp a-links-path a-links-stamp)])
(if (not (equal? ts a-links-stamp)) (if (not (equal? ts a-links-stamp))
@ -714,16 +712,12 @@
[user? [user?
(set! user-links-cache ht) (set! user-links-cache ht)
(set! user-links-stamp ts)] (set! user-links-stamp ts)]
[shared?
(set! shared-links-cache ht)
(set! shared-links-stamp ts)]
[else [else
(vector-set! links-caches ii ht) (vector-set! links-caches ii ht)
(vector-set! links-stamps ii ts)]) (vector-set! links-stamps ii ts)])
ht))))) ht)))))
(cond (cond
[user? user-links-cache] [user? user-links-cache]
[shared? shared-links-cache]
[else (vector-ref links-caches ii)])))))))) [else (vector-ref links-caches ii)]))))))))
(define-values (normalize-collection-reference) (define-values (normalize-collection-reference)
@ -759,10 +753,7 @@
;; list of paths and (box path)s: ;; list of paths and (box path)s:
(if (and links? (use-user-specific-search-paths)) (if (and links? (use-user-specific-search-paths))
(append (append
(let ([ht (get-linked-collections #t #f 0)]) (let ([ht (get-linked-collections #t 0)])
(append (hash-ref ht sym null)
(hash-ref ht #f null)))
(let ([ht (get-linked-collections #f #t 0)])
(append (hash-ref ht sym null) (append (hash-ref ht sym null)
(hash-ref ht #f null)))) (hash-ref ht #f null))))
null) null)
@ -771,7 +762,7 @@
(let loop ([ii 0]) (let loop ([ii 0])
(if (ii . >= . (vector-length links-paths)) (if (ii . >= . (vector-length links-paths))
null null
(let ([ht (get-linked-collections #f #f ii)]) (let ([ht (get-linked-collections #f ii)])
(append (hash-ref ht sym null) (append (hash-ref ht sym null)
(hash-ref ht #f null) (hash-ref ht #f null)
(loop (add1 ii)))))) (loop (add1 ii))))))
@ -927,7 +918,8 @@
[(extra-collects-dirs) (find-library-collection-paths extra-collects-dirs null)] [(extra-collects-dirs) (find-library-collection-paths extra-collects-dirs null)]
[(extra-collects-dirs post-collects-dirs) [(extra-collects-dirs post-collects-dirs)
(let ([user-too? (use-user-specific-search-paths)] (let ([user-too? (use-user-specific-search-paths)]
[cons-if (lambda (f r) (if f (cons f r) r))]) [cons-if (lambda (f r) (if f (cons f r) r))]
[config-table (get-config-table (find-config-dir))])
(path-list-string->path-list (path-list-string->path-list
(if user-too? (if user-too?
(let ([c (environment-variables-ref (current-environment-variables) (let ([c (environment-variables-ref (current-environment-variables)
@ -937,12 +929,12 @@
"")) ""))
"") "")
(add-config-search (add-config-search
(get-config-table (find-config-dir)) config-table
'collects-search-dirs 'collects-search-dirs
(cons-if (cons-if
(and user-too? (and user-too?
(build-path (find-system-path 'addon-dir) (build-path (find-system-path 'addon-dir)
(version) (get-installation-name config-table)
"collects")) "collects"))
(let loop ([l (append (let loop ([l (append
extra-collects-dirs extra-collects-dirs