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

raco pkg: fix treatmennt of "file://" package sources

Browse Source 
A "file://" prefix on a package source needs to be consistently
removed. The new `package-source->path` function does that, so it
should be used to convert a package source to a filesystem path.
This commit is contained in:
Matthew Flatt 2014-06-02 06:55:51 +01:00
parent ae2b0b93a1
commit e0a82393b7
5 changed files with 92 additions and 33 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

16
pkgs/racket-pkgs/racket-doc/pkg/scribblings/name.scrbl
View File

@ -55,3 +55,19 @@ is called if a valid name cannot be inferred from @racket[source].
If @racket[link-dirs?] is true, then a directory path is reported as
type @racket['link] instead of @racket['dir].}
@defproc[(package-source->path [source string?]
[type (or/c #f 'file 'dir 'link 'static-link) #f])
path?]{
Converts a file or directory package source to a filesystem path.
The @racket[package-source->path] function is different from
@racket[string->path] in the case that @racket[source] starts with
@litchar{file://}. Also, if @racket[type] is @racket['dir],
@racket['link], or @racket['static-link], then
@racket[path->directory-path] is used to ensure that the result path
refers to a directory.
@history[#:added "10.0.1.11"]}

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

@ -117,7 +117,8 @@ The @tech{package source} types are:
@itemlist[
@item{a local file path naming an archive -- The name of the package
@item{a local file path naming an archive (as a plain path or @litchar{file://} URL)
--- The name of the package
is the basename of the archive file. The @tech{checksum} for archive
@filepath{f.@nonterm{ext}} is given by the file @filepath{f.@nonterm{ext}.CHECKSUM}.
The valid archive formats
@ -138,11 +139,12 @@ and when it starts with @litchar{file://} or does not start
with alphabetic characters followed by @litchar{://}. The inferred
package name is the filename without its suffix.}
@item{a local directory -- The name of the package is the name of the
@item{a local directory (as a plain path or @litchar{file://} URL)
--- The name of the package is the name of the
directory. The @tech{checksum} is not present.
For example,
@filepath{~/tic-tac-toe/} is directory package source.
@filepath{~/tic-tac-toe/} is a directory package source.
A package source is inferred to refer
to a directory only when it does not have a file-archive suffix, does
@ -151,7 +153,7 @@ with @litchar{file://} or does not start
with alphabetic characters followed by @litchar{://}. The inferred
package name is the directory name.}
@item{a remote URL naming an archive -- This type follows the same
@item{a remote URL naming an archive --- This type follows the same
rules as a local file path, but the archive and @tech{checksum} files are
accessed via HTTP(S).
@ -167,7 +169,7 @@ that could be inferred as a file archive.
The inferred package name is from the URL's file name in the same
way as for a file package source.}
@item{a remote URL naming a directory -- The remote directory must
@item{a remote URL naming a directory --- The remote directory must
contain a file named @filepath{MANIFEST} that lists all the contingent
files. These are downloaded into a local directory and then the rules
for local directory paths are followed. However, if the remote
@ -184,7 +186,7 @@ file, and it is treated as a directory URL when it does not end with a
path element that has an archive file suffix. The inferred package name
is the directory name.}
@item{a remote URL naming a GitHub repository -- The format for such
@item{a remote URL naming a GitHub repository --- The format for such
URLs is:
@inset{@exec{git://github.com/}@nonterm{user}@exec{/}@nonterm{repo}@;
@ -217,7 +219,7 @@ specified as a GitHub reference is automatically prefixed with
is the last element of @nonterm{path} if it is
non-empty, otherwise the inferred name is @nonterm{repo}.}
@item{a @tech{package name} -- A @tech{package catalog} is
@item{a @tech{package name} --- A @tech{package catalog} is
consulted to determine the source and @tech{checksum} for the package.
For

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

@ -8,6 +8,7 @@
racket/runtime-path
racket/path
racket/list
net/url
pkg/util
"shelly.rkt"
"util.rkt")
@ -22,11 +23,18 @@
"raco pkg install tests"
(shelly-install "local package (tgz)" "test-pkgs/pkg-test1.tgz")
(shelly-install "local package (zip)" "test-pkgs/pkg-test1.zip")
(shelly-install "local package (file://zip)" (url->string (path->url (path->complete-path "test-pkgs/pkg-test1.zip"))))
(shelly-install "local package (plt)" "test-pkgs/pkg-test1.plt")
(shelly-install* "local package (zip, compiled)" "test-pkgs/pkg-test1b.zip" "pkg-test1b")
(shelly-install* "local package (zip, single-collection)"
"test-pkgs/pkg-test1.zip test-pkgs/pkg-test3.zip"
"pkg-test1 pkg-test3")
(shelly-install "local package (dir)" (string-append
"--copy "
(url->string (path->url (path->complete-path "test-pkgs/pkg-test1")))))
(shelly-install "local package (file://dir)" (string-append
"--copy "
(url->string (path->url (path->complete-path "test-pkgs/pkg-test1")))))
(with-fake-root
(shelly-case

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

@ -448,10 +448,15 @@
(define new-ht
(cond
[s
;; If `i' is a "file:" URL, then it makes sense to parse
;; `s' as a path and make it absolute relative to `i'.
;; If `i' is a URL, then `s' might be treated as a relative
;; URL, and we rely on the pun that a relative URL looks
;; like a relative path.
(define-values (name type) (package-source->name+type s #f))
(cond
[(and (or (eq? type 'dir) (eq? type 'file))
(not (complete-path? s)))
(not (complete-path? (package-source->path s type))))
(define full-path
(cond
[(equal? "file" (url-scheme i))
@ -460,9 +465,16 @@
(let-values ([(base name dir?) (split-path path)])
base)
path))
(path->string (simplify-path (path->complete-path s (path->complete-path dir))))]
(path->string (simplify-path (path->complete-path (package-source->path s type)
(path->complete-path dir))))]
[else
(url->string (combine-url/relative i s))]))
(define rel-url (string-join (for/list ([e (explode-path (package-source->path s type))])
(cond
[(eq? e 'same) "."]
[(eq? e 'up) ".."]
[else (path-element->string e)]))
"/"))
(url->string (combine-url/relative i rel-url))]))
(hash-set ht 'source full-path)]
[else ht])]
[else ht]))
@ -492,7 +504,9 @@
[(up) ".."]
[(same) "."]
[else (path-element->string s)]))
(explode-path (find-relative-path dir s)))
(explode-path (find-relative-path
dir
(package-source->path s type))))
"/"))]
[else ht])]
[else ht]))
@ -1243,23 +1257,26 @@
info
checksum)]
[(eq? type 'file)
(unless (file-exists? pkg)
(pkg-error "no such file\n path: ~a" pkg))
(define checksum-pth (format "~a.CHECKSUM" pkg))
(define pkg-path (if (path? pkg)
pkg
(package-source->path pkg type)))
(unless (file-exists? pkg-path)
(pkg-error "no such file\n path: ~a" pkg-path))
(define checksum-pth (format "~a.CHECKSUM" pkg-path))
(define expected-checksum
(and (file-exists? checksum-pth)
check-sums?
(file->string checksum-pth)))
(check-checksum given-checksum expected-checksum "unexpected" pkg #f)
(check-checksum given-checksum expected-checksum "unexpected" pkg-path #f)
(define actual-checksum
(with-input-from-file pkg
(with-input-from-file pkg-path
(λ ()
(sha1 (current-input-port)))))
(check-checksum expected-checksum actual-checksum "mismatched" pkg
(check-checksum expected-checksum actual-checksum "mismatched" pkg-path
(and use-cache? cached-url))
(define checksum
actual-checksum)
(define pkg-format (filename-extension pkg))
(define pkg-format (filename-extension pkg-path))
(define pkg-dir
(make-temporary-file (string-append "~a-" pkg-name)
'directory))
@ -1271,17 +1288,17 @@
(match pkg-format
[#"tgz"
(untar pkg pkg-dir)]
(untar pkg-path pkg-dir)]
[#"tar"
(untar pkg pkg-dir)]
(untar pkg-path pkg-dir)]
[#"gz" ; assuming .tar.gz
(untar pkg pkg-dir)]
(untar pkg-path pkg-dir)]
[#"zip"
(unzip pkg (make-filesystem-entry-reader #:dest pkg-dir)
(unzip pkg-path (make-filesystem-entry-reader #:dest pkg-dir)
#:preserve-timestamps? #t)]
[#"plt"
(make-directory* pkg-dir)
(unpack pkg pkg-dir
(unpack pkg-path pkg-dir
(lambda (x) (log-pkg-debug "~a" x))
(lambda () pkg-dir)
#f
@ -1314,7 +1331,7 @@
#:strip strip-mode
#:in-place? (not strip-mode)
#:in-place-clean? #t)
`(file ,(simple-form-path* pkg)))
`(file ,(simple-form-path* pkg-path)))
checksum)
(unless strip-mode
(set! staged? #t))))
@ -1324,18 +1341,21 @@
[(or (eq? type 'dir)
(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)])
(define pkg-path (if (path? pkg)
pkg
(package-source->path pkg type)))
(unless (directory-exists? pkg-path)
(pkg-error "no such directory\n path: ~a" pkg-path))
(let ([pkg-path (directory-path-no-slash pkg-path)])
(cond
[(or (eq? type 'link)
(eq? type 'static-link))
(install-info pkg-name
`(,type ,(path->string
(find-relative-path (pkg-installed-dir)
(simple-form-path pkg)
(simple-form-path pkg-path)
#:more-than-root? #t)))
pkg
pkg-path
#f
given-checksum ; if a checksum is provided, just use it
(directory->module-paths pkg pkg-name metadata-ns))]
@ -1344,7 +1364,7 @@
(if in-place?
(if strip-mode
(pkg-error "cannot strip directory in place")
pkg)
pkg-path)
(let ([pkg-dir (make-temporary-file "pkg~a" 'directory)])
(delete-directory pkg-dir)
(if strip-mode
@ -1353,13 +1373,13 @@
(generate-stripped-directory strip-mode pkg pkg-dir))
(begin
(make-parent-directory* pkg-dir)
(copy-directory/files pkg pkg-dir #:keep-modify-seconds? #t)))
(copy-directory/files pkg-path pkg-dir #:keep-modify-seconds? #t)))
pkg-dir)))
(when (or (not in-place?)
in-place-clean?)
(drop-redundant-files pkg-dir))
(install-info pkg-name
`(dir ,(simple-form-path* pkg))
`(dir ,(simple-form-path* pkg-path))
pkg-dir
(or (not in-place?) in-place-clean?)
given-checksum ; if a checksum is provided, just use it

15
racket/collects/pkg/name.rkt
View File

@ -15,7 +15,10 @@
(values (or/c #f string?) (or/c #f package-source-format?)))]
[package-source->name (->* (string?)
((or/c #f package-source-format?))
(or/c #f string?))]))
(or/c #f string?))]
[package-source->path (->* (string?)
((or/c #f 'file 'dir 'link 'static-link))
path?)]))
(define rx:package-name #rx"^[-_a-zA-Z0-9]+$")
(define rx:archive #rx"[.](plt|zip|tar|tgz|tar[.]gz)$")
@ -200,3 +203,13 @@
(define (package-source->name s [given-type #f])
(define-values (name type) (package-source->name+type s given-type))
name)
(define (package-source->path s [type #f])
((if (memq type '(dir link static-link))
path->directory-path
values)
(cond
[(regexp-match? #rx"^file://" s)
(url->path (string->url s))]
[else
(string->path s)])))