diff --git a/pkgs/racket-pkgs/racket-doc/pkg/scribblings/path.scrbl b/pkgs/racket-pkgs/racket-doc/pkg/scribblings/path.scrbl index 847f159d6e..15ca0d4dae 100644 --- a/pkgs/racket-pkgs/racket-doc/pkg/scribblings/path.scrbl +++ b/pkgs/racket-pkgs/racket-doc/pkg/scribblings/path.scrbl @@ -16,6 +16,7 @@ utilities for working with package paths and installed-package databases.} @defstruct*[pkg-info ([orig-pkg (or/c (list/c 'catalog string?) + (list/c 'catalog string? string?) (list/c 'url string?) (list/c 'link string?) (list/c 'static-link string?) @@ -24,7 +25,18 @@ databases.} [auto? boolean?]) #:prefab]{ -A structure type that is used to report installed-package information.} +A structure type that is used to report installed-package information. + +The @racket[orig-pkg] field describes the source of the package as +installed, where @racket['catalog] refers to a package that was +installed by consulting a catalog with a package name, and so on. The +two-element @racket['catalog] form records a URL for a Git or GitHub +package source when the catalog reported such a source, and the URL is +used for operations that adjust @racket['clone]-form installations. + +@history[#:changed "6.1.1.5" @elem{Added @racket['clone] and two-level + @racket['catalog] variants for + @racket[orig-pkg].}]} @defstruct*[(sc-pkg-info pkg-info) ()]{ diff --git a/pkgs/racket-pkgs/racket-doc/pkg/scribblings/pkg.scrbl b/pkgs/racket-pkgs/racket-doc/pkg/scribblings/pkg.scrbl index b18cdd0a9f..9960f9fafa 100644 --- a/pkgs/racket-pkgs/racket-doc/pkg/scribblings/pkg.scrbl +++ b/pkgs/racket-pkgs/racket-doc/pkg/scribblings/pkg.scrbl @@ -552,9 +552,12 @@ within a package, then the enclosing package is updated. @item{@DFlag{clone} @nonterm{dir} --- Same as for @command-ref{install}, except that a @nonterm{pkg-source} can be the name of an installed package. In that case, the package must - be currently installed from a Git or GitHub source, and that + be currently installed from a Git or GitHub source---possibly as + directed by a catalog---and that source is used for the clone (which replaces the existing package - installation).} + installation). If no @nonterm{pkg-source} is supplied, then + the last path element of @nonterm{dir} is used as a package name + and used as a @nonterm{pkg-source} argument.} @item{@DFlag{binary} --- Same as for @command-ref{install}.} @item{@DFlag{copy} --- Same as for @command-ref{install}.} @item{@DFlag{source} --- Same as for @command-ref{install}.} diff --git a/pkgs/racket-pkgs/racket-test/tests/pkg/test.rkt b/pkgs/racket-pkgs/racket-test/tests/pkg/test.rkt index b6e26962d0..deeaca02db 100644 --- a/pkgs/racket-pkgs/racket-test/tests/pkg/test.rkt +++ b/pkgs/racket-pkgs/racket-test/tests/pkg/test.rkt @@ -39,7 +39,8 @@ "locking" "overwrite" "config" - + "clone" + "network" "planet" "main-server" diff --git a/pkgs/racket-pkgs/racket-test/tests/pkg/tests-network.rkt b/pkgs/racket-pkgs/racket-test/tests/pkg/tests-network.rkt index b07cabc425..7749d42af6 100644 --- a/pkgs/racket-pkgs/racket-test/tests/pkg/tests-network.rkt +++ b/pkgs/racket-pkgs/racket-test/tests/pkg/tests-network.rkt @@ -56,12 +56,23 @@ (test-remote "git://github.com/mflatt/pkg-test") (test-remote "https://github.com/mflatt/pkg-test.git") (test-remote "https://bitbucket.org/mflatt/pkg-test.git") + + (define (try-git-repo label type+repo) + (define tmp-dir (make-temporary-file "~a-clone" 'directory)) + (shelly-install + label + type+repo + (shelly-wind + $ "racket -l racket/base -l pkg-test1/number -e '(number)'" =stdout> "10\n" + $ (~a "raco pkg update --clone " tmp-dir " pkg-test1") + $ "racket -l racket/base -l pkg-test1/number -e '(number)'" =stdout> "10\n" + $ (~a "raco pkg update " type+repo) + (finally + (delete-directory/files tmp-dir))))) - (shelly-install + (try-git-repo "remote/github with auto prefix and with branch" - "--type github mflatt/pkg-test?path=pkg-test1/#alt" - $ "racket -l racket/base -l pkg-test1/number -e '(number)'" =stdout> "10\n") - (shelly-install + "--type github mflatt/pkg-test?path=pkg-test1/#alt") + (try-git-repo "remote/git type" - "--type git https://bitbucket.org/mflatt/pkg-test?path=pkg-test1#alt" - $ "racket -l racket/base -l pkg-test1/number -e '(number)'" =stdout> "10\n")) + "--type git https://bitbucket.org/mflatt/pkg-test?path=pkg-test1#alt")) diff --git a/racket/collects/pkg/main.rkt b/racket/collects/pkg/main.rkt index 10e51a4819..40960e2fd0 100644 --- a/racket/collects/pkg/main.rkt +++ b/racket/collects/pkg/main.rkt @@ -41,7 +41,9 @@ ;; Selects scope from `given-scope' through `user' arguments, or infers ;; a scope from `pkgs' if non-#f, and then calls `thunk'. -(define (call-with-package-scope who given-scope scope-dir installation user pkgs pkgs-type thunk) +(define (call-with-package-scope who given-scope scope-dir installation user pkgs + pkgs-type clone-type-can-be-name? given-name + thunk) (define scope (case given-scope [(installation user) given-scope] @@ -63,15 +65,26 @@ (with-pkg-lock/read-only (define-values (pkg scope) (for/fold ([prev-pkg #f] [prev-scope #f]) ([pkg (in-list pkgs)]) - (define-values (pkg-name pkg-type) - (package-source->name+type pkg pkgs-type - #:must-infer-name? #t - #:complain - (lambda (s msg) - ((current-pkg-error) - (~a "~a\n" - " given: ~a") - msg s)))) + (define-values (pkg-name pkg-type/unused) + (cond + [given-name (values given-name #f)] + [(and (eq? pkgs-type 'clone) + clone-type-can-be-name? + (let-values ([(pkg-name pkg-type) + (package-source->name+type pkg #f)]) + (and (eq? pkg-type 'name) + pkg-name))) + => (lambda (name) + (values name #f))] + [else + (package-source->name+type pkg pkgs-type + #:must-infer-name? #t + #:complain + (lambda (s msg) + ((current-pkg-error) + (~a "~a\n" + " given: ~a") + msg s)))])) (define scope (find-pkg-installation-scope pkg-name)) (cond [(not prev-pkg) (values pkg scope)] @@ -168,7 +181,7 @@ install-copy-defns ... (call-with-package-scope 'install - scope scope-dir installation user #f a-type + scope scope-dir installation user #f a-type #f name (lambda () install-copy-checks ... (when (and name (> (length pkg-source) 1)) @@ -232,19 +245,35 @@ job-flags ... #:args pkg-source install-copy-defns ... - (let ([pkg-source (cond - [(and (null? pkg-source) - (not all) - (not clone)) - ;; In a package directory? - (define pkg (path->pkg (current-directory))) - (if pkg - (list pkg) - null)] - [else pkg-source])]) + (let ([pkg-source + ;; Implement special rules for an empty list of package sources + (cond + [(or (not (null? pkg-source)) + all) ; --all has is own treatment of an empty list + pkg-source] + [clone + ;; Use directory name as sole package name, if possible + (define-values (base name dir?) (split-path clone)) + (cond + [(and (path? name) + (let-values ([(pkg-name pkg-type) + (package-source->name+type (path-element->string name) #f)]) + (eq? pkg-type 'name))) + (list (path-element->string name))] + [else + ((pkg-error 'update) + (~a "cannot extract a valid package name from the `--clone' path\n" + " given path: ~a") + clone)])] + [else + ;; In a package directory? + (define pkg (path->pkg (current-directory))) + (if pkg + (list pkg) + null)])]) (call-with-package-scope 'update - scope scope-dir installation user pkg-source #f + scope scope-dir installation user pkg-source a-type #t name (lambda () install-copy-checks ... (define setup-collects @@ -293,7 +322,7 @@ #:args pkg (call-with-package-scope 'remove - scope scope-dir installation user pkg 'name + scope scope-dir installation user pkg 'name #f #f (lambda () (define setup-collects (with-pkg-lock @@ -370,7 +399,7 @@ #:args (from-version) (call-with-package-scope 'migrate - scope scope-dir installation user #f #f + scope scope-dir installation user #f #f #f #f (lambda () (define setup-collects (with-pkg-lock @@ -438,7 +467,7 @@ (lambda (accum . key+vals) (call-with-package-scope 'config - scope scope-dir installation user #f #f + scope scope-dir installation user #f #f #f #f (lambda () (if set (with-pkg-lock diff --git a/racket/collects/pkg/private/install.rkt b/racket/collects/pkg/private/install.rkt index 38c84d1f2e..3a134b1c9f 100644 --- a/racket/collects/pkg/private/install.rkt +++ b/racket/collects/pkg/private/install.rkt @@ -195,9 +195,12 @@ (when (and (pair? orig-pkg) (or (eq? (car orig-pkg) 'link) - (eq? (car orig-pkg) 'static-link))) + (eq? (car orig-pkg) 'static-link) + (eq? (car orig-pkg) 'clone))) (disallow-package-path-overlaps pkg-name - pkg-dir + (if (eq? (car orig-pkg) 'clone) + git-dir + pkg-dir) path-pkg-cache simultaneous-installs)) (cond @@ -906,10 +909,10 @@ ;; No checksum available => always update (not new-checksum) ;; Different source => always update - (not (equal? (pkg-info-orig-pkg info) - (desc->orig-pkg type - (pkg-desc-source pkg-name) - (pkg-desc-extra-path pkg-name))))) + (not (same-orig-pkg? (pkg-info-orig-pkg info) + (desc->orig-pkg type + (pkg-desc-source pkg-name) + (pkg-desc-extra-path pkg-name))))) ;; Update: (begin (hash-set! update-cache (pkg-desc-source pkg-name) #t) @@ -1119,6 +1122,13 @@ (pkg-error (~a "package is already a linked repository clone\n" " package: ~a") name)] + [`(catalog ,lookup-name ,url-str) + ;; Found a catalog-based installation that can be converted + ;; to a clone: + (pkg-desc url-str 'clone name + (pkg-desc-checksum pkg-name) + (pkg-desc-auto? pkg-name) + (pkg-desc-extra-path pkg-name))] [`(url ,url-str) (define-values (current-name current-type) (package-source->name+type url-str #f)) diff --git a/racket/collects/pkg/private/migrate.rkt b/racket/collects/pkg/private/migrate.rkt index c6fdef4757..d8ba6a0c52 100644 --- a/racket/collects/pkg/private/migrate.rkt +++ b/racket/collects/pkg/private/migrate.rkt @@ -38,7 +38,7 @@ #:unless (pkg-info-auto? info)) (define-values (source type dir) (match (pkg-info-orig-pkg info) - [(list 'catalog name) (values name 'name #f)] + [(list* 'catalog name _) (values name 'name #f)] [(list 'url url) (values url #f #f)] [(list 'link path) (values (path->complete-string path) 'link #f)] [(list 'static-link path) (values (path->complete-string path) 'static-link #f)] diff --git a/racket/collects/pkg/private/orig-pkg.rkt b/racket/collects/pkg/private/orig-pkg.rkt index 6d10431ae9..1c62ecc29c 100644 --- a/racket/collects/pkg/private/orig-pkg.rkt +++ b/racket/collects/pkg/private/orig-pkg.rkt @@ -8,11 +8,14 @@ ;; An "orig-pkg" is the way that that a pacage source is recorded ;; in the installed-package database. -(provide desc->orig-pkg) +(provide desc->orig-pkg + same-orig-pkg?) -(define (desc->orig-pkg type src extra-path) +(define (desc->orig-pkg type src extra-path #:repo-url [repo-url #f]) (case type - [(name) `(catalog ,src)] + [(name) (if repo-url + `(catalog ,src ,repo-url) + `(catalog ,src))] [(link static-link) `(,type ,(path->string (find-relative-path (pkg-installed-dir) @@ -31,3 +34,10 @@ ,src)] [(file dir) `(,type ,(simple-form-path* src))] [else `(url ,src)])) + +;; Ignore URL that is potentially recorded for a 'catalog kind: +(define (same-orig-pkg? a b) + (if (and (eq? 'catalog (car a)) + (eq? 'catalog (car b))) + (equal? (cadr a) (cadr b)) + (equal? a b))) diff --git a/racket/collects/pkg/private/stage.rkt b/racket/collects/pkg/private/stage.rkt index 3244b8c856..1341294806 100644 --- a/racket/collects/pkg/private/stage.rkt +++ b/racket/collects/pkg/private/stage.rkt @@ -39,7 +39,7 @@ (define (remote-package-checksum pkg download-printf pkg-name #:type [type #f]) (match pkg - [`(catalog ,pkg-name) + [`(catalog ,pkg-name . ,_) (hash-ref (package-catalog-lookup pkg-name #f download-printf) 'checksum)] [`(url ,pkg-url-str) (package-url->checksum pkg-url-str @@ -104,11 +104,20 @@ #:force-strip? force-strip?)] [(eq? type 'clone) (define pkg-url (string->url pkg)) - (define pkg-no-query (url->string - (struct-copy url pkg-url - [query null]))) (define-values (host port repo branch path) (split-git-or-hub-url pkg-url)) + (define pkg-no-query + (url->string + (if (equal? "github" (url-scheme pkg-url)) + ;; Convert "github://" to a real URL: + (url "https" #f host port #t + (map (lambda (s) (path/param s null)) (string-split repo "/")) + null + #f) + ;; Drop any query or fragment in the URL: + (struct-copy url pkg-url + [query null] + [fragment #f])))) (define clone-dir (or given-at-dir (current-directory))) @@ -579,11 +588,15 @@ (when check-sums? (check-checksum given-checksum checksum "unexpected" pkg #f) (check-checksum checksum (install-info-checksum info) "incorrect" pkg #f)) + (define repo-url (let-values ([(name type) (package-source->name+type source #f)]) + (and (or (eq? type 'git) + (eq? type 'github)) + source))) (update-install-info-orig-pkg (update-install-info-checksum info checksum) - (desc->orig-pkg 'name pkg #f))] + (desc->orig-pkg 'name pkg #f #:repo-url repo-url))] [else (pkg-error "cannot infer package source type\n source: ~a" pkg)]))