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

pkg/lib: more fixes to handling of relative package sources in catalogs

Browse Source 
Relative paths in a catalog should be treated as relative URLs, not
relative paths.
This commit is contained in:
Matthew Flatt 2014-06-02 14:49:51 +01:00
parent e27c51698b
commit 2360a9f69a
3 changed files with 31 additions and 42 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
pkgs/racket-pkgs/racket-doc/pkg/scribblings/catalog-protocol.scrbl
View File

@ -46,7 +46,7 @@ information about packages:
@item{@racket['source] (required) --- a @tech{package source}
string, typically a remote URL. If this source is a
relative path, then it is treated as relative to the
relative URL, then it is treated as relative to the
catalog.
@history[#:changed "6.0.1.7" @elem{Added relative-path support

19
pkgs/racket-pkgs/racket-test/tests/pkg/tests-catalogs.rkt
View File

@ -107,16 +107,17 @@
$ (~a "raco pkg catalog-archive " archive-d " http://localhost:9990")
$ (~a "test -f " archive-d "/pkgs/pkg-test1.zip")
(define rx:pkg-test1 (regexp
(~a (regexp-quote (~a "Source: " archive-d "/pkgs/pkg-test1.zip"))
".*"
(regexp-quote (~a "Checksum: " (file->string
(build-path archive-d
"pkgs"
"pkg-test1.zip.CHECKSUM")))))))
(define (rx:pkg-test1 as-url?)
(regexp
(~a (regexp-quote (~a "Source: " (if as-url? "file://" "") archive-d "/pkgs/pkg-test1.zip"))
".*"
(regexp-quote (~a "Checksum: " (file->string
(build-path archive-d
"pkgs"
"pkg-test1.zip.CHECKSUM")))))))
$ (~a "raco pkg catalog-show --catalog file://" archive-d "/catalog pkg-test1")
=stdout> rx:pkg-test1
=stdout> (rx:pkg-test1 #f)
(delete-directory/files archive-d)
@ -127,7 +128,7 @@
" " archive-d)
=stdout> #rx"== Archiving pkg-test1 =="
$ (~a "raco pkg catalog-show --catalog file://" archive-d "/catalog pkg-test1")
=stdout> rx:pkg-test1
=stdout> (rx:pkg-test1 #t)
$ (~a "grep archive " archive-d "/catalog/pkg/pkg-test1") ; relative path => no "archive"
=exit> 1
$ (~a "test -f " archive-d "/pkgs/pkg-test2.zip")

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

@ -448,34 +448,27 @@
(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.
;; If `s' is a relative URL, then we rely on the pun
;; that it will parse as 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? (package-source->path s type))))
(define full-path
(not (regexp-match? #rx"^file://" s))
(relative-path? s))
(define i-for-combine
(cond
[(equal? "file" (url-scheme i))
(define path (url->path i))
(define dir (if (db-path? path)
(let-values ([(base name dir?) (split-path path)])
base)
path))
(path->string (simplify-path (path->complete-path (package-source->path s type)
(path->complete-path dir))))]
[else
(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)]
(define i-path (url->path i))
(if (db-path? i-path)
i
;; Make sure we interpret `i' as a directory when
;; adding a relative path:
(path->url (path->directory-path (url->path i))))]
[else i]))
(define full-url
(url->string
(combine-url/relative i-for-combine s)))
(hash-set ht 'source full-url)]
[else ht])]
[else ht]))
(let ([v (hash-ref new-ht 'versions #f)])
@ -499,15 +492,10 @@
[(or (eq? type 'dir) (eq? type 'file))
(hash-set ht
'source
(string-join (map (lambda (s)
(case s
[(up) ".."]
[(same) "."]
[else (path-element->string s)]))
(explode-path (find-relative-path
dir
(package-source->path s type))))
"/"))]
(relative-path->relative-url-string
(find-relative-path
dir
(package-source->path s type))))]
[else ht])]
[else ht]))
(let ([v (hash-ref new-ht 'versions #f)])