use `filesystem-change-evt' and static roots to speed library search
Use `filesystem-change-evt' (where supported) to detect changes to collection link files. Add "static root" as a new kind of collection root directory in links files. A static root directory is assumed to not change (in terms of its collection subdirectories) as long as the links file itself does not change. Propagate the notion of static roots through `raco link' and `raco pkg install'. Change the `pkg-links' makefile target to install static links instead of plain links. The result of all of these changes is to cut 25%-33% of the time for `racket -l racket', bringing it back in line with the pre-package-reorganization time.
This commit is contained in:
Matthew Flatt
parent
3b0566ea0a
commit
b8e20f5a3e
|
|
@ -234,7 +234,9 @@
|
|||
(send install-button enable (and (pair? sels)
|
||||
(or (and all-installed?
|
||||
(not (for/or ([p (in-list sels)])
|
||||
(eq? 'link (car (pkg-info-orig-pkg (cdr p)))))))
|
||||
(define kind (car (pkg-info-orig-pkg (cdr p))))
|
||||
(or (eq? 'link kind)
|
||||
(eq? 'static-link kind)))))
|
||||
none-installed?)))
|
||||
(send install-button set-label (if all-installed?
|
||||
(string-constant install-pkg-update)
|
||||
|
|
@ -462,6 +464,7 @@
|
|||
(case (car (pkg-info-orig-pkg info))
|
||||
[(catalog) ""]
|
||||
[(link) "="]
|
||||
[(static-link) "="]
|
||||
[(url) "@"]))]))
|
||||
(for/list ([p list-pkgs]) (->label-string (db:pkg-name p)))
|
||||
(for/list ([p list-pkgs]) (->label-string (db:pkg-author p)))
|
||||
|
|
|
|||
|
|
@ -70,7 +70,8 @@ catalogs}.}
|
|||
|
||||
@defstruct[pkg-info ([orig-pkg (or/c (list/c 'catalog string?)
|
||||
(list/c 'url string?)
|
||||
(list/c 'link string?))]
|
||||
(list/c 'link string?)
|
||||
(list/c 'static-link string?))]
|
||||
[checksum (or/c #f string?)]
|
||||
[auto? boolean?])
|
||||
#:prefab]{
|
||||
|
|
@ -117,7 +118,8 @@ scope}.}
|
|||
@deftogether[(
|
||||
@defproc[(pkg-desc? [v any/c]) boolean?]
|
||||
@defproc[(pkg-desc [name string?]
|
||||
[type (or/c #f 'file 'dir 'link 'file-url 'dir-url 'github 'name)]
|
||||
[type (or/c #f 'file 'dir 'link 'static-link
|
||||
'file-url 'dir-url 'github 'name)]
|
||||
[checksum (or/c string? #f)]
|
||||
[auto? boolean?])
|
||||
pkg-desc?]
|
||||
|
|
|
|||
|
|
@ -311,6 +311,13 @@ sub-sub-commands:
|
|||
definition in @filepath{info.rkt} is changed (i.e., he package must be removed and re-installed
|
||||
for the change to take effect).}
|
||||
|
||||
@item{@DFlag{static-link} --- Implies @DFlag{link}, and also indicates that subdirectories
|
||||
of the given directory will not change for each given directory that implements a
|
||||
@tech{multi-collection package}.}
|
||||
|
||||
@item{@DFlag{skip-installed} --- Ignore any @nonterm{pkg-source}
|
||||
whose name corresponds to an already-installed package.}
|
||||
|
||||
@item{@DFlag{scope} @nonterm{scope} --- Selects the @tech{package scope} for installation, where @nonterm{scope} is one of
|
||||
@itemlist[
|
||||
@item{@exec{installation} --- Install packages for all users of a Racket installation, rather than user-specific.}
|
||||
|
|
@ -925,12 +932,13 @@ requires reinstallation of all packages every version change.)
|
|||
|
||||
@subsection{Where and how are packages installed?}
|
||||
|
||||
User-specific and Racket-version-specific packages are in @racket[(build-path
|
||||
(find-system-path 'addon-dir) (version) "pkgs")], user-specific and
|
||||
all-version packages are in @racket[(build-path (find-system-path
|
||||
'addon-dir) "pkgs")], and installation-wide packages are in
|
||||
@racket[(build-path (find-lib-dir) "pkgs")]. They are linked as
|
||||
collection roots with @exec{raco link}.
|
||||
User-specific and Racket-version-specific packages are in
|
||||
@racket[(build-path (find-system-path 'addon-dir) (version) "pkgs")],
|
||||
user-specific and all-version packages are in @racket[(build-path
|
||||
(find-system-path 'addon-dir) "pkgs")], and installation-wide packages
|
||||
are in @racket[(build-path (find-lib-dir) "pkgs")]. They are linked as
|
||||
collections (for single-collection packages) collection roots (for
|
||||
multi-collection packages) with @exec{raco link}.
|
||||
|
||||
@subsection{How are user-specific and installation-wide @tech{package scopes}
|
||||
related for conflict checking?}
|
||||
|
|
|
|||
|
|
@ -77,6 +77,11 @@ Full command-line options:
|
|||
that match a directory are removed. This flag is mutually
|
||||
exclusive with @Flag{n} and @DFlag{name}.}
|
||||
|
||||
@item{@Flag{D} or @DFlag{static-root} --- Like @Flag{d} or
|
||||
@DFlag{root}, but each directory is assumed to have a constant
|
||||
set of subdirectories (to improve the use of collection-search
|
||||
caches) as long as the links file itself does not change.}
|
||||
|
||||
@item{@Flag{x} @nonterm{regexp} or @DFlag{version-regexp}
|
||||
@nonterm{regexp} --- Sets a version regexp that limits the link
|
||||
to use only by Racket versions (as reported by
|
||||
|
|
@ -133,6 +138,7 @@ Full command-line options:
|
|||
[#:file file (or/c path-string? #f) #f]
|
||||
[#:name name (or/c string? #f) #f]
|
||||
[#:root? root? any/c #f]
|
||||
[#:static-root? static-root? any/c #f]
|
||||
[#:version-regexp version-regexp (or/c regexp? #f) #f]
|
||||
[#:error error-proc (symbol? string? any/c ... . -> . any) error]
|
||||
[#:remove? remove? any/c #f]
|
||||
|
|
@ -149,6 +155,10 @@ user-specific, all-version @tech[#:doc reference-doc]{collection links file} if
|
|||
@racket[shared?] is true, or the installation-wide @tech[#:doc
|
||||
reference-doc]{collection links file} otherwise.
|
||||
|
||||
The @racket[static-root?] flag value is ignored unless @racket[root?]
|
||||
is true and @racket[remove?] is false, in which case each given
|
||||
@racket[dir] is added as a static root if @racket[static-root?] is true.
|
||||
|
||||
The @racket[error-proc] argument is called to raise exceptions that
|
||||
would be fatal to the @exec{raco link} command.
|
||||
|
||||
|
|
|
|||
|
|
@ -217,12 +217,16 @@ 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)], or @racket[(list 'root _regexp)]. A @racket[_string] names a
|
||||
_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)]. If @racket[_path] is a
|
||||
@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
|
||||
|
|
|
|||
|
|
@ -613,7 +613,7 @@
|
|||
(let ()
|
||||
(match-define (pkg-info orig-pkg checksum _) info)
|
||||
(match orig-pkg
|
||||
[`(link ,orig-pkg-dir)
|
||||
[`(,(or 'link 'static-link) ,orig-pkg-dir)
|
||||
orig-pkg-dir]
|
||||
[_
|
||||
(build-path (pkg-installed-dir) pkg-name)]))))
|
||||
|
|
@ -662,7 +662,7 @@
|
|||
(for/fold ([pkg #f] [subpath #f]) ([(k v) (in-hash (read-pkg-db/cached))]
|
||||
#:when (not pkg))
|
||||
(match (pkg-info-orig-pkg v)
|
||||
[`(link ,orig-pkg-dir)
|
||||
[`(,(or 'link 'static-link) ,orig-pkg-dir)
|
||||
(define e (explode orig-pkg-dir))
|
||||
(if (sub-path? <= p e)
|
||||
(values k (build-path* (list-tail p (length e))))
|
||||
|
|
@ -687,7 +687,7 @@
|
|||
(define shared? (and user?
|
||||
(eq? (current-pkg-scope) 'shared)))
|
||||
(match orig-pkg
|
||||
[`(link ,_)
|
||||
[`(,(or 'link 'static-link) ,_)
|
||||
(links pkg-dir
|
||||
#:remove? #t
|
||||
#:user? user?
|
||||
|
|
@ -1040,14 +1040,16 @@
|
|||
(unless staged?
|
||||
(delete-directory/files pkg-dir))))]
|
||||
[(or (eq? type 'dir)
|
||||
(eq? type 'link))
|
||||
(eq? type 'link)
|
||||
(eq? type 'static-link))
|
||||
(unless (directory-exists? pkg)
|
||||
(pkg-error "no such directory\n path: ~a" pkg))
|
||||
(let ([pkg (directory-path-no-slash pkg)])
|
||||
(cond
|
||||
[(eq? type 'link)
|
||||
[(or (eq? type 'link)
|
||||
(eq? type 'static-link))
|
||||
(install-info pkg-name
|
||||
`(link ,(simple-form-path* pkg))
|
||||
`(,type ,(simple-form-path* pkg))
|
||||
pkg
|
||||
#f #f
|
||||
(directory->module-paths pkg pkg-name metadata-ns))]
|
||||
|
|
@ -1363,7 +1365,9 @@
|
|||
(path? scope)))
|
||||
#:shared? (eq? 'shared scope)
|
||||
#:file (scope->links-file scope)
|
||||
#:root? (not single-collect))
|
||||
#:root? (not single-collect)
|
||||
#:static-root? (and (pair? orig-pkg)
|
||||
(eq? 'static-link (car orig-pkg))))
|
||||
(define this-pkg-info
|
||||
(if single-collect
|
||||
(sc-pkg-info orig-pkg checksum auto? single-collect)
|
||||
|
|
@ -1503,13 +1507,13 @@
|
|||
(match-define (pkg-info orig-pkg checksum _)
|
||||
(package-info pkg-name))
|
||||
(define ty (first orig-pkg))
|
||||
(not (member ty '(link dir file))))
|
||||
(not (member ty '(link static-link dir file))))
|
||||
|
||||
(define ((update-package download-printf) pkg-name)
|
||||
(match-define (pkg-info orig-pkg checksum auto?)
|
||||
(package-info pkg-name))
|
||||
(match orig-pkg
|
||||
[`(link ,_)
|
||||
[`(,(or 'link 'static-link) ,_)
|
||||
(pkg-error (~a "cannot update linked packages\n"
|
||||
" package name: ~a\n"
|
||||
" package source: ~a")
|
||||
|
|
@ -2258,7 +2262,7 @@
|
|||
(values (or/c #f string?) (or/c #f 'same path?)))]
|
||||
[pkg-desc
|
||||
(-> string?
|
||||
(or/c #f 'file 'dir 'link 'file-url 'dir-url 'github 'name)
|
||||
(or/c #f 'file 'dir 'link 'static-link 'file-url 'dir-url 'github 'name)
|
||||
(or/c string? #f)
|
||||
boolean?
|
||||
pkg-desc?)]
|
||||
|
|
|
|||
|
|
@ -74,7 +74,10 @@
|
|||
" search-auto: like 'search-ask' but does not ask for permission to install")]
|
||||
[#:bool force () "Ignores conflicts"]
|
||||
[#:bool ignore-checksums () "Ignores checksums"]
|
||||
#:once-any
|
||||
[#:bool link () ("Link a directory package source in place")]
|
||||
[#:bool static-link () ("Link in place, promising collections do not change")]
|
||||
#:once-each
|
||||
[#:bool skip-installed () ("Skip a <pkg-source> if already installed")]
|
||||
#:once-any
|
||||
[(#:sym scope [installation user shared] #f) scope ()
|
||||
|
|
@ -107,7 +110,10 @@
|
|||
#:ignore-checksums? ignore-checksums
|
||||
#:skip-installed? skip-installed
|
||||
(for/list ([p (in-list pkg-source)])
|
||||
(pkg-desc p (or (and link 'link) type) name #f))))))
|
||||
(define a-type (or (and link 'link)
|
||||
(and static-link 'static-link)
|
||||
type))
|
||||
(pkg-desc p a-type name #f))))))
|
||||
(setup no-setup setup-collects jobs)))]
|
||||
[update
|
||||
"Update packages"
|
||||
|
|
|
|||
|
|
@ -95,7 +95,9 @@
|
|||
(define name (extract-archive-name name+ext))
|
||||
(values name 'file)]
|
||||
[(if type
|
||||
(or (eq? type 'dir) (eq? type 'link))
|
||||
(or (eq? type 'dir)
|
||||
(eq? type 'link)
|
||||
(eq? type 'static-link))
|
||||
(path-string? s))
|
||||
(define-values (base name dir?) (split-path s))
|
||||
(define dir-name (and (path? name) (path->string name)))
|
||||
|
|
|
|||
|
|
@ -7,6 +7,7 @@
|
|||
(define link-file (make-parameter #f))
|
||||
(define link-name (make-parameter #f))
|
||||
(define root-mode (make-parameter #f))
|
||||
(define static-root-mode (make-parameter #f))
|
||||
(define link-version (make-parameter #f))
|
||||
(define remove-mode (make-parameter #f))
|
||||
(define repair-mode (make-parameter #f))
|
||||
|
|
@ -28,6 +29,9 @@
|
|||
(link-name name)]
|
||||
[("-d" "--root") "Treat <dir> as a collection root"
|
||||
(root-mode #t)]
|
||||
[("-D" "--static-root") "Treat <dir> as a static collection root"
|
||||
(root-mode #t)
|
||||
(static-root-mode #t)]
|
||||
#:once-each
|
||||
[("-x" "--version-regexp") regexp "Set the version pregexp"
|
||||
(with-handlers ([exn:fail:contract? (lambda (exn)
|
||||
|
|
@ -74,6 +78,7 @@
|
|||
(apply links
|
||||
dirs
|
||||
#:root? (root-mode)
|
||||
#:static-root? (static-root-mode)
|
||||
#:user? user?
|
||||
#:shared? shared?
|
||||
#:file (link-file)
|
||||
|
|
|
|||
|
|
@ -12,6 +12,7 @@
|
|||
#:version-regexp [version-regexp #f]
|
||||
#:shared? [shared? #f]
|
||||
#:root? [root? #f]
|
||||
#:static-root? [static-root? #f]
|
||||
#:remove? [remove? #f]
|
||||
#:show? [show? #f]
|
||||
#:repair? [repair? #f]
|
||||
|
|
@ -67,8 +68,9 @@
|
|||
(content-error "entry is a not a 2- or 3-element list: " e))
|
||||
#:when
|
||||
(or (or (string? (car e))
|
||||
(eq? 'root (car e)))
|
||||
(content-error "entry's first element is not a string or 'root: " e))
|
||||
(eq? 'root (car e))
|
||||
(eq? 'static-root (car e)))
|
||||
(content-error "entry's first element is not a string, 'root, or 'static-root: " e))
|
||||
#:when
|
||||
(or (path-string? (cadr e))
|
||||
(content-error "entry's second element is not a path string: " e))
|
||||
|
|
@ -115,7 +117,9 @@
|
|||
(path->complete-path d))
|
||||
#:more-than-root? #t))]
|
||||
[a-name (if root?
|
||||
'root
|
||||
(if static-root?
|
||||
'static-root
|
||||
'root)
|
||||
(and d
|
||||
(or name
|
||||
(let-values ([(base name dir?) (split-path dp)])
|
||||
|
|
@ -136,7 +140,8 @@
|
|||
(and name
|
||||
(not (equal? (car e) name)))
|
||||
(and root?
|
||||
(not (eq? (car e) 'root)))
|
||||
(not (or (eq? (car e) 'root)
|
||||
(eq? (car e) 'static-root))))
|
||||
(and version-regexp
|
||||
(pair? (cddr e))
|
||||
(not (equal? (caddr e) version-regexp)))))
|
||||
|
|
@ -181,7 +186,8 @@
|
|||
(when show?
|
||||
(for ([e (in-list new-table)])
|
||||
(printf " ~a~s path: ~s~a\n"
|
||||
(if (eq? (car e) 'root)
|
||||
(if (or (eq? (car e) 'root)
|
||||
(eq? (car e) 'static-root))
|
||||
""
|
||||
"collection: ")
|
||||
(car e)
|
||||
|
|
@ -197,7 +203,8 @@
|
|||
(if root?
|
||||
;; Return root paths:
|
||||
(for/list ([e (in-list new-table)]
|
||||
#:when (eq? 'root (car e))
|
||||
#:when (or (eq? 'root (car e))
|
||||
(eq? 'static-root (car e)))
|
||||
#:when (or (null? (cddr e))
|
||||
(regexp-match? (caddr e) (version))))
|
||||
(simplify (cadr e)))
|
||||
|
|
|
|||
|
|
@ -174,7 +174,7 @@
|
|||
(define auto? (is-auto? name))
|
||||
(printf "Adding ~a~a as ~a\n" name (if auto? "*" "") dir)
|
||||
(pkg-desc (path->string dir)
|
||||
'link
|
||||
'static-link
|
||||
#f
|
||||
auto?)))))
|
||||
|
||||
|
|
|
|||
File diff suppressed because it is too large
Load Diff
|
|
@ -424,7 +424,13 @@
|
|||
"(define-values(links-stamps)(make-vector(vector-length links-paths) #f))"
|
||||
"(define-values(stamp-prompt-tag)(make-continuation-prompt-tag 'stamp))"
|
||||
"(define-values(file->stamp)"
|
||||
"(lambda(path)"
|
||||
"(lambda(path old-stamp)"
|
||||
"(cond"
|
||||
"((and old-stamp"
|
||||
"(cdr old-stamp)"
|
||||
"(not(sync/timeout 0(cdr old-stamp))))"
|
||||
" old-stamp)"
|
||||
"(else"
|
||||
"(call-with-continuation-prompt"
|
||||
"(lambda()"
|
||||
"(with-continuation-mark"
|
||||
|
|
@ -435,6 +441,18 @@
|
|||
"(if(exn:fail:filesystem? exn)"
|
||||
"(lambda() #f)"
|
||||
"(lambda()(raise exn)))))"
|
||||
"(let((dir-evt"
|
||||
"(let loop((path path))"
|
||||
"(let-values(((base name dir?)(split-path path)))"
|
||||
"(and(path? base)"
|
||||
"(if(directory-exists? base)"
|
||||
"(filesystem-change-evt base(lambda() #f))"
|
||||
"(loop base)))))))"
|
||||
"(if(not(file-exists? path))"
|
||||
"(cons #f dir-evt)"
|
||||
"(let((evt(filesystem-change-evt path(lambda() #f))))"
|
||||
"(when dir-evt(filesystem-change-evt-cancel dir-evt))"
|
||||
"(cons"
|
||||
"(let((p(open-input-file path)))"
|
||||
"(dynamic-wind"
|
||||
" void"
|
||||
|
|
@ -452,8 +470,18 @@
|
|||
" null"
|
||||
"(cons bstr(loop)))))))"
|
||||
" bstr)))"
|
||||
"(lambda()(close-input-port p))))))"
|
||||
" stamp-prompt-tag)))"
|
||||
"(lambda()(close-input-port p))))"
|
||||
" evt))))))"
|
||||
" stamp-prompt-tag)))))"
|
||||
"(define-values(stamp=?)"
|
||||
"(lambda(a b)"
|
||||
"(if(and(pair? a)(pair? b))"
|
||||
"(equal?(car a)(car b))"
|
||||
"(equal? a b))))"
|
||||
"(define-values(no-file-stamp?)"
|
||||
"(lambda(a)"
|
||||
"(or(not a)"
|
||||
"(not(car a)))))"
|
||||
"(define-values(get-linked-collections)"
|
||||
"(lambda(user? shared? ii)"
|
||||
"(call/ec(lambda(esc)"
|
||||
|
|
@ -494,11 +522,12 @@
|
|||
"(user? user-links-path)"
|
||||
"(shared? shared-links-path)"
|
||||
"(else(vector-ref links-paths ii))))"
|
||||
"(ts(file->stamp a-links-path)))"
|
||||
"(if(not(equal? ts(cond"
|
||||
"(a-links-stamp(cond"
|
||||
"(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)))"
|
||||
"(if(not(stamp=? ts a-links-stamp))"
|
||||
"(with-continuation-mark"
|
||||
" exception-handler-key"
|
||||
"(make-handler ts)"
|
||||
|
|
@ -516,7 +545,9 @@
|
|||
"(read-accept-reader #t)"
|
||||
"(read-accept-lang #f)"
|
||||
"(current-readtable #f))"
|
||||
"(let((v(let((p(open-input-file a-links-path 'binary)))"
|
||||
"(let((v(if(no-file-stamp? ts)"
|
||||
" null"
|
||||
"(let((p(open-input-file a-links-path 'binary)))"
|
||||
"(dynamic-wind"
|
||||
" void"
|
||||
"(lambda() "
|
||||
|
|
@ -524,14 +555,15 @@
|
|||
"(read p)"
|
||||
"(unless(eof-object?(read p))"
|
||||
" (error \"expected a single S-expression\"))))"
|
||||
"(lambda()(close-input-port p))))))"
|
||||
"(lambda()(close-input-port p)))))))"
|
||||
"(unless(and(list? v)"
|
||||
"(andmap(lambda(p)"
|
||||
"(and(list? p)"
|
||||
"(or(= 2(length p))"
|
||||
"(= 3(length p)))"
|
||||
"(or(string?(car p))"
|
||||
"(eq? 'root(car p)))"
|
||||
"(eq? 'root(car p))"
|
||||
"(eq? 'static-root(car p)))"
|
||||
"(path-string?(cadr p))"
|
||||
"(or(null?(cddr p))"
|
||||
"(regexp?(caddr p)))))"
|
||||
|
|
@ -546,17 +578,25 @@
|
|||
"(regexp-match?(caddr p)(version)))"
|
||||
"(let((dir(simplify-path"
|
||||
"(path->complete-path(cadr p) dir))))"
|
||||
"(if(symbol?(car p))"
|
||||
"(begin"
|
||||
"(cond"
|
||||
"((eq?(car p) 'static-root)"
|
||||
"(for-each"
|
||||
"(lambda(sub)"
|
||||
"(when(directory-exists?(build-path dir sub))"
|
||||
"(let((k(string->symbol(path->string sub))))"
|
||||
"(hash-set! ht k(cons dir(hash-ref ht k null))))))"
|
||||
"(directory-list dir)))"
|
||||
"((eq?(car p) 'root)"
|
||||
"(unless(hash-ref ht #f #f)"
|
||||
"(hash-set! ht #f null))"
|
||||
"(hash-for-each"
|
||||
" ht"
|
||||
"(lambda(k v)"
|
||||
"(hash-set! ht k(cons dir v)))))"
|
||||
"(else"
|
||||
"(let((s(string->symbol(car p))))"
|
||||
"(hash-set! ht s(cons(box dir)"
|
||||
"(hash-ref ht s null))))))))"
|
||||
"(hash-ref ht s null)))))))))"
|
||||
" v)"
|
||||
"(hash-for-each"
|
||||
" ht"
|
||||
|
|
|
|||
|
|
@ -505,42 +505,72 @@
|
|||
(define-values (stamp-prompt-tag) (make-continuation-prompt-tag 'stamp))
|
||||
|
||||
(define-values (file->stamp)
|
||||
(lambda (path)
|
||||
;; We'd prefer to do something lighter than read the file every time!
|
||||
;; Using just the file's modification date almost works, but 1-second
|
||||
;; granularity isn't fine enough. To do this right, probably Racket needs
|
||||
;; to provide more support from the OS's filesystem (along the lines of
|
||||
;; inotify, but the interface varies among platforms).
|
||||
(call-with-continuation-prompt
|
||||
(lambda ()
|
||||
(with-continuation-mark
|
||||
exception-handler-key
|
||||
(lambda (exn)
|
||||
(abort-current-continuation
|
||||
stamp-prompt-tag
|
||||
(if (exn:fail:filesystem? exn)
|
||||
(lambda () #f)
|
||||
(lambda () (raise exn)))))
|
||||
(let ([p (open-input-file path)])
|
||||
(dynamic-wind
|
||||
void
|
||||
(lambda ()
|
||||
(let ([bstr (read-bytes 8192 p)])
|
||||
(if (and (bytes? bstr)
|
||||
((bytes-length bstr) . >= . 8192))
|
||||
(apply
|
||||
bytes-append
|
||||
(cons
|
||||
bstr
|
||||
(let loop ()
|
||||
(let ([bstr (read-bytes 8192 p)])
|
||||
(if (eof-object? bstr)
|
||||
null
|
||||
(cons bstr (loop)))))))
|
||||
bstr)))
|
||||
(lambda () (close-input-port p))))))
|
||||
stamp-prompt-tag)))
|
||||
(lambda (path old-stamp)
|
||||
;; Using just the file's modification date almost works as a stamp,
|
||||
;; but 1-second granularity isn't fine enough. A stamp is therefore
|
||||
;; the file content paired with a filesystem-change event (where
|
||||
;; supported), and the event lets us recycle the old stamp almost
|
||||
;; always.
|
||||
(cond
|
||||
[(and old-stamp
|
||||
(cdr old-stamp)
|
||||
(not (sync/timeout 0 (cdr old-stamp))))
|
||||
old-stamp]
|
||||
[else
|
||||
(call-with-continuation-prompt
|
||||
(lambda ()
|
||||
(with-continuation-mark
|
||||
exception-handler-key
|
||||
(lambda (exn)
|
||||
(abort-current-continuation
|
||||
stamp-prompt-tag
|
||||
(if (exn:fail:filesystem? exn)
|
||||
(lambda () #f)
|
||||
(lambda () (raise exn)))))
|
||||
(let ([dir-evt
|
||||
(let loop ([path path])
|
||||
(let-values ([(base name dir?) (split-path path)])
|
||||
(and (path? base)
|
||||
(if (directory-exists? base)
|
||||
(filesystem-change-evt base (lambda () #f))
|
||||
(loop base)))))])
|
||||
(if (not (file-exists? path))
|
||||
(cons #f dir-evt)
|
||||
(let ([evt (filesystem-change-evt path (lambda () #f))])
|
||||
(when dir-evt (filesystem-change-evt-cancel dir-evt))
|
||||
(cons
|
||||
(let ([p (open-input-file path)])
|
||||
(dynamic-wind
|
||||
void
|
||||
(lambda ()
|
||||
(let ([bstr (read-bytes 8192 p)])
|
||||
(if (and (bytes? bstr)
|
||||
((bytes-length bstr) . >= . 8192))
|
||||
(apply
|
||||
bytes-append
|
||||
(cons
|
||||
bstr
|
||||
(let loop ()
|
||||
(let ([bstr (read-bytes 8192 p)])
|
||||
(if (eof-object? bstr)
|
||||
null
|
||||
(cons bstr (loop)))))))
|
||||
bstr)))
|
||||
(lambda () (close-input-port p))))
|
||||
evt))))))
|
||||
stamp-prompt-tag)])))
|
||||
|
||||
(define-values (stamp=?)
|
||||
(lambda (a b)
|
||||
(if (and (pair? a) (pair? b))
|
||||
(equal? (car a) (car b))
|
||||
(equal? a b))))
|
||||
|
||||
(define-values (no-file-stamp?)
|
||||
(lambda (a)
|
||||
(or (not a)
|
||||
(not (car a)))))
|
||||
|
||||
(define-values (get-linked-collections)
|
||||
(lambda (user? shared? ii)
|
||||
(call/ec (lambda (esc)
|
||||
|
|
@ -582,11 +612,12 @@
|
|||
[user? user-links-path]
|
||||
[shared? shared-links-path]
|
||||
[else (vector-ref links-paths ii)])]
|
||||
[ts (file->stamp a-links-path)])
|
||||
(if (not (equal? ts (cond
|
||||
[a-links-stamp (cond
|
||||
[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)])
|
||||
(if (not (stamp=? ts a-links-stamp))
|
||||
(with-continuation-mark
|
||||
exception-handler-key
|
||||
(make-handler ts)
|
||||
|
|
@ -604,22 +635,25 @@
|
|||
[read-accept-reader #t]
|
||||
[read-accept-lang #f]
|
||||
[current-readtable #f])
|
||||
(let ([v (let ([p (open-input-file a-links-path 'binary)])
|
||||
(dynamic-wind
|
||||
void
|
||||
(lambda ()
|
||||
(begin0
|
||||
(read p)
|
||||
(unless (eof-object? (read p))
|
||||
(error "expected a single S-expression"))))
|
||||
(lambda () (close-input-port p))))])
|
||||
(let ([v (if (no-file-stamp? ts)
|
||||
null
|
||||
(let ([p (open-input-file a-links-path 'binary)])
|
||||
(dynamic-wind
|
||||
void
|
||||
(lambda ()
|
||||
(begin0
|
||||
(read p)
|
||||
(unless (eof-object? (read p))
|
||||
(error "expected a single S-expression"))))
|
||||
(lambda () (close-input-port p)))))])
|
||||
(unless (and (list? v)
|
||||
(andmap (lambda (p)
|
||||
(and (list? p)
|
||||
(or (= 2 (length p))
|
||||
(= 3 (length p)))
|
||||
(or (string? (car p))
|
||||
(eq? 'root (car p)))
|
||||
(eq? 'root (car p))
|
||||
(eq? 'static-root (car p)))
|
||||
(path-string? (cadr p))
|
||||
(or (null? (cddr p))
|
||||
(regexp? (caddr p)))))
|
||||
|
|
@ -634,21 +668,31 @@
|
|||
(regexp-match? (caddr p) (version)))
|
||||
(let ([dir (simplify-path
|
||||
(path->complete-path (cadr p) dir))])
|
||||
(if (symbol? (car p))
|
||||
;; add to every table element (to keep
|
||||
;; the choices in order); need a better
|
||||
;; data structure
|
||||
(begin
|
||||
(unless (hash-ref ht #f #f)
|
||||
(hash-set! ht #f null))
|
||||
(hash-for-each
|
||||
ht
|
||||
(lambda (k v)
|
||||
(hash-set! ht k (cons dir v)))))
|
||||
;; single collection:
|
||||
(let ([s (string->symbol (car p))])
|
||||
(hash-set! ht s (cons (box dir)
|
||||
(hash-ref ht s null))))))))
|
||||
(cond
|
||||
[(eq? (car p) 'static-root)
|
||||
;; multi-collection, constant content:
|
||||
(for-each
|
||||
(lambda (sub)
|
||||
(when (directory-exists? (build-path dir sub))
|
||||
(let ([k (string->symbol (path->string sub))])
|
||||
(hash-set! ht k (cons dir (hash-ref ht k null))))))
|
||||
(directory-list dir))]
|
||||
[(eq? (car p) 'root)
|
||||
;; multi-collection, dynamic content:
|
||||
;; Add directory to the #f mapping, and also
|
||||
;; add to every existing table element (to keep
|
||||
;; the choices in order)
|
||||
(unless (hash-ref ht #f #f)
|
||||
(hash-set! ht #f null))
|
||||
(hash-for-each
|
||||
ht
|
||||
(lambda (k v)
|
||||
(hash-set! ht k (cons dir v))))]
|
||||
[else
|
||||
;; single collection:
|
||||
(let ([s (string->symbol (car p))])
|
||||
(hash-set! ht s (cons (box dir)
|
||||
(hash-ref ht s null))))]))))
|
||||
v)
|
||||
;; reverse all lists:
|
||||
(hash-for-each
|
||||
|
|
|
|||
Loading…
Reference in New Issue
Block a user