From 47f2742575476c2b334ef79e97fff1397683e517 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Sun, 7 Jul 2013 21:22:58 -0600 Subject: [PATCH] pkg/path: add `path->pkg+subpath+collect' I was going to use this extension to implement `path->module-path', but it turns out that `path->module-path' already exists and in a form that works with packages. Still, this extension might be useful in the future. --- .../racket-doc/pkg/scribblings/path.scrbl | 8 ++++ .../racket-test/tests/pkg/path.rkt | 24 ++++++++++ racket/lib/collects/pkg/path.rkt | 44 ++++++++++++------- 3 files changed, 61 insertions(+), 15 deletions(-) create mode 100644 pkgs/racket-pkgs/racket-test/tests/pkg/path.rkt diff --git a/pkgs/racket-pkgs/racket-doc/pkg/scribblings/path.scrbl b/pkgs/racket-pkgs/racket-doc/pkg/scribblings/path.scrbl index 02ce20ce08..c8e0869277 100644 --- a/pkgs/racket-pkgs/racket-doc/pkg/scribblings/path.scrbl +++ b/pkgs/racket-pkgs/racket-doc/pkg/scribblings/path.scrbl @@ -44,6 +44,14 @@ Like @racket[path->pkg], but returns a second value that represents the remainder of @racket[path] within the package's directory.} +@defproc[(path->pkg+subpath+collect [path path-string?]) + (values (or/c string? #f) (or/c path? 'same #f) (or/c string? #f))]{ + +Like @racket[path->pkg+subpath], but returns a third value for a +collection name if the package is a single-collection package, +@racket[#f] otherwise.} + + @defproc[(get-pkgs-dir [scope (or/c 'installation 'user 'shared (and/c path? complete-path?))] [user-version string? (version)]) diff --git a/pkgs/racket-pkgs/racket-test/tests/pkg/path.rkt b/pkgs/racket-pkgs/racket-test/tests/pkg/path.rkt new file mode 100644 index 0000000000..aed8052477 --- /dev/null +++ b/pkgs/racket-pkgs/racket-test/tests/pkg/path.rkt @@ -0,0 +1,24 @@ +#lang racket/base +(require pkg/path) + +(module+ test + (require rackunit) + + (check-equal? (path->pkg (collection-file-path "path.rkt" "tests" "pkg")) + "racket-test") + (check-equal? (call-with-values + (lambda () (path->pkg+subpath (collection-file-path "path.rkt" "tests" "pkg"))) + list) + (list "racket-test" (build-path "tests" "pkg" "path.rkt"))) + (check-equal? (call-with-values + (lambda () (path->pkg+subpath+collect (collection-file-path "path.rkt" "tests" "pkg"))) + list) + (list "racket-test" (build-path "tests" "pkg" "path.rkt") #f)) + + (check-equal? (path->pkg (find-system-path 'temp-dir)) + #f) + + (check-equal? (call-with-values + (lambda () (path->pkg+subpath+collect (collection-file-path "serve-catalog.rkt" "distro-build"))) + list) + (list "distro-build" (build-path "serve-catalog.rkt") "distro-build"))) diff --git a/racket/lib/collects/pkg/path.rkt b/racket/lib/collects/pkg/path.rkt index 56df72ed04..2d7f16aa3b 100644 --- a/racket/lib/collects/pkg/path.rkt +++ b/racket/lib/collects/pkg/path.rkt @@ -6,8 +6,9 @@ get-pkgs-dir read-pkgs-db read-pkg-file-hash + path->pkg path->pkg+subpath - path->pkg) + path->pkg+subpath+collect) (struct pkg-info (orig-pkg checksum auto?) #:prefab) (struct sc-pkg-info pkg-info (collect) #:prefab) ; a pkg with a single collection @@ -66,7 +67,7 @@ [orig-pkg `(catalog ,(cadr (pkg-info-orig-pkg v)))]) v))))) -(define (path->pkg+subpath* who given-p cache) +(define (path->pkg+subpath+collect* who given-p cache want-collect?) (unless (path-string? given-p) (raise-argument-error who "path-string?" given-p)) (unless (or (not cache) @@ -85,9 +86,10 @@ (define p (explode given-p)) (define (build-path* l) (if (null? l) 'same (apply build-path l))) - (for/fold ([pkg #f] [subpath #f]) ([scope (in-list (list* 'user 'shared - (get-pkgs-search-dirs)))] - #:when (not pkg)) + (for/fold ([pkg #f] [subpath #f] [collect #f]) + ([scope (in-list (list* 'user 'shared + (get-pkgs-search-dirs)))] + #:when (not pkg)) (define d (or (and cache (hash-ref cache `(dir ,scope) #f)) (let ([d (explode (get-pkgs-dir scope))]) @@ -105,12 +107,17 @@ ;; We assume that no one else writes there, so the ;; next path element is the package name. (define len (length d)) - (values (path-element->string (list-ref p len)) - (build-path* (list-tail p (add1 len))))] + (define pkg-name (path-element->string (list-ref p len))) + (values pkg-name + (build-path* (list-tail p (add1 len))) + (and want-collect? + (let ([i (hash-ref (read-pkg-db/cached) pkg-name #f)]) + (and i (sc-pkg-info? i) (sc-pkg-info-collect i)))))] [else ;; Maybe it's a linked package - (for/fold ([pkg #f] [subpath #f]) ([(k v) (in-hash (read-pkg-db/cached))] - #:when (not pkg)) + (for/fold ([pkg #f] [subpath #f] [collect #f]) + ([(k v) (in-hash (read-pkg-db/cached))] + #:when (not pkg)) (define orig (pkg-info-orig-pkg v)) (if (and (pair? orig) (or (eq? 'link (car orig)) @@ -118,14 +125,21 @@ (let ([orig-pkg-dir (cadr orig)]) (define e (explode orig-pkg-dir)) (if (sub-path? <= p e) - (values k (build-path* (list-tail p (length e)))) - (values #f #f))) - (values #f #f)))]))) + (values k + (build-path* (list-tail p (length e))) + (and (sc-pkg-info? v) (sc-pkg-info-collect v))) + (values #f #f #f))) + (values #f #f #f)))]))) + +(define (path->pkg+subpath+collect given-p #:cache [cache #f]) + (path->pkg+subpath+collect* 'path->pkg+subpath+collect given-p cache #t)) (define (path->pkg+subpath given-p #:cache [cache #f]) - (path->pkg+subpath* 'path->pkg+subpath given-p cache)) + (define-values (pkg rest rest2) + (path->pkg+subpath+collect* 'path->pkg+subpath given-p cache #f)) + (values pkg rest)) (define (path->pkg given-p #:cache [cache #f]) - (define-values (pkg rest) - (path->pkg+subpath* path->pkg given-p cache)) + (define-values (pkg rest rest2) + (path->pkg+subpath+collect* path->pkg given-p cache #f)) pkg)