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

add `current-library-collection-links' parameter

Browse Source 
Also, the initial value causes `curent-library-collection-paths'
before collection links files, instead of after.
This commit is contained in:
Matthew Flatt 2013-08-02 08:22:53 -06:00
parent 1468575c3d
commit 8eefa2126b
21 changed files with 1541 additions and 1255 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -5,29 +5,18 @@
@title[#:tag "collects"]{Libraries and Collections}
A @deftech{library} is @racket[module] declaration for use by multiple
programs. Racket further groups libraries into @deftech{collections}
that can be easily distributed and added to a local Racket
installation.
programs. Racket further groups libraries into @deftech{collections}.
Typically, collections are added via @deftech{packages} (see
@other-doc['(lib "pkg/scribblings/pkg.scrbl")]); the package manager
works outside of the Racket core, but it configures the core run-time
system through @tech{collection links files}.
Some libraries are distributed via @|PLaneT| packages. Such libraries are
referenced through a @racket[planet] module path (see
@racket[require]) and are downloaded by Racket on demand.
Other collections are distributed with Racket, in which case each
collection is a directory that is located in a @filepath{collects}
directory relative to the Racket executable. A collection can also be
installed in a user-specific directory. More generally, the search
path for installed collections can be configured through the
@racket[current-library-collection-paths] parameter. Finally, the
location of collections can be specified through the @tech{collection
links files}; see @secref["links-file"] for more information. In all
of these cases, the collections are referenced through @racket[lib]
paths (see @racket[require]) or symbolic shorthands.
For example, the following module uses the @filepath{getinfo.rkt}
library module from the @filepath{setup} collection, and the
@filepath{cards.rkt} library module from the @filepath{games}
collection's @filepath{cards} subcollection:
Libraries in collections are referenced through @racket[lib] paths
(see @racket[require]) or symbolic shorthands. For example, the
following module uses the @filepath{getinfo.rkt} library module from
the @filepath{setup} collection, and the @filepath{cards.rkt} library
module from the @filepath{games} collection's @filepath{cards}
subcollection:
@racketmod[
racket
@ -58,35 +47,137 @@ element that names a library file; the path elements are separated by
@racket[_rel-string] contains @litchar{/} but does not end with a file
suffix, then @litchar{.rkt} is implicitly appended to the path.
Libraries also can be distributed via @|PLaneT| packages. Such
libraries are referenced through a @racket[planet] module path (see
@racket[require]) and are downloaded by Racket on demand, instead of
referenced through @tech{collections}.
The translation of a @racket[planet] or @racket[lib] path to a
@racket[module] declaration is determined by the @tech{module name
resolver}, as specified by the @racket[current-module-name-resolver]
parameter.
@; ----------------------------------------------------------------------
@section[#:tag "collects-search"]{Collection Search Configuration}
For the default @tech{module name resolver}, the search path for
collections is determined by the content of the @tech{collection links files}
and the
@racket[current-library-collection-paths] parameter. The collection
links and then list of paths in
@racket[current-library-collection-paths] are searched from first to
last to locate the first that contains @racket[_rel-string]. In other
words, the filesystem tree for each element in the link table and
search path is spliced together with the filesystem trees of other
path elements. Some Racket tools rely on unique resolution of module
path names, so an installation and
@racket[current-library-collection-paths] configuration should not
allow multiple files to match the same collection and file name.
collections is determined by the
@racket[current-library-collection-links] parameter and the
@racket[current-library-collection-paths] parameter:
The value of the @racket[current-library-collection-paths] parameter
is initialized in the Racket executable to the result of
@racket[(find-library-collection-paths)].
@itemlist[
@item{The most primitive @tech{collection}-based modules are located
in @filepath{collects} directory relative to the Racket
executable. Libraries for a collection are grouped within a
directory whose name matches the collection name. The path to
the @filepath{collects} directory is normally included in
@racket[current-library-collection-paths].}
@item{Collection-based libraries also can be installed other
directories, perhaps user-specific, that are structured like
the @filepath{collects} directory. Those additional directories
can be included in the
@racket[current-library-collection-paths] parameter either
dynamically, through command-line arguments to @exec{racket},
or by setting the @envvar{PLTCOLLECTS} environment variable;
see @racket[find-library-collection-paths].}
@item{@tech{Collection links files} provide a mapping from top-level
collection names to directories, plus additional
@filepath{collects}-like directories (that have subdirectories
with names that match collection names). Each @tech{collection
links file} to be searched is referenced by the
@racket[current-library-collection-links] parameter; the parameter
references the file, and not the file's content, so
that changes to the file can be detected and affect later
module resolution. See also
@racket[find-library-collection-links].}
@item{The @racket[current-library-collection-links] parameter's value
can also include hash tables that provide the same content as
@tech{collection links files}: a mapping from collection names
in symbol form to a list of paths for the collection, or from
@racket[#f] to a list of @filepath{collects}-like paths.}
@item{Finally, the @racket[current-library-collection-links]
parameter's value includes @racket[#f] to indicate the point in
the search process at which the @tech{module-name resolver} should
check @racket[current-library-collection-paths] relative to the
files and hash tables in @racket[current-library-collection-links].}
]
To resolve a module reference @racket[_rel-string], the default
@tech{module name resolver} searches collection links in
@racket[current-library-collection-links] from first to last to locate
the first directory that contains @racket[_rel-string], splicing a
search through in @racket[current-library-collection-paths] where in
@racket[current-library-collection-links] contains @racket[#f]. The
filesystem tree for each element in the link table and search path is
effectively spliced together with the filesystem trees of other path
elements that correspond to the same collection. Some Racket tools
rely on unique resolution of module path names, so an installation and
configuration should not allow multiple files to match the same
collection and file name.
The value of the @racket[current-library-collection-links] parameter
is initialized by the @exec{racket} executable to the result of
@racket[(find-library-collection-links)], and the value of the
@racket[current-library-collection-paths] parameter is initialized to
the result of @racket[(find-library-collection-paths)].
@; ----------------------------------------------------------------------
@section[#:tag "links-file"]{Collection Links}
@deftech{Collection links files} are used by
@racket[collection-file-path], @racket[collection-path], and the
default @tech{module name resolver} to locate collections before
trying the @racket[(current-library-collection-paths)] search
path. The @tech{collection links files} to use are determined by the
@racket[current-library-collection-links] parameter, which is
initialized to the result of @racket[find-library-collection-links].
A @tech{collection links file} is @racket[read] with default reader
parameter settings to obtain a list. Every element of the list must be
a link specification with one of the forms @racket[(list _string
_path)], @racket[(list _string _path _regexp)], @racket[(list 'root
_path)], @racket[(list 'root _path _regexp)], @racket[(list 'static-root
_path)], @racket[(list 'static-root _path _regexp)]. A @racket[_string] names a
top-level @tech{collection}, in which case @racket[_path] is a path
that can be used as the collection's path (directly, as opposed to a
subdirectory of @racket[_path] named by @racket[_string]). A
@racket['root] entry, in contrast, acts like an path in
@racket[(current-library-collection-paths)]. A
@racket['static-root] entry is like a @racket['root] entry, but
where the immediate content of the directory is assumed not to change unless the
@tech{collection links file} changes. If @racket[_path] is a
relative path, it is relative to the directory containing the
@tech{collection links file}. If @racket[_regexp] is specified in a
link, then the link is used only if @racket[(regexp-match? _regexp
(version))] produces a true result.
A single top-level collection can have multiple links in a
@tech{collection links file}, and any number of @racket['root] entries
can appear. The corresponding paths are effectively spliced together,
since the paths are tried in order to locate a file or sub-collection.
The @exec{raco link} command-link tool can display, install, and
remove links in a @tech{collection links file}. See @secref[#:doc
raco-doc "link"] in @other-manual[raco-doc] for more information.
@; ----------------------------------------
@section[#:tag "collects-api"]{Collection Paths and Parameters}
@defproc[(find-library-collection-paths [pre-extras (listof path-string?) null]
[post-extras (listof path-string?) null])
(listof path?)]{
Produces a list of paths as follows:
Produces a list of paths, which is normally used to initialize
@racket[current-library-collection-paths], as follows:
@itemize[
@ -110,9 +201,11 @@ Produces a list of paths as follows:
@item{If the @indexed-envvar{PLTCOLLECTS} environment variable is
defined, it is combined with the default list using
@racket[path-list-string->path-list]. If it is not defined, the
default collection path list (as constructed by the first three
bullets above) is used directly.
@racket[path-list-string->path-list], as long as the value of
@racket[use-user-specific-search-paths] is true. If it is not
defined or if the value @racket[use-user-specific-search-paths] is
@racket[#f], the default collection path list (as constructed by the
first three bullets above) is used directly.
Note that on @|AllUnix|, paths are separated by @litchar{:}, and
on Windows by @litchar{;}. Also,
@ -124,6 +217,36 @@ Produces a list of paths as follows:
]}
@defproc[(find-library-collection-links)
(listof (or/c #f (and/c path? complete-path?)))]{
Produces a list of paths and @racket[#f], which is normally used to
initialized @racket[current-library-collection-links], as follows:
@itemlist[
@item{The list starts with @racket[#f], which causes the default
@tech{module name resolver}, @racket[collection-file-path],
and @racket[collection-path] to try paths in
@racket[current-library-collection-paths] before
@tech{collection links files}.}
@item{As long as the values of
@racket[use-user-specific-search-paths] and
@racket[use-collection-link-paths] are true, the second element
in the result list is the path of the user--specific
@tech{collection links file}, which is @racket[(build-path
(find-system-path 'addon-dir) (get-installation-name)
"links.rktd")].}
@item{As long as the value of @racket[use-collection-link-paths] is
true, the rest of the list contains the result of
@racket[get-links-search-files]. Typically, that function
produces a list with a single path, @racket[(build-path
(find-config-dir) "links.rktd")].}
]}
@defproc*[([(collection-file-path [file path-string?] [collection path-string?] ...+)
path?]
@ -133,7 +256,9 @@ Produces a list of paths as follows:
Returns the path to the file indicated by @racket[file] in the
collection specified by the @racket[collection]s, where the second
@racket[collection] (if any) names a sub-collection, and so on.
@racket[collection] (if any) names a sub-collection, and so on. The
search uses the values of @racket[current-library-collection-links]
and @racket[current-library-collection-paths].
If @racket[file] is not found, but @racket[file] ends in
@filepath{.rkt} and a file with the suffix @filepath{.ss} exists, then
@ -170,8 +295,31 @@ the file level.}
(listof (and/c path? complete-path?))]{
Parameter that determines a list of complete directory paths for
library collections used by @racket[require]. See
@secref["collects"] for more information.}
finding libraries (as referenced in @racket[require], for example)
through the default @tech{module name resolver} and for finding paths
through @racket[collection-path] and
@racket[collection-file-path]. See @secref["collects-search"] for more
information.}
@defparam*[current-library-collection-links paths
(listof (or/c #f
(and/c path-string? complete-path?)
(hash/c (or/c (and/c symbol? module-path?) #f)
(listof (and/c path-string? complete-path?)))))
(listof (or/c #f
(and/c path? complete-path?)
(hash/c (or/c (and/c symbol? module-path?) #f)
(listof (and/c path? complete-path?)))))]{
Parameter that determines @tech{collection links files}, additional
paths, and the relative search order of
@racket[current-library-collection-paths] for finding libraries (as
referenced in @racket[require], for example) through the default
@tech{module name resolver} and for finding paths through
@racket[collection-path] and @racket[collection-file-path]. See
@secref["collects-search"] for more information.}
@defboolparam[use-user-specific-search-paths on?]{
@ -181,12 +329,17 @@ the directory produced by @racket[(find-system-path 'addon-dir)], are
included in search paths for collections and other files. For example,
the initial value of @racket[find-library-collection-paths] omits the
user-specific collection directory when this parameter's value is
@racket[#f].
If @Flag{U} or @DFlag{no-user-path} argument to @exec{racket}, then
@racket[use-user-specific-search-paths] is initialized to
@racket[#f].}
@defboolparam[use-collection-link-paths on?]{
Parameter that determines whether @tech{collection links files} are
used to locate collections.
included in the result of @racket[find-library-collection-links].
If this parameter's value is @racket[#f] on start-up, then
@tech{collection links files} are effectively disabled permanently for
@ -196,52 +349,3 @@ only is @racket[current-library-collection-paths] initialized to the
empty list, but @racket[use-collection-link-paths] is initialized to
@racket[#f].}
@; ----------------------------------------------------------------------
@section[#:tag "links-file"]{Collection Links}
The @deftech{collection links files} are used by
@racket[collection-file-path], @racket[collection-path], and the
default @tech{module name resolver} to locate collections before
trying the @racket[(current-library-collection-paths)] search
path, but only if the @racket[use-collection-link-paths] parameter is set to
@racket[#t]. Furthermore, a user-specific @tech{collection links file} takes
precedence over an installation-wide @tech{collection links file}.
The user-specific @tech{collection links file} is used only if the
@racket[use-user-specific-search-paths] parameter is set to
@racket[#t].
The path of the user--specific @tech{collection links file} is
@racket[(build-path (find-system-path 'addon-dir) (get-installation-name) "links.rktd")].
The path of the installation-wide @tech{collection links file} is
@racket[(build-path (find-config-dir) "links.rktd")].
Each @tech{collection links file} is cached by Racket, but
the file is re-read if its content changes.
A @tech{collection links file} is @racket[read] with default reader
parameter settings to obtain a list. Every element of the list must be
a link specification with one of the forms @racket[(list _string
_path)], @racket[(list _string _path _regexp)], @racket[(list 'root
_path)], @racket[(list 'root _path _regexp)], @racket[(list 'static-root
_path)], @racket[(list 'static-root _path _regexp)]. A @racket[_string] names a
top-level @tech{collection}, in which case @racket[_path] is a path
that can be used as the collection's path (directly, as opposed to a
subdirectory of @racket[_path] named by @racket[_string]). A
@racket['root] entry, in contrast, acts like an path in
@racket[(current-library-collection-paths)]. A
@racket['static-root] entry is like a @racket['root] entry, but
where the immediate content of the directory is assumed not to change unless the
@tech{collection links file} changes. If @racket[_path] is a
relative path, it is relative to the directory containing the
@tech{collection links file}. If @racket[_regexp] is specified in a
link, then the link is used only if @racket[(regexp-match? _regexp
(version))] produces a true result.
A single top-level collection can have multiple links in a
@tech{collection links file}, and any number of @racket['root] entries
can appear. The corresponding paths are effectively spliced together,
since the paths are tried in order to locate a file or sub-collection.
The @exec{raco link} command-link tool can display, install, and
remove links in the @tech{collection links file}. See @secref[#:doc
raco-doc "link"] in @other-manual[raco-doc] for more information.

9
pkgs/racket-pkgs/racket-doc/scribblings/reference/module-reflect.scrbl
View File

@ -80,7 +80,14 @@ when the expander encounters @racket[(require _module-path)] where
or resolved module path. When such a @racket[require] appears within a
module, the @deftech{module path resolver} is also given the name of
the enclosing module, so that a relative reference can be converted to
an absolute symbol or @tech{resolved module path}.
an absolute symbol or @tech{resolved module path}.
The default @tech{module name resolver} uses
@racket[collection-file-path] to convert @racket[lib] and
symbolic-shorthand module paths to filesystem paths. The
@racket[collection-file-path] function, in turn, uses the
@racket[current-library-collection-links]
and @racket[current-library-collection-paths] parameters.
A @tech{module name resolver} takes two and four arguments:
@itemize[

73
pkgs/racket-pkgs/racket-test/tests/racket/collects.rktl Normal file
View File

@ -0,0 +1,73 @@
(load-relative "loadtest.rktl")
(Section 'collects)
;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(require racket/file)
(let ()
(define tmp-dir (make-temporary-file "collects~a" 'directory))
(make-directory* (build-path tmp-dir "zjhyq-1"))
(with-output-to-file (build-path tmp-dir "zjhyq-1" "m.rkt")
(lambda ()
(displayln "#lang racket/base")
(displayln "(provide v)")
(displayln "(define v 1)")))
(test #f collection-path "zjhyq-1" #:fail (lambda (s) #f))
(define (test-found)
(test (build-path (build-path tmp-dir "zjhyq-1"))
collection-path "zjhyq-1")
(test (build-path (build-path tmp-dir "zjhyq-1" "m.rkt"))
collection-file-path "m.rkt" "zjhyq-1"))
;; Add to paths
(parameterize ([current-library-collection-paths
(append (current-library-collection-paths)
(list tmp-dir))])
(test-found))
;; Add to link as hash table from #f:
(parameterize ([current-library-collection-links
(append (current-library-collection-links)
(list (hash #f (list tmp-dir))))])
(test-found))
;; Add to link as hash table from 'zjhyq-1:
(parameterize ([current-library-collection-links
(append (current-library-collection-links)
(list (hash 'zjhyq-1 (list (build-path tmp-dir "zjhyq-1")))))])
(test-found))
(delete-directory/files tmp-dir))
;; ----------------------------------------
(err/rt-test (current-library-collection-paths 5))
(err/rt-test (current-library-collection-paths (list 5)))
(err/rt-test (current-library-collection-paths (list "relative")))
;; strings coreced to paths:
(test #t andmap path? (parameterize ([current-library-collection-paths (list (path->string
(current-directory)))])
(current-library-collection-paths)))
(err/rt-test (current-library-collection-links 5))
(err/rt-test (current-library-collection-links (list 5)))
(err/rt-test (current-library-collection-links (list #t)))
(err/rt-test (current-library-collection-links (list "relative")))
(err/rt-test (current-library-collection-links (list (hash 'bad! null))))
(err/rt-test (current-library-collection-links (list (hash 'ok 5))))
(err/rt-test (current-library-collection-links (list (hash 'ok (list 5)))))
(err/rt-test (current-library-collection-links (list (hash 'ok (list "relative")))))
;; strings coreced to paths:
(test #t andmap path? (parameterize ([current-library-collection-links (list (path->string
(build-path (current-directory)
"links.rktd")))])
(current-library-collection-links)))
;; ----------------------------------------
(report-errs)

1
pkgs/racket-pkgs/racket-test/tests/racket/mz-tests.rktl
View File

@ -27,6 +27,7 @@
(load-relative "prompt.rktl")
(load-relative "will.rktl")
(load-relative "namespac.rktl")
(load-relative "collects.rktl")
(load-relative "modprot.rktl")
(load-relative "chaperone.rktl")
(unless (or building-flat-tests? in-drscheme?)

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

@ -923,24 +923,25 @@
(current-library-collection-paths)))]
[sandbox-path-permissions
`(,@(map (lambda (p) `(read-bytecode ,p))
(append
(current-library-collection-paths)
(apply append
(for/list ([f (get-links-search-files)]
#:when (file-exists? f))
(links #:root? #t #:file f)))
(links #:root? #t #:user? #t)
(apply append
(for/list ([f (get-links-search-files)]
#:when (file-exists? f))
(map cdr (links #:file f #:with-path? #t))))
(map cdr (links #:user? #t #:with-path? #t))))
(apply
append
(for/list ([l (current-library-collection-links)])
(cond
[(not l)
(current-library-collection-paths)]
[(hash? l)
(hash-values l)]
[else
(if (file-exists? l)
(append
(links #:root? #t #:file l)
(map cdr (links #:file l #:with-path? #t)))
null)]))))
,@(for/list ([l (current-library-collection-links)]
#:when (path? l))
`(read ,l))
(read-bytecode ,(PLANET-BASE-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) (version) "links.rktd"))
,@(for/list ([f (get-links-search-files)])
`(read ,f))
(read ,(find-lib-dir))
,@(compute-permissions allow-for-require allow-for-load)
,@(sandbox-path-permissions))]

34
pkgs/shell-completion/list-collects.rkt
View File

@ -9,24 +9,22 @@
(hash-set s (path-element->string p) #t))
s))
(define (links* m root?)
(case m
[(user) (links #:user? #t #:root? root?)]
[else (links #:file m #:root? root?)]))
(define (get-all-top-level-collections)
(define link-modes (list* 'user (get-links-search-files)))
(let* ([s (hash)]
[s (for/fold ([s s]) ([c (in-list
(current-library-collection-paths))])
(add-directory-collections c s))]
[s (for*/fold ([s s]) ([m (in-list link-modes)]
[l (in-list (links* m #f))])
(hash-set s l #t))]
[s (for*/fold ([s s]) ([m (in-list link-modes)]
[c (in-list (links* m #t))])
(add-directory-collections c s))])
(hash-keys s)))
(hash-keys
(for/fold ([s (hash)]) ([l (in-list
(current-library-collection-links))])
(cond
[(not l)
(for/fold ([s s]) ([c (in-list
(current-library-collection-paths))])
(add-directory-collections c s))]
[(path? l)
(let ([s (for*/fold ([s s]) ([c (in-list (links #:file l #:root? #f))])
(hash-set s c #t))])
(for*/fold ([s s]) ([c (in-list (links #:file l #:root? #t))])
(add-directory-collections c s)))]
[else (error 'get-all-top-level-collections
"unexpected value in `current-library-collection-links': ~e"
l)]))))
(for-each displayln (get-all-top-level-collections))

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

@ -1,3 +1,11 @@
Version 5.90.0.4
Add current-library-collection-links, find-library-collection-links
Changed module search to use current-library-collection-paths
before collection link files by default
Changed use-user-specific-search-paths and use-collection-link-paths
to affect only find-library-collection-paths and
find-library-collection-links
Version 5.90.0.3
Base user directoy paths on an installation name instead
of the Racket version string

1
racket/collects/racket/private/misc.rkt
View File

@ -234,6 +234,7 @@
guard-evt channel-get channel-try-get channel-put
port? displayln
find-library-collection-paths
find-library-collection-links
bytes-environment-variable-name?
string-environment-variable-name?
getenv putenv

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

@ -64,6 +64,8 @@
(define main-collects-dir (simple-form-path (find-collects-dir)))
(define main-collects-dirs (for/hash ([p (in-list (get-main-collects-search-dirs))])
(values (simple-form-path p) #t)))
(define main-links-files (for/hash ([p (in-list (get-links-search-files))])
(values (simple-form-path p) #t)))
(define mode-dir
(if (compile-mode)
(build-path "compiled" (compile-mode))
@ -76,7 +78,12 @@
p)))
(current-library-collection-paths
(map simple-form-path (current-library-collection-paths)))
(if (member #f (current-library-collection-links))
;; Normal case, include current library collection paths:
(map simple-form-path (current-library-collection-paths))
;; No `#f' in links list means that we don't look at
;; the current library collection paths:
null))
(define (setup-fprintf p task s . args)
(let ([task (if task (string-append task ": ") "")])
@ -345,7 +352,8 @@
;; checkout as a collection directory
(regexp-match? #rx"[.](git|svn)$" (path->bytes collection)))
;; Add in all non-planet collections:
;; Add in all non-planet collections, first from
;; `current-library-collection-paths':
(for ([cp (current-library-collection-paths)]
#:when (directory-exists? cp)
[collection (directory-list cp)]
@ -355,6 +363,8 @@
#:info-root cp
#:path (build-path cp collection)
#:main? (hash-ref main-collects-dirs cp #f)))
;; Now from `current-library-collection-links' for installation-wide
;; links:
(let ()
(define info-root (find-share-dir))
(define info-path (build-path info-root "info-cache.rktd"))
@ -366,7 +376,9 @@
#:info-path-mode 'abs-in-relative
#:omit-root 'dir
#:main? #t))
(for ([inst-links (in-list (get-links-search-files))])
(for ([inst-links (in-list (current-library-collection-links))]
#:when (and (path? inst-links)
(hash-ref main-links-files (simple-form-path inst-links) #f)))
(for ([c+p (in-list (links #:file inst-links #:with-path? #t))])
(cc! (list (string->path (car c+p)))
#:path (cdr c+p)))
@ -377,6 +389,8 @@
#:when (directory-exists? (build-path cp collection)))
(cc! (list collection)
#:path (build-path cp collection)))))
;; Now from `current-library-collection-links' for user-specific
;; links:
(when (make-user)
(define info-root (find-user-share-dir))
(define info-path (build-path info-root "info-cache.rktd"))
@ -387,15 +401,36 @@
#:info-path info-path
#:info-path-mode 'abs-in-relative
#:omit-root 'dir))
(for ([c+p (in-list (links #:with-path? #t))])
(cc! (list (string->path (car c+p)))
#:path (cdr c+p)))
(for ([cp (in-list (links #:root? #t))]
#:when (directory-exists? cp)
[collection (directory-list cp)]
#:unless (skip-collection-directory? collection)
#:when (directory-exists? (build-path cp collection)))
(cc! (list collection) #:path (build-path cp collection))))
;; A links spec in `current-library-collection-links' counts as
;; user-specific when it's not in `make-links-files':
(for ([inst-links (in-list (current-library-collection-links))]
#:unless (and (path? inst-links)
(hash-ref main-links-files (simple-form-path inst-links) #f)))
(cond
[(not inst-links) ; covered by `current-library-collection-paths'
(void)]
[(path? inst-links)
(for ([c+p (in-list (links #:file inst-links #:with-path? #t))])
(cc! (list (string->path (car c+p)))
#:path (cdr c+p)))
(for ([cp (in-list (links #:file inst-links #:root? #t))]
#:when (directory-exists? cp)
[collection (directory-list cp)]
#:unless (skip-collection-directory? collection)
#:when (directory-exists? (build-path cp collection)))
(cc! (list collection) #:path (build-path cp collection)))]
[else ; must be a hash table that simulates a links file:
(for ([(coll-sym dir) (in-hash inst-links)])
(cond
[coll-sym
;; A single collection
(cc! (string-split "/" (symbol->string coll-sym)) #:path dir)]
[(directory-exists? dir)
;; A directory that holds collections:
(for ([collection (directory-list dir)]
#:unless (skip-collection-directory? collection)
#:when (directory-exists? (build-path dir collection)))
(cc! (list collection) #:path (build-path dir collection)))]))])))
;; `all-collections' lists all top-level collections (not from Planet):
(define all-collections

1
racket/src/racket/include/scheme.h
View File

@ -1360,6 +1360,7 @@ enum {
MZCONFIG_WRITE_DIRECTORY,
MZCONFIG_COLLECTION_PATHS,
MZCONFIG_COLLECTION_LINKS,
MZCONFIG_PORT_PRINT_HANDLER,

2
racket/src/racket/include/schthread.h
View File

@ -284,7 +284,6 @@ typedef struct Thread_Local_Variables {
int env_uid_counter_;
int scheme_overflow_count_;
struct Scheme_Object *original_pwd_;
struct Scheme_Object *inst_links_path_;
void *file_path_wc_buffer_;
intptr_t scheme_hash_request_count_;
intptr_t scheme_hash_iteration_count_;
@ -665,7 +664,6 @@ XFORM_GC_VARIABLE_STACK_THROUGH_THREAD_LOCAL;
#define env_uid_counter XOA (scheme_get_thread_local_variables()->env_uid_counter_)
#define scheme_overflow_count XOA (scheme_get_thread_local_variables()->scheme_overflow_count_)
#define original_pwd XOA (scheme_get_thread_local_variables()->original_pwd_)
#define inst_links_path XOA (scheme_get_thread_local_variables()->inst_links_path_)
#define file_path_wc_buffer XOA (scheme_get_thread_local_variables()->file_path_wc_buffer_)
#define scheme_hash_request_count XOA (scheme_get_thread_local_variables()->scheme_hash_request_count_)
#define scheme_hash_iteration_count XOA (scheme_get_thread_local_variables()->scheme_hash_iteration_count_)

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

File diff suppressed because it is too large Load Diff

8
racket/src/racket/src/eval.c
View File

@ -5325,6 +5325,14 @@ void scheme_init_collection_paths_post(Scheme_Env *global_env, Scheme_Object *ex
if (!scheme_setjmp(newbuf)) {
Scheme_Object *clcp, *flcp, *a[2];
clcp = scheme_builtin_value("current-library-collection-links");
flcp = scheme_builtin_value("find-library-collection-links");
if (clcp && flcp) {
a[0] = _scheme_apply(flcp, 0, NULL);
_scheme_apply(clcp, 1, a);
}
clcp = scheme_builtin_value("current-library-collection-paths");
flcp = scheme_builtin_value("find-library-collection-paths");

118
racket/src/racket/src/file.c
View File

@ -201,6 +201,7 @@ static Scheme_Object *file_or_dir_permissions(int argc, Scheme_Object *argv[]);
static Scheme_Object *file_identity(int argc, Scheme_Object *argv[]);
static Scheme_Object *file_size(int argc, Scheme_Object *argv[]);
static Scheme_Object *current_library_collection_paths(int argc, Scheme_Object *argv[]);
static Scheme_Object *current_library_collection_links(int argc, Scheme_Object *argv[]);
static Scheme_Object *use_compiled_kind(int, Scheme_Object *[]);
static Scheme_Object *compiled_file_roots(int, Scheme_Object *[]);
static Scheme_Object *use_user_paths(int, Scheme_Object *[]);
@ -240,7 +241,6 @@ SHARED_OK static Scheme_Object *run_cmd;
SHARED_OK static Scheme_Object *collects_path, *config_path;
THREAD_LOCAL_DECL(static Scheme_Object *original_pwd);
SHARED_OK static Scheme_Object *addon_dir;
THREAD_LOCAL_DECL(static Scheme_Object *inst_links_path);
#endif
READ_ONLY static Scheme_Object *windows_symbol, *unix_symbol;
@ -554,6 +554,11 @@ void scheme_init_file(Scheme_Env *env)
"current-library-collection-paths",
MZCONFIG_COLLECTION_PATHS),
env);
scheme_add_global_constant("current-library-collection-links",
scheme_register_parameter(current_library_collection_links,
"current-library-collection-links",
MZCONFIG_COLLECTION_LINKS),
env);
#endif
scheme_add_global_constant("use-compiled-file-paths",
scheme_register_parameter(use_compiled_kind,
@ -5930,9 +5935,38 @@ static Scheme_Object *current_user_directory(int argc, Scheme_Object **argv)
#endif
static Scheme_Object *collpaths_gen_p(int argc, Scheme_Object **argv, int rel_ok, int abs_ok, int sym_ok)
static Scheme_Object *check_link_key_val(Scheme_Object *key, Scheme_Object *val)
{
Scheme_Object *new_val = scheme_null, *a;
if (!SCHEME_FALSEP(key)
&& (!SCHEME_SYMBOLP(key)
|| !scheme_is_module_path(key)))
return NULL;
while (SCHEME_PAIRP(val)) {
a = SCHEME_CAR(val);
if (!SCHEME_PATH_STRINGP(a))
return NULL;
a = TO_PATH(a);
if (!scheme_is_complete_path(SCHEME_PATH_VAL(a),
SCHEME_PATH_LEN(a),
SCHEME_PLATFORM_PATH_KIND))
return NULL;
new_val = scheme_make_pair(a, new_val);
val = SCHEME_CDR(val);
}
if (!SCHEME_NULLP(val))
return NULL;
return scheme_reverse(new_val);
}
static Scheme_Object *collpaths_gen_p(int argc, Scheme_Object **argv, int rel_ok, int abs_ok, int sym_ok, int links_ok)
{
Scheme_Object *v = argv[0];
Scheme_Object *new_hts = scheme_null;
if (scheme_proper_list_length(v) < 0)
return NULL;
@ -5945,6 +5979,36 @@ static Scheme_Object *collpaths_gen_p(int argc, Scheme_Object **argv, int rel_ok
s = SCHEME_CAR(v);
if (sym_ok && SAME_OBJ(s, same_symbol)) {
/* ok */
} else if (links_ok && SCHEME_FALSEP(s)) {
/* ok */
} else if (links_ok && (SCHEME_CHAPERONE_HASHTP(s)
|| SCHEME_CHAPERONE_HASHTRP(s)
|| SCHEME_CHAPERONE_BUCKTP(s))) {
Scheme_Hash_Tree *new_ht;
Scheme_Object *key, *val, *idx, *a[2];
new_ht = scheme_make_hash_tree(0);
a[0] = s;
idx = scheme_hash_table_iterate_start(1, a);
while (SCHEME_TRUEP(idx)) {
a[0] = s;
a[1] = idx;
key = scheme_hash_table_iterate_key(2, a);
val = scheme_chaperone_hash_get(s, key);
if (val) {
val = check_link_key_val(key, val);
if (!val) return NULL;
new_ht = scheme_hash_tree_set(new_ht, key, val);
}
a[0] = s;
a[1] = idx;
idx = scheme_hash_table_iterate_next(2, a);
}
new_hts = scheme_make_pair((Scheme_Object *)new_ht, new_hts);
} else {
if (!SCHEME_PATH_STRINGP(s))
return NULL;
@ -5964,14 +6028,24 @@ static Scheme_Object *collpaths_gen_p(int argc, Scheme_Object **argv, int rel_ok
if (!SCHEME_NULLP(v))
return NULL;
new_hts = scheme_reverse(new_hts);
/* Convert to list of paths: */
{
Scheme_Object *last = NULL, *first = NULL, *p, *s;
v = argv[0];
while (SCHEME_PAIRP(v)) {
s = SCHEME_CAR(v);
if (!SCHEME_SYMBOLP(s))
if (SCHEME_SYMBOLP(s)) {
/* ok */
} else if (SCHEME_FALSEP(s)) {
/* ok */
} else if (SCHEME_PATH_STRINGP(s)) {
s = TO_PATH(s);
} else {
s = SCHEME_CAR(new_hts);
new_hts = SCHEME_CDR(new_hts);
}
p = scheme_make_pair(s, scheme_null);
if (!first)
@ -5991,7 +6065,7 @@ static Scheme_Object *collpaths_gen_p(int argc, Scheme_Object **argv, int rel_ok
static Scheme_Object *collpaths_p(int argc, Scheme_Object **argv)
{
return collpaths_gen_p(argc, argv, 0, 1, 0);
return collpaths_gen_p(argc, argv, 0, 1, 0, 0);
}
Scheme_Object *scheme_current_library_collection_paths(int argc, Scheme_Object *argv[]) {
@ -6006,11 +6080,32 @@ static Scheme_Object *current_library_collection_paths(int argc, Scheme_Object *
-1, collpaths_p, "(listof (and/c path-string? complete-path?))", 1);
}
static Scheme_Object *colllinks_p(int argc, Scheme_Object **argv)
{
return collpaths_gen_p(argc, argv, 0, 1, 0, 1);
}
Scheme_Object *scheme_current_library_collection_links(int argc, Scheme_Object *argv[]) {
return current_library_collection_links(argc, argv);
}
static Scheme_Object *current_library_collection_links(int argc, Scheme_Object *argv[])
{
return scheme_param_config2("current-library-collection-links",
scheme_make_integer(MZCONFIG_COLLECTION_LINKS),
argc, argv,
-1, colllinks_p,
"(listof (or/c #f (and/c path-string? complete-path?)"
/**/ " (hash/c (or/c (and/c symbol? module-path?) #f)"
/**/ " (listof (and/c path-string? complete-path?)))))",
1);
}
#endif
static Scheme_Object *compiled_kind_p(int argc, Scheme_Object **argv)
{
return collpaths_gen_p(argc, argv, 1, 0, 0);
return collpaths_gen_p(argc, argv, 1, 0, 0, 0);
}
static Scheme_Object *use_compiled_kind(int argc, Scheme_Object *argv[])
@ -6023,7 +6118,7 @@ static Scheme_Object *use_compiled_kind(int argc, Scheme_Object *argv[])
static Scheme_Object *compiled_roots_p(int argc, Scheme_Object **argv)
{
return collpaths_gen_p(argc, argv, 1, 1, 1);
return collpaths_gen_p(argc, argv, 1, 1, 1, 0);
}
Scheme_Object *scheme_compiled_file_roots(int argc, Scheme_Object *argv[])
@ -6438,17 +6533,6 @@ void scheme_set_addon_dir(Scheme_Object *p)
addon_dir = p;
}
Scheme_Object *scheme_find_links_path(int argc, Scheme_Object *argv[])
{
if (inst_links_path)
return inst_links_path;
REGISTER_SO(inst_links_path);
inst_links_path = scheme_apply(argv[0], 0, NULL);
return inst_links_path;
}
/********************************************************************************/
#ifdef DOS_FILE_SYSTEM

8
racket/src/racket/src/place.c
View File

@ -208,6 +208,7 @@ typedef struct Place_Start_Data {
Scheme_Object *function;
Scheme_Object *channel;
Scheme_Object *current_library_collection_paths;
Scheme_Object *current_library_collection_links;
Scheme_Object *compiled_roots;
mzrt_sema *ready; /* malloc'ed item */
struct Scheme_Place_Object *place_obj; /* malloc'ed item */
@ -274,6 +275,7 @@ Scheme_Object *scheme_place(int argc, Scheme_Object *args[]) {
Place_Start_Data *place_data;
mz_proc_thread *proc_thread;
Scheme_Object *collection_paths;
Scheme_Object *collection_links;
Scheme_Place_Object *place_obj;
mzrt_sema *ready;
struct NewGC *parent_gc;
@ -364,6 +366,9 @@ Scheme_Object *scheme_place(int argc, Scheme_Object *args[]) {
collection_paths = scheme_current_library_collection_paths(0, NULL);
place_data->current_library_collection_paths = collection_paths;
collection_links = scheme_current_library_collection_links(0, NULL);
place_data->current_library_collection_links = collection_links;
collection_paths = scheme_compiled_file_roots(0, NULL);
place_data->compiled_roots = collection_paths;
@ -451,6 +456,7 @@ Scheme_Object *scheme_place(int argc, Scheme_Object *args[]) {
}
places_prepare_direct(place_data->current_library_collection_paths);
places_prepare_direct(place_data->current_library_collection_links);
places_prepare_direct(place_data->compiled_roots);
places_prepare_direct(place_data->channel);
places_prepare_direct(place_data->module);
@ -2633,6 +2639,8 @@ static void *place_start_proc_after_stack(void *data_arg, void *stack_base) {
a[0] = places_deep_direct_uncopy(place_data->current_library_collection_paths);
scheme_current_library_collection_paths(1, a);
a[0] = places_deep_direct_uncopy(place_data->current_library_collection_links);
scheme_current_library_collection_links(1, a);
a[0] = places_deep_direct_uncopy(place_data->compiled_roots);
scheme_compiled_file_roots(1, a);
scheme_seal_parameters();

2
racket/src/racket/src/schminc.h
View File

@ -14,7 +14,7 @@
#define USE_COMPILED_STARTUP 1
#define EXPECTED_PRIM_COUNT 1109
#define EXPECTED_PRIM_COUNT 1110
#define EXPECTED_UNSAFE_COUNT 100
#define EXPECTED_FLFXNUM_COUNT 69
#define EXPECTED_EXTFL_COUNT 45

1
racket/src/racket/src/schpriv.h
View File

@ -4007,6 +4007,7 @@ Scheme_Object *scheme_symbol_to_string(Scheme_Object *sym);
#define SCHEME_SYM_WEIRDP(o) (MZ_OPT_HASH_KEY(&((Scheme_Symbol *)(o))->iso) & 0x3)
Scheme_Object *scheme_current_library_collection_paths(int argc, Scheme_Object *argv[]);
Scheme_Object *scheme_current_library_collection_links(int argc, Scheme_Object *argv[]);
Scheme_Object *scheme_compiled_file_roots(int argc, Scheme_Object *argv[]);
#ifdef MZ_USE_JIT

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

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

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

@ -143,6 +143,7 @@
" collection-path"
" collection-file-path"
" find-library-collection-paths"
" find-library-collection-links"
" path-list-string->path-list"
" find-executable-path"
" load/use-compiled"
@ -428,9 +429,8 @@
"((not(car l))(append orig-l(loop(cdr l))))"
"(else(cons(coerce-to-path(car l))(loop(cdr l))))))"
" orig-l))))"
"(define-values(all-links-paths)(find-links-path!"
"(define-values(find-library-collection-links)"
"(lambda()"
"(if(use-collection-link-paths)"
"(let*((d(find-config-dir))"
"(ht(get-config-table d))"
"(lf(coerce-to-path"
@ -438,21 +438,21 @@
"(build-path(or(hash-ref ht 'share-dir #f)"
" (build-path 'up \"share\"))"
" \"links.rktd\")))))"
"(cons(list->vector"
"(append"
"(list #f)"
"(if(and(use-user-specific-search-paths)"
"(use-collection-link-paths))"
"(list(build-path(find-system-path 'addon-dir)"
"(get-installation-name ht)"
" \"links.rktd\"))"
" null)"
"(if(use-collection-link-paths)"
"(add-config-search"
" ht"
" 'links-search-files"
"(list lf)))"
"(build-path(find-system-path 'addon-dir)"
"(get-installation-name ht)"
" \"links.rktd\")))"
"(cons #() #f)))))"
"(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-stamps)(make-vector(vector-length links-paths) #f))"
"(list lf))"
" null)))))"
"(define-values(links-cache)(make-weak-hash))"
"(define-values(stamp-prompt-tag)(make-continuation-prompt-tag 'stamp))"
"(define-values(file->stamp)"
"(lambda(path old-stamp)"
@ -511,7 +511,7 @@
"(or(not a)"
"(not(car a)))))"
"(define-values(get-linked-collections)"
"(lambda(user? ii)"
"(lambda(links-path)"
"(call/ec(lambda(esc)"
"(define-values(make-handler)"
"(lambda(ts)"
@ -522,33 +522,21 @@
"(log-message l 'error"
"(format"
" \"error reading collection links file ~s: ~a\""
"(cond"
"(user? user-links-path)"
"(else(vector-ref links-paths ii)))"
" links-path"
"(exn-message exn))"
"(current-continuation-marks))))"
"(void))"
"(when ts"
"(cond"
"(user?"
"(set! user-links-cache(make-hasheq))"
"(set! user-links-stamp ts))"
"(else"
"(vector-set! links-caches ii(make-hasheq))"
"(vector-set! links-stamps ii ts))))"
"(hash-set! links-cache links-path(cons #hasheq() ts)))"
"(if(exn:fail? exn)"
"(esc(make-hasheq))"
" exn))))"
"(with-continuation-mark"
" exception-handler-key"
"(make-handler #f)"
"(let*((a-links-path(cond"
"(user? user-links-path)"
"(else(vector-ref links-paths ii))))"
"(a-links-stamp(cond"
"(user? user-links-stamp)"
"(else(vector-ref links-stamps ii))))"
"(ts(file->stamp a-links-path a-links-stamp)))"
"(let*((links-stamp+cache(hash-ref links-cache links-path '(#f . #hasheq())))"
"(a-links-stamp(car links-stamp+cache))"
"(ts(file->stamp links-path a-links-stamp)))"
"(if(not(equal? ts a-links-stamp))"
"(with-continuation-mark"
" exception-handler-key"
@ -557,7 +545,7 @@
"(lambda()"
"(let((v(if(no-file-stamp? ts)"
" null"
"(let((p(open-input-file a-links-path 'binary)))"
"(let((p(open-input-file links-path 'binary)))"
"(dynamic-wind"
" void"
"(lambda() "
@ -580,7 +568,7 @@
" v))"
" (error \"ill-formed content\"))"
"(let((ht(make-hasheq))"
"(dir(let-values(((base name dir?)(split-path a-links-path)))"
"(dir(let-values(((base name dir?)(split-path links-path)))"
" base)))"
"(for-each"
"(lambda(p)"
@ -611,17 +599,9 @@
"(hash-for-each"
" ht"
"(lambda(k v)(hash-set! ht k(reverse v))))"
"(cond"
"(user?"
"(set! user-links-cache ht)"
"(set! user-links-stamp ts))"
"(else"
"(vector-set! links-caches ii ht)"
"(vector-set! links-stamps ii ts)))"
"(hash-set! links-cache links-path(cons ts ht))"
" ht)))))"
"(cond"
"(user? user-links-cache)"
"(else(vector-ref links-caches ii))))))))))"
"(cdr links-stamp+cache))))))))"
"(define-values(normalize-collection-reference)"
"(lambda(collection collection-path)"
"(cond"
@ -645,29 +625,28 @@
"(lambda(fail collection collection-path file-name)"
"(let-values(((collection collection-path)"
"(normalize-collection-reference collection collection-path)))"
"(let((all-paths(let((sym(string->symbol(if(path? collection)"
"(let((all-paths(let((sym(string->symbol "
"(if(path? collection)"
"(path->string collection)"
" collection)))"
"(links?(use-collection-link-paths)))"
" collection))))"
"(let loop((l(current-library-collection-links)))"
"(cond"
"((null? l) null)"
"((not(car l))"
"(append "
"(current-library-collection-paths)"
"(loop(cdr l))))"
"((hash?(car l))"
"(append"
"(if(and links? "
"(use-user-specific-search-paths)"
" user-links-path)"
"(append"
"(let((ht(get-linked-collections #t 0)))"
"(append(hash-ref ht sym null)"
"(hash-ref ht #f null))))"
" null)"
"(if links?"
"(let loop((ii 0))"
"(if(ii . >= .(vector-length links-paths))"
" null"
"(let((ht(get-linked-collections #f ii)))"
"(append(hash-ref ht sym null)"
"(map box(hash-ref(car l) sym null))"
"(hash-ref(car l) #f null)"
"(loop(cdr l))))"
"(else"
"(let((ht(get-linked-collections(car l))))"
"(append "
"(hash-ref ht sym null)"
"(hash-ref ht #f null)"
"(loop(add1 ii))))))"
" null)"
"(current-library-collection-paths)))))"
"(loop(cdr l))))))))))"
"(define-values(done)"
"(lambda(p)"
"(if file-name(build-path p file-name) p)))"

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

@ -190,6 +190,7 @@
collection-path
collection-file-path
find-library-collection-paths
find-library-collection-links
path-list-string->path-list
find-executable-path
load/use-compiled
@ -504,42 +505,37 @@
[else (cons (coerce-to-path (car l)) (loop (cdr l)))]))
orig-l))))
(define-values (all-links-paths) (find-links-path!
;; This thunk is called once per place, and the result
;; is remembered for later invocations. Otherwise, the
;; search for the config file can trip over filesystem
;; restrictions imposed by security guards.
(lambda ()
;; If `use-collection-link-paths' is disabled on
;; startup, then don't try to read the configuration
;; file, either.
(if (use-collection-link-paths)
(let* ([d (find-config-dir)]
[ht (get-config-table d)]
[lf (coerce-to-path
(or (hash-ref ht 'links-file #f)
(build-path (or (hash-ref ht 'share-dir #f)
(build-path 'up "share"))
"links.rktd")))])
(cons (list->vector
(add-config-search
ht
'links-search-files
(list lf)))
(build-path (find-system-path 'addon-dir)
(get-installation-name ht)
"links.rktd")))
(cons #() #f)))))
(define-values (find-library-collection-links)
(lambda ()
(let* ([d (find-config-dir)]
[ht (get-config-table d)]
[lf (coerce-to-path
(or (hash-ref ht 'links-file #f)
(build-path (or (hash-ref ht 'share-dir #f)
(build-path 'up "share"))
"links.rktd")))])
(append
;; `#f' means `current-library-collection-paths':
(list #f)
;; user-specific
(if (and (use-user-specific-search-paths)
(use-collection-link-paths))
(list (build-path (find-system-path 'addon-dir)
(get-installation-name ht)
"links.rktd"))
null)
;; installation-wide:
(if (use-collection-link-paths)
(add-config-search
ht
'links-search-files
(list lf))
null)))))
(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-stamps) (make-vector (vector-length links-paths) #f))
;; map from link-file names to cached information:
(define-values (links-cache) (make-weak-hash))
;; used for low-level except abort below:
(define-values (stamp-prompt-tag) (make-continuation-prompt-tag 'stamp))
(define-values (file->stamp)
@ -606,7 +602,9 @@
(not (car a)))))
(define-values (get-linked-collections)
(lambda (user? ii)
(lambda (links-path)
;; Use/save information in `links-cache', relying on filesystem-change events
;; or a copy of the file to detect when the cache is stale.
(call/ec (lambda (esc)
(define-values (make-handler)
(lambda (ts)
@ -617,20 +615,12 @@
(log-message l 'error
(format
"error reading collection links file ~s: ~a"
(cond
[user? user-links-path]
[else (vector-ref links-paths ii)])
links-path
(exn-message exn))
(current-continuation-marks))))
(void))
(when ts
(cond
[user?
(set! user-links-cache (make-hasheq))
(set! user-links-stamp ts)]
[else
(vector-set! links-caches ii (make-hasheq))
(vector-set! links-stamps ii ts)]))
(hash-set! links-cache links-path (cons #hasheq() ts)))
(if (exn:fail? exn)
(esc (make-hasheq))
;; re-raise the exception (which is probably a break)
@ -638,13 +628,9 @@
(with-continuation-mark
exception-handler-key
(make-handler #f)
(let* ([a-links-path (cond
[user? user-links-path]
[else (vector-ref links-paths ii)])]
[a-links-stamp (cond
[user? user-links-stamp]
[else (vector-ref links-stamps ii)])]
[ts (file->stamp a-links-path a-links-stamp)])
(let* ([links-stamp+cache (hash-ref links-cache links-path '(#f . #hasheq()))]
[a-links-stamp (car links-stamp+cache)]
[ts (file->stamp links-path a-links-stamp)])
(if (not (equal? ts a-links-stamp))
(with-continuation-mark
exception-handler-key
@ -653,7 +639,7 @@
(lambda ()
(let ([v (if (no-file-stamp? ts)
null
(let ([p (open-input-file a-links-path 'binary)])
(let ([p (open-input-file links-path 'binary)])
(dynamic-wind
void
(lambda ()
@ -676,7 +662,7 @@
v))
(error "ill-formed content"))
(let ([ht (make-hasheq)]
[dir (let-values ([(base name dir?) (split-path a-links-path)])
[dir (let-values ([(base name dir?) (split-path links-path)])
base)])
(for-each
(lambda (p)
@ -715,17 +701,9 @@
ht
(lambda (k v) (hash-set! ht k (reverse v))))
;; save table & file content:
(cond
[user?
(set! user-links-cache ht)
(set! user-links-stamp ts)]
[else
(vector-set! links-caches ii ht)
(vector-set! links-stamps ii ts)])
(hash-set! links-cache links-path (cons ts ht))
ht)))))
(cond
[user? user-links-cache]
[else (vector-ref links-caches ii)]))))))))
(cdr links-stamp+cache))))))))
(define-values (normalize-collection-reference)
(lambda (collection collection-path)
@ -752,32 +730,38 @@
(lambda (fail collection collection-path file-name)
(let-values ([(collection collection-path)
(normalize-collection-reference collection collection-path)])
(let ([all-paths (let ([sym (string->symbol (if (path? collection)
(path->string collection)
collection))]
[links? (use-collection-link-paths)])
(append
;; list of paths and (box path)s:
(if (and links?
(use-user-specific-search-paths)
user-links-path)
(append
(let ([ht (get-linked-collections #t 0)])
(append (hash-ref ht sym null)
(hash-ref ht #f null))))
null)
;; list of paths and (box path)s:
(if links?
(let loop ([ii 0])
(if (ii . >= . (vector-length links-paths))
null
(let ([ht (get-linked-collections #f ii)])
(append (hash-ref ht sym null)
(hash-ref ht #f null)
(loop (add1 ii))))))
null)
;; list of paths:
(current-library-collection-paths)))])
(let ([all-paths (let ([sym (string->symbol
(if (path? collection)
(path->string collection)
collection))])
(let loop ([l (current-library-collection-links)])
(cond
[(null? l) null]
[(not (car l))
;; #f is the point where we try the old parameter:
(append
(current-library-collection-paths)
(loop (cdr l)))]
[(hash? (car l))
;; A hash table maps a collection-name symbol
;; to a list of paths. We need to wrap each path
;; in a box, because that's how the code below
;; knows that it's a single collection's directory.
;; A hash table can also map #f to a list of paths
;; for directories that hold collections.
(append
(map box (hash-ref (car l) sym null))
(hash-ref (car l) #f null)
(loop (cdr l)))]
[else
(let ([ht (get-linked-collections (car l))])
(append
;; Table values are lists of paths and (box path)s,
;; where a (box path) is a collection directory
;; (instead of a directory containing collections).
(hash-ref ht sym null)
(hash-ref ht #f null)
(loop (cdr l))))])))])
(define-values (done)
(lambda (p)
(if file-name (build-path p file-name) p)))

2
racket/src/racket/src/thread.c
View File

@ -669,7 +669,6 @@ void scheme_init_paramz(Scheme_Env *env)
GLOBAL_PRIM_W_ARITY("check-for-break" , check_break_now , 0, 0, newenv);
GLOBAL_PRIM_W_ARITY("reparameterize" , reparameterize , 1, 1, newenv);
GLOBAL_PRIM_W_ARITY("make-custodian-from-main", make_custodian_from_main, 0, 0, newenv);
GLOBAL_PRIM_W_ARITY("find-links-path!" , scheme_find_links_path , 1, 1, newenv);
scheme_finish_primitive_module(newenv);
scheme_protect_primitive_provide(newenv, NULL);
@ -7454,6 +7453,7 @@ static void make_initial_config(Scheme_Thread *p)
: scheme_false));
init_param(cells, paramz, MZCONFIG_COLLECTION_PATHS, scheme_null);
init_param(cells, paramz, MZCONFIG_COLLECTION_LINKS, scheme_null);
{
Scheme_Security_Guard *sg;