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

fix collection-file-path & related for binary package installation

Browse Source 
Binary package installation failed in the case of collection
splicing, because module-name resolution via `collection-file-path`
did not check for compiled files along hte search path of
registered collection directories.
This commit is contained in:
Matthew Flatt 2014-06-02 10:58:59 +01:00
parent e0a82393b7
commit 43d81b06da
7 changed files with 1609 additions and 1541 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

5
pkgs/compatibility-pkgs/compatibility-lib/mzscheme/private/old-procs.rkt
View File

@ -21,7 +21,7 @@
(define new:collection-path (define new:collection-path
(let ([collection-path (lambda (collection . collections) (let ([collection-path (lambda (collection . collections)
(apply collection-path (collection-path
(lambda (s) (lambda (s)
(raise (raise
(exn:fail:filesystem (exn:fail:filesystem
@ -32,12 +32,13 @@
(define new:collection-file-path (define new:collection-file-path
(let ([collection-file-path (lambda (file-name collection . collections) (let ([collection-file-path (lambda (file-name collection . collections)
(apply collection-file-path (collection-file-path
(lambda (s) (lambda (s)
(raise (raise
(exn:fail:filesystem (exn:fail:filesystem
(string-append "collection-file-path: " s) (string-append "collection-file-path: " s)
(current-continuation-marks)))) (current-continuation-marks))))
#f
file-name collection collections))]) file-name collection collections))])
collection-file-path)) collection-file-path))

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

@ -248,10 +248,12 @@ initialized @racket[current-library-collection-links], as follows:
]} ]}
@defproc*[([(collection-file-path [file path-string?] [collection path-string?] ...+) @defproc*[([(collection-file-path [file path-string?] [collection path-string?] ...+
[#:check-compiled? check-compiled? any/c #f])
path?] path?]
[(collection-file-path [file path-string?] [collection path-string?] ...+ [(collection-file-path [file path-string?] [collection path-string?] ...+
[#:fail fail-proc (string? . -> . any)]) [#:fail fail-proc (string? . -> . any)]
[#:check-compiled? check-compiled? any/c #f])
any])]{ any])]{
Returns the path to the file indicated by @racket[file] in the Returns the path to the file indicated by @racket[file] in the
@ -268,13 +270,24 @@ apply, but a directory corresponding to the @racket[collection]s is
found, then a path using the first such directory is found, then a path using the first such directory is
returned. returned.
If @racket[check-compiled?] is true, then the search also depends on
@racket[use-compiled-file-paths] and
@racket[current-compiled-file-roots]; if @racket[file] is not found,
then a compiled form of @racket[file] with the suffix @filepath{.zo}
is checked in the same way as the default @tech{compiled-load
handler}. If a compiled file is found, the result from
@racket[collection-file-path] reports the location that @racket[file]
itself would occupy (if it existed) for the found compiled file.
Finally, if the collection is not found, and if @racket[fail-proc] is Finally, if the collection is not found, and if @racket[fail-proc] is
provided, then @racket[fail-proc] is applied to an error message (that provided, then @racket[fail-proc] is applied to an error message (that
does not start @scheme["collection-file-path:"] or otherwise claim a does not start @scheme["collection-file-path:"] or otherwise claim a
source), and its result is the result of source), and its result is the result of
@racket[collection-file-path]. If @racket[fail-proc] is not provided @racket[collection-file-path]. If @racket[fail-proc] is not provided
and the collection is not found, then the and the collection is not found, then the
@exnraise[exn:fail:filesystem].} @exnraise[exn:fail:filesystem].
@history[#:changed "6.0.1.12" @elem{Added the @racket[check-compiled?] argument.}]}
@defproc*[([(collection-path [collection path-string?] ...+) @defproc*[([(collection-path [collection path-string?] ...+)

5
racket/collects/racket/private/pre-base.rkt
View File

@ -106,19 +106,20 @@
(string-append "collection-path: " s) (string-append "collection-path: " s)
(current-continuation-marks))))] (current-continuation-marks))))]
. collections) . collections)
(apply collection-path fail collection collections))]) (collection-path fail collection collections))])
collection-path)) collection-path))
(define-values (new:collection-file-path) (define-values (new:collection-file-path)
(let ([collection-file-path (new-lambda (file-name (let ([collection-file-path (new-lambda (file-name
collection collection
#:check-compiled? [check-compiled? #f]
#:fail [fail (lambda (s) #:fail [fail (lambda (s)
(raise (raise
(exn:fail:filesystem (exn:fail:filesystem
(string-append "collection-file-path: " s) (string-append "collection-file-path: " s)
(current-continuation-marks))))] (current-continuation-marks))))]
. collections) . collections)
(apply collection-file-path fail file-name collection collections))]) (collection-file-path fail check-compiled? file-name collection collections))])
collection-file-path)) collection-file-path))
(define-syntaxes (module-begin) (define-syntaxes (module-begin)

3014
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 "6.0.1.11" #define MZSCHEME_VERSION "6.0.1.12"
#define MZSCHEME_VERSION_X 6 #define MZSCHEME_VERSION_X 6
#define MZSCHEME_VERSION_Y 0 #define MZSCHEME_VERSION_Y 0
#define MZSCHEME_VERSION_Z 1 #define MZSCHEME_VERSION_Z 1
#define MZSCHEME_VERSION_W 11 #define MZSCHEME_VERSION_W 12
#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)

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

@ -352,20 +352,22 @@
"(procedure-arity-includes? fail 1))" "(procedure-arity-includes? fail 1))"
" (raise-argument-error who \"(any/c . -> . any)\" fail))))" " (raise-argument-error who \"(any/c . -> . any)\" fail))))"
"(define-values(collection-path)" "(define-values(collection-path)"
"(lambda(fail collection . collection-path) " "(lambda(fail collection collection-path) "
"(-check-collection 'collection-path collection collection-path)" "(-check-collection 'collection-path collection collection-path)"
"(-check-fail 'collection-path fail)" "(-check-fail 'collection-path fail)"
"(find-col-file fail" "(find-col-file fail"
" collection collection-path" " collection collection-path"
" #f"
" #f)))" " #f)))"
"(define-values(collection-file-path)" "(define-values(collection-file-path)"
"(lambda(fail file-name collection . collection-path) " "(lambda(fail check-compiled? file-name collection collection-path) "
"(-check-relpath 'collection-file-path file-name)" "(-check-relpath 'collection-file-path file-name)"
"(-check-collection 'collection-file-path collection collection-path)" "(-check-collection 'collection-file-path collection collection-path)"
"(-check-fail 'collection-file-path fail)" "(-check-fail 'collection-file-path fail)"
"(find-col-file fail" "(find-col-file fail"
" collection collection-path" " collection collection-path"
" file-name)))" " file-name"
" check-compiled?)))"
"(define-values(find-main-collects)" "(define-values(find-main-collects)"
"(lambda()" "(lambda()"
"(cache-configuration" "(cache-configuration"
@ -623,7 +625,7 @@
"(values name collection-path)" "(values name collection-path)"
"(normalize-collection-reference base(cons name collection-path))))))))" "(normalize-collection-reference base(cons name collection-path))))))))"
"(define-values(find-col-file)" "(define-values(find-col-file)"
"(lambda(fail collection collection-path file-name)" "(lambda(fail collection collection-path file-name check-compiled?)"
"(let-values(((collection collection-path)" "(let-values(((collection collection-path)"
"(normalize-collection-reference collection collection-path)))" "(normalize-collection-reference collection collection-path)))"
"(let((all-paths(let((sym(string->symbol " "(let((all-paths(let((sym(string->symbol "
@ -714,7 +716,8 @@
" #t" " #t"
"(directory-exists? cpath))" "(directory-exists? cpath))"
"(if file-name" "(if file-name"
"(if(or(file-exists?(build-path cpath file-name))" "(if(or(file-exists?/maybe-compiled cpath file-name"
" check-compiled?)"
"(let((alt-file-name" "(let((alt-file-name"
"(let*((file-name(if(path? file-name)" "(let*((file-name(if(path? file-name)"
"(path->string file-name)" "(path->string file-name)"
@ -724,12 +727,30 @@
" (string=? \".rkt\" (substring file-name (- len 4)))" " (string=? \".rkt\" (substring file-name (- len 4)))"
" (string-append (substring file-name 0 (- len 4)) \".ss\")))))" " (string-append (substring file-name 0 (- len 4)) \".ss\")))))"
"(and alt-file-name" "(and alt-file-name"
"(file-exists?(build-path cpath alt-file-name)))))" "(file-exists?/maybe-compiled cpath alt-file-name"
" check-compiled?))))"
"(done cpath)" "(done cpath)"
"(cloop(cdr paths)(or found-col cpath)))" "(cloop(cdr paths)(or found-col cpath)))"
"(done cpath))" "(done cpath))"
"(cloop(cdr paths) found-col)))" "(cloop(cdr paths) found-col)))"
"(cloop(cdr paths) found-col)))))))))" "(cloop(cdr paths) found-col)))))))))"
"(define-values(file-exists?/maybe-compiled)"
"(lambda(dir path check-compiled?)"
"(or(file-exists?(build-path dir path))"
"(and check-compiled?"
" (let ((try-path (path-add-suffix path #\".zo\"))"
"(modes(use-compiled-file-paths))"
"(roots(current-compiled-file-roots)))"
"(ormap(lambda(d)"
"(ormap(lambda(mode)"
"(file-exists?"
"(let((p(build-path dir mode try-path)))"
"(cond"
"((eq? d 'same) p)"
"((relative-path? d)(build-path p d))"
"(else(reroot-path p d))))))"
" modes))"
" roots))))))"
"(define-values(check-suffix-call)" "(define-values(check-suffix-call)"
"(lambda(s sfx who)" "(lambda(s sfx who)"
"(unless(or(path-for-some-system? s)" "(unless(or(path-for-some-system? s)"
@ -1257,7 +1278,8 @@
"(find-col-file show-collection-err" "(find-col-file show-collection-err"
"(if(null? cols) file(car cols))" "(if(null? cols) file(car cols))"
"(if(null? cols) null(cdr cols))" "(if(null? cols) null(cdr cols))"
" f-file)))))" " f-file"
" #t)))))"
"((string? s)" "((string? s)"
"(let*((dir(get-dir)))" "(let*((dir(get-dir)))"
"(or(path-cache-get(cons s dir))" "(or(path-cache-get(cons s dir))"
@ -1307,7 +1329,8 @@
"(find-col-file show-collection-err" "(find-col-file show-collection-err"
"(car cols)" "(car cols)"
"(cdr cols)" "(cdr cols)"
" f-file))))))" " f-file"
" #t))))))"
"((eq?(car s) 'file)" "((eq?(car s) 'file)"
"(path-ss->rkt " "(path-ss->rkt "
"(simplify-path(path->complete-path(expand-user-path(cadr s))(get-dir))))))))" "(simplify-path(path->complete-path(expand-user-path(cadr s))(get-dir))))))))"

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

@ -417,21 +417,23 @@
(raise-argument-error who "(any/c . -> . any)" fail)))) (raise-argument-error who "(any/c . -> . any)" fail))))
(define-values (collection-path) (define-values (collection-path)
(lambda (fail collection . collection-path) (lambda (fail collection collection-path)
(-check-collection 'collection-path collection collection-path) (-check-collection 'collection-path collection collection-path)
(-check-fail 'collection-path fail) (-check-fail 'collection-path fail)
(find-col-file fail (find-col-file fail
collection collection-path collection collection-path
#f
#f))) #f)))
(define-values (collection-file-path) (define-values (collection-file-path)
(lambda (fail file-name collection . collection-path) (lambda (fail check-compiled? file-name collection collection-path)
(-check-relpath 'collection-file-path file-name) (-check-relpath 'collection-file-path file-name)
(-check-collection 'collection-file-path collection collection-path) (-check-collection 'collection-file-path collection collection-path)
(-check-fail 'collection-file-path fail) (-check-fail 'collection-file-path fail)
(find-col-file fail (find-col-file fail
collection collection-path collection collection-path
file-name))) file-name
check-compiled?)))
(define-values (find-main-collects) (define-values (find-main-collects)
(lambda () (lambda ()
@ -736,7 +738,7 @@
(normalize-collection-reference base (cons name collection-path))))]))) (normalize-collection-reference base (cons name collection-path))))])))
(define-values (find-col-file) (define-values (find-col-file)
(lambda (fail collection collection-path file-name) (lambda (fail collection collection-path file-name check-compiled?)
(let-values ([(collection collection-path) (let-values ([(collection collection-path)
(normalize-collection-reference collection collection-path)]) (normalize-collection-reference collection collection-path)])
(let ([all-paths (let ([sym (string->symbol (let ([all-paths (let ([sym (string->symbol
@ -839,7 +841,8 @@
#t #t
(directory-exists? cpath)) (directory-exists? cpath))
(if file-name (if file-name
(if (or (file-exists? (build-path cpath file-name)) (if (or (file-exists?/maybe-compiled cpath file-name
check-compiled?)
(let ([alt-file-name (let ([alt-file-name
(let* ([file-name (if (path? file-name) (let* ([file-name (if (path? file-name)
(path->string file-name) (path->string file-name)
@ -849,7 +852,8 @@
(string=? ".rkt" (substring file-name (- len 4))) (string=? ".rkt" (substring file-name (- len 4)))
(string-append (substring file-name 0 (- len 4)) ".ss")))]) (string-append (substring file-name 0 (- len 4)) ".ss")))])
(and alt-file-name (and alt-file-name
(file-exists? (build-path cpath alt-file-name))))) (file-exists?/maybe-compiled cpath alt-file-name
check-compiled?))))
(done cpath) (done cpath)
;; Look further for specific file, but remember ;; Look further for specific file, but remember
;; first found directory ;; first found directory
@ -861,6 +865,24 @@
(cloop (cdr paths) found-col))) (cloop (cdr paths) found-col)))
(cloop (cdr paths) found-col))))))))) (cloop (cdr paths) found-col)))))))))
(define-values (file-exists?/maybe-compiled)
(lambda (dir path check-compiled?)
(or (file-exists? (build-path dir path))
(and check-compiled?
(let ([try-path (path-add-suffix path #".zo")]
[modes (use-compiled-file-paths)]
[roots (current-compiled-file-roots)])
(ormap (lambda (d)
(ormap (lambda (mode)
(file-exists?
(let ([p (build-path dir mode try-path)])
(cond
[(eq? d 'same) p]
[(relative-path? d) (build-path p d)]
[else (reroot-path p d)]))))
modes))
roots))))))
(define-values (check-suffix-call) (define-values (check-suffix-call)
(lambda (s sfx who) (lambda (s sfx who)
(unless (or (path-for-some-system? s) (unless (or (path-for-some-system? s)
@ -1434,7 +1456,8 @@
(find-col-file show-collection-err (find-col-file show-collection-err
(if (null? cols) file (car cols)) (if (null? cols) file (car cols))
(if (null? cols) null (cdr cols)) (if (null? cols) null (cdr cols))
f-file))))] f-file
#t))))]
[(string? s) [(string? s)
(let* ([dir (get-dir)]) (let* ([dir (get-dir)])
(or (path-cache-get (cons s dir)) (or (path-cache-get (cons s dir))
@ -1485,7 +1508,8 @@
(find-col-file show-collection-err (find-col-file show-collection-err
(car cols) (car cols)
(cdr cols) (cdr cols)
f-file)))))] f-file
#t)))))]
[(eq? (car s) 'file) [(eq? (car s) 'file)
;; Use filesystem-sensitive `simplify-path' here: ;; Use filesystem-sensitive `simplify-path' here:
(path-ss->rkt (path-ss->rkt