raco pkg {install,remove}: promotion from & demotion to auto-installed
When you `raco pkg install' a package that is already present as an auto-installed package, the installation is promoted to an explicitly installed package. When you `raco pkg remove --demote' a package, then it is changed from an explicitly installed package to an auto-installed package. Combine `--demote' with `--auto' to remove a package only if there are no dependencies, leaving it auto-installed otherwise. The defaults (promote in the case of `install', not demote in the case of `remove') are different because it seems more likely that you really mean to remove a package when using `pkg remove', while it seems likely that you just want to start using a package that happened to be auto-installed already for `pkg install'. Also, make the package scope inferred for `raco pkg' commands that take a list of package names, and fix up lock handling and error reporting.
This commit is contained in:
Matthew Flatt
parent
4bbf4c7264
commit
5e0b87a0cd
|
|
@ -1,4 +1,4 @@
|
|||
#lang info
|
||||
|
||||
(define scribblings
|
||||
'(("scribblings/pkg.scrbl" (multi-page) (tool 100))))
|
||||
'(("scribblings/pkg.scrbl" (multi-page) (racket-core -20))))
|
||||
|
|
|
|||
|
|
@ -13,3 +13,5 @@
|
|||
(define (command/toc s)
|
||||
@(toc-target-element #f @command[s] `(raco-pkg-cmd ,s)))
|
||||
|
||||
(define pkgname onscreen)
|
||||
(define reponame litchar)
|
||||
|
|
|
|||
|
|
@ -215,6 +215,7 @@ The package lock must be held; see @racket[with-pkg-lock].}
|
|||
|
||||
|
||||
@defproc[(pkg-remove [names (listof string?)]
|
||||
[#:demote? demote? boolean? #f]
|
||||
[#:auto? auto? boolean? #f]
|
||||
[#:force? force? boolean? #f]
|
||||
[#:quiet? boolean? quiet? #f])
|
||||
|
|
@ -224,8 +225,8 @@ The package lock must be held; see @racket[with-pkg-lock].}
|
|||
(non-empty-listof path-string?))))]{
|
||||
|
||||
Implements @racket[pkg-remove-command]. The result is the same as for
|
||||
@racket[pkg-install], indicating collects that should be setup
|
||||
via @exec{raco setup}.
|
||||
@racket[pkg-install], indicating collects that should be setup via
|
||||
@exec{raco setup}.
|
||||
|
||||
The package lock must be held; see @racket[with-pkg-lock].}
|
||||
|
||||
|
|
@ -256,7 +257,9 @@ The package lock must be held to allow reads; see
|
|||
(non-empty-listof path-string?))))]{
|
||||
|
||||
Implements @racket[pkg-migrate-command]. The result is the same as for
|
||||
@racket[pkg-install].}
|
||||
@racket[pkg-install].
|
||||
|
||||
The package lock must be held; see @racket[with-pkg-lock].}
|
||||
|
||||
|
||||
@defproc[(pkg-catalog-show [names (listof string?)]
|
||||
|
|
@ -265,7 +268,7 @@ Implements @racket[pkg-migrate-command]. The result is the same as for
|
|||
[#:modules? modules? boolean? #f])
|
||||
void?]{
|
||||
|
||||
Implements @racket[catalog-show-command]. If @racket[all?] is true,
|
||||
Implements @racket[pkg-catalog-show-command]. If @racket[all?] is true,
|
||||
then @racket[names] should be empty.}
|
||||
|
||||
|
||||
|
|
|
|||
|
|
@ -8,9 +8,6 @@
|
|||
|
||||
@(define @|Planet1| @|PLaneT|)
|
||||
|
||||
@(define pkgname onscreen)
|
||||
@(define reponame litchar)
|
||||
|
||||
@(define package-name-chars
|
||||
@list{@litchar{a} through @litchar{z},
|
||||
@litchar{A} through @litchar{Z},
|
||||
|
|
@ -26,7 +23,7 @@
|
|||
|
||||
@; ----------------------------------------
|
||||
|
||||
@title{Package Management in Racket (Beta)}
|
||||
@title{Package Management in Racket}
|
||||
@author[@author+email["Jay McCarthy" "jay@racket-lang.org"]]
|
||||
|
||||
The Racket package manager lets you install new libraries and
|
||||
|
|
@ -258,24 +255,28 @@ directory in its search path for installed packages).
|
|||
|
||||
@; ----------------------------------------
|
||||
|
||||
@section{Managing Packages}
|
||||
@section[#:tag "Managing Packages"]{Managing Packages}
|
||||
|
||||
The Racket package manager has two main user interfaces: a command line @exec{raco}
|
||||
sub-command and a @racketmodname[pkg] library to run the same commands.
|
||||
command and a @racketmodname[pkg] library to run the same commands.
|
||||
They have the exact same capabilities, as
|
||||
the command line interface invokes the library functions and
|
||||
reprovides all their options.
|
||||
|
||||
@subsection[#:tag "cmdline"]{Command Line}
|
||||
|
||||
The @as-index{@exec{raco pkg}} sub-command provides the following
|
||||
sub-sub-commands:
|
||||
The @as-index{@exec{raco pkg}} command provides the following
|
||||
sub-commands:
|
||||
|
||||
@itemlist[
|
||||
|
||||
@item{@command/toc{install} @nonterm{option} ... @nonterm{pkg-source} ...
|
||||
--- Installs the given @tech{package sources} (eliminating exact-duplicate @nonterm{pkg-source}s) with the given
|
||||
@nonterm{option}s:
|
||||
--- Installs the given @tech{package sources} (eliminating exact-duplicate @nonterm{pkg-source}s).
|
||||
If a given @nonterm{pkg-source} is ``auto-installed'' (to satisfy some other package's
|
||||
dependency), then it is promoted to explicitly installed.
|
||||
|
||||
The @exec{install} sub-command accepts
|
||||
the following @nonterm{option}s:
|
||||
|
||||
@itemlist[
|
||||
|
||||
|
|
@ -323,7 +324,8 @@ sub-sub-commands:
|
|||
@item{@DFlag{source} --- Strips built elements of a package before installing, and implies @DFlag{copy}.}
|
||||
|
||||
@item{@DFlag{skip-installed} --- Ignore any @nonterm{pkg-source}
|
||||
whose name corresponds to an already-installed package.}
|
||||
whose name corresponds to an already-installed package, except for promoting auto-installed
|
||||
packages to explicitly installed.}
|
||||
|
||||
@item{@DFlag{scope} @nonterm{scope} --- Selects the @tech{package scope} for installation, where @nonterm{scope} is one of
|
||||
@itemlist[
|
||||
|
|
@ -356,6 +358,9 @@ installed (e.g. it conflicts with another installed package), then
|
|||
this command fails without installing any of the @nonterm{pkg}s
|
||||
(or their dependencies).
|
||||
|
||||
If a @tech{package scope} is not specified, the scope is inferred from
|
||||
the given @nonterm{pkg}s.
|
||||
|
||||
The @exec{update} sub-command accepts
|
||||
the following @nonterm{option}s:
|
||||
|
||||
|
|
@ -379,13 +384,20 @@ this command fails without installing any of the @nonterm{pkg}s
|
|||
of another package that is not listed, this command fails without
|
||||
removing any of the @nonterm{pkg}s.
|
||||
|
||||
If a @tech{package scope} is not specified, the scope is inferred from
|
||||
the given @nonterm{pkg}s.
|
||||
|
||||
The @exec{remove} sub-command accepts
|
||||
the following @nonterm{option}s:
|
||||
|
||||
@itemlist[
|
||||
@item{@DFlag{demote} --- ``Remove'' explicitly installed packages by demoting them to auto-installed
|
||||
(leaving auto-installed packages as such). Combined with @DFlag{auto}, removes
|
||||
packages for which there are no dependencies.}
|
||||
@item{@DFlag{force} --- Ignore dependencies when removing packages.}
|
||||
@item{@DFlag{auto} --- Remove packages that were installed by the @exec{search-auto} or @exec{search-ask}
|
||||
dependency behavior and are no longer required.}
|
||||
@item{@DFlag{auto} --- Remove auto-installed packages (i.e., installed by the @exec{search-auto} or @exec{search-ask}
|
||||
dependency behavior, or demoted via @DFlag{demote}) that are no longer required by any
|
||||
explicitly installed package.}
|
||||
@item{@DFlag{scope} @nonterm{scope} --- Selects a @tech{package scope}, the same as for @command-ref{install}.}
|
||||
@item{@Flag{i} or @DFlag{installation} --- Shorthand for @exec{--scope installation}.}
|
||||
@item{@Flag{u} or @DFlag{user} --- Shorthand for @exec{--scope user}.}
|
||||
|
|
@ -498,8 +510,9 @@ View and modify configuration of the package manager itself, with the following
|
|||
@item{@exec{default-scope} --- Either @exec{installation} or @exec{user}.
|
||||
The value of this key at @exec{user} scope (possibly defaulting from
|
||||
@exec{installation} scope) is
|
||||
the default @tech{package scope} for all @exec{raco pkg} commands
|
||||
(even @command{config}, which is consistent but potentially confusing).}
|
||||
the default @tech{package scope} for @exec{raco pkg} commands for which
|
||||
a scope is not inferred from a given set of package names
|
||||
(even for @command{config}, which is consistent but potentially confusing).}
|
||||
@item{@exec{name} --- A string for the installation's name, which is used by @exec{user}
|
||||
@tech{package scope} and defaults to the Racket version.}
|
||||
]
|
||||
|
|
|
|||
|
|
@ -13,3 +13,4 @@
|
|||
documentation, including documentation for installed packages.}}
|
||||
|
||||
@(make-start-page #f)
|
||||
|
||||
|
|
|
|||
|
|
@ -43,6 +43,7 @@
|
|||
"conflicts" "checksums"
|
||||
"deps" "update"
|
||||
"remove"
|
||||
"promote"
|
||||
"locking"
|
||||
"overwrite"
|
||||
"config"
|
||||
|
|
|
|||
50
pkgs/racket-pkgs/racket-test/tests/pkg/tests-promote.rkt
Normal file
50
pkgs/racket-pkgs/racket-test/tests/pkg/tests-promote.rkt
Normal file
|
|
@ -0,0 +1,50 @@
|
|||
#lang racket/base
|
||||
(require rackunit
|
||||
racket/system
|
||||
pkg/util
|
||||
"shelly.rkt"
|
||||
"util.rkt")
|
||||
|
||||
(pkg-tests
|
||||
(shelly-begin
|
||||
(initialize-catalogs)
|
||||
|
||||
(with-fake-root
|
||||
(shelly-case
|
||||
"promote"
|
||||
$ "raco pkg config --set catalogs http://localhost:9990"
|
||||
$ "raco pkg install --deps search-auto test-pkgs/pkg-test2.zip" =exit> 0
|
||||
$ "raco pkg show -u -a" =stdout> #rx"Package\\[\\*=auto\\] +Checksum +Source\npkg-test1\\* +[a-f0-9]+ +\\(catalog pkg-test1\\)\npkg-test2 +[a-f0-9]+ +\\(file .+tests/pkg/test-pkgs/pkg-test2.zip\\)\n"
|
||||
$ "raco pkg install test-pkgs/pkg-test2.zip" =exit> 1 =stderr> #rx"already installed"
|
||||
$ "raco pkg install test-pkgs/pkg-test1.zip" =exit> 1 =stderr> #rx"already installed from a different source"
|
||||
$ "raco pkg install pkg-test1" ; promote
|
||||
$ "raco pkg show -u -a" =stdout> #rx"Package\\[\\*=auto\\] +Checksum +Source\npkg-test1 +[a-f0-9]+ +\\(catalog pkg-test1\\)\npkg-test2 +[a-f0-9]+ +\\(file .+tests/pkg/test-pkgs/pkg-test2.zip\\)\n"
|
||||
$ "raco pkg install pkg-test1" =exit> 1 =stderr> #rx"already installed" ; redundant promote fails
|
||||
$ "racket -e '(require pkg-test1)'" =exit> 0
|
||||
$ "racket -e '(require pkg-test2)'" =exit> 0
|
||||
$ "raco pkg remove --auto pkg-test1" =exit> 1 =stderr> #rx"cannot remove packages that are dependencies of other packages"
|
||||
$ "raco pkg remove --auto pkg-test2"
|
||||
$ "raco pkg show -u -a" =stdout> #rx"Package\\[\\*=auto\\] +Checksum +Source\npkg-test1 +[a-f0-9]+ +\\(catalog pkg-test1\\)"
|
||||
$ "raco pkg remove --auto pkg-test1"
|
||||
$ "raco pkg show -u -a" =stdout> " [none]\n")
|
||||
(shelly-case
|
||||
"demote"
|
||||
$ "raco pkg config --set catalogs http://localhost:9990"
|
||||
$ "raco pkg install --deps search-auto test-pkgs/pkg-test2.zip" =exit> 0
|
||||
$ "raco pkg show -u -a" =stdout> #rx"Package\\[\\*=auto\\] +Checksum +Source\npkg-test1\\* +[a-f0-9]+ +\\(catalog pkg-test1\\)\npkg-test2 +[a-f0-9]+ +\\(file .+tests/pkg/test-pkgs/pkg-test2.zip\\)\n"
|
||||
$ "raco pkg remove --demote pkg-test2"
|
||||
$ "raco pkg show -u -a" =stdout> #rx"Package\\[\\*=auto\\] +Checksum +Source\npkg-test1\\* +[a-f0-9]+ +\\(catalog pkg-test1\\)\npkg-test2\\* +[a-f0-9]+ +\\(file .+tests/pkg/test-pkgs/pkg-test2.zip\\)\n"
|
||||
$ "racket -e '(require pkg-test1)'" =exit> 0
|
||||
$ "racket -e '(require pkg-test2)'" =exit> 0
|
||||
$ "raco pkg remove --auto"
|
||||
$ "raco pkg show -u -a" =stdout> " [none]\n"))
|
||||
(with-fake-root
|
||||
(shelly-case
|
||||
"demote+auto"
|
||||
$ "raco pkg config --set catalogs http://localhost:9990"
|
||||
$ "raco pkg install --deps search-auto test-pkgs/pkg-test2.zip" =exit> 0
|
||||
$ "raco pkg show -u -a" =stdout> #rx"Package\\[\\*=auto\\] +Checksum +Source\npkg-test1\\* +[a-f0-9]+ +\\(catalog pkg-test1\\)\npkg-test2 +[a-f0-9]+ +\\(file .+tests/pkg/test-pkgs/pkg-test2.zip\\)\n"
|
||||
$ "raco pkg remove --demote --auto pkg-test1" =exit> 0 ; should have no effect
|
||||
$ "raco pkg show -u -a" =stdout> #rx"Package\\[\\*=auto\\] +Checksum +Source\npkg-test1\\* +[a-f0-9]+ +\\(catalog pkg-test1\\)\npkg-test2 +[a-f0-9]+ +\\(file .+tests/pkg/test-pkgs/pkg-test2.zip\\)\n"
|
||||
$ "raco pkg remove --demote --auto pkg-test2"
|
||||
$ "raco pkg show -u -a" =stdout> " [none]\n"))))
|
||||
|
|
@ -78,5 +78,5 @@
|
|||
"different scope error"
|
||||
$ "raco pkg install test-pkgs/pkg-test1.zip" =exit> 0
|
||||
$ "raco pkg remove --installation pkg-test1" =exit> 1
|
||||
=stderr> #rx"package installed in a different scope: user"
|
||||
=stderr> #rx"package installed in a different scope"
|
||||
$ "raco pkg remove pkg-test1")))))
|
||||
|
|
|
|||
|
|
@ -33,7 +33,10 @@
|
|||
(prefix-in db: "db.rkt"))
|
||||
|
||||
(define current-pkg-scope
|
||||
(make-parameter 'user))
|
||||
(make-parameter 'user (lambda (p)
|
||||
(if (path? p)
|
||||
(simple-form-path p)
|
||||
p))))
|
||||
(define current-pkg-scope-version
|
||||
(make-parameter (get-installation-name)))
|
||||
(define current-pkg-error
|
||||
|
|
@ -264,10 +267,24 @@
|
|||
#t))
|
||||
|
||||
(define pkg-lock-held (make-parameter #f))
|
||||
(define pkg-lock-scope (make-parameter #f))
|
||||
|
||||
;; Call `t' with lock held for the current scope. The intent is that
|
||||
;; `t' reads and writes package information in the curent scope. It
|
||||
;; may also *read* package information for wider package scopes
|
||||
;; without a further lock --- which is questionable, but modification
|
||||
;; of a shared scope while others are running can create trouble,
|
||||
;; anyway.
|
||||
(define (with-pkg-lock* read-only? t)
|
||||
(define mode (if read-only? 'shared 'exclusive))
|
||||
(define held-mode (pkg-lock-held))
|
||||
(define now-scope (current-pkg-scope))
|
||||
(define held-scope (pkg-lock-scope))
|
||||
(when (and held-scope
|
||||
(not (eq? held-scope now-scope)))
|
||||
(pkg-error "lock mismatch\n held scope: ~a\n requested scope: ~a"
|
||||
held-scope
|
||||
now-scope))
|
||||
(if (or (eq? mode held-mode)
|
||||
(eq? 'exclusive held-mode))
|
||||
(t)
|
||||
|
|
@ -280,7 +297,8 @@
|
|||
#f
|
||||
mode
|
||||
(lambda ()
|
||||
(parameterize ([pkg-lock-held mode])
|
||||
(parameterize ([pkg-lock-held mode]
|
||||
[pkg-lock-scope now-scope])
|
||||
(t)))
|
||||
(λ () (pkg-error (~a "could not acquire package lock\n"
|
||||
" lock file: ~a")
|
||||
|
|
@ -387,12 +405,16 @@
|
|||
#:download-printf download-printf)]))
|
||||
|
||||
(define (write-file-hash! file new-db)
|
||||
(unless (eq? (pkg-lock-held) 'exclusive)
|
||||
(pkg-error "attempt to write package database without write lock"))
|
||||
(make-parent-directory* file)
|
||||
(call-with-atomic-output-file
|
||||
file
|
||||
(λ (o tmp-path) (write new-db o) (newline o))))
|
||||
|
||||
(define (read-pkg-db)
|
||||
(unless (pkg-lock-held)
|
||||
(pkg-error "attempt to read package database without lock"))
|
||||
(if (current-no-pkg-db)
|
||||
#hash()
|
||||
(read-pkgs-db (current-pkg-scope) (current-pkg-scope-version))))
|
||||
|
|
@ -401,7 +423,7 @@
|
|||
(define (merge-pkg-dbs [scope (current-pkg-scope)])
|
||||
(define (merge-next-pkg-dbs scope)
|
||||
(parameterize ([current-pkg-scope scope])
|
||||
(with-pkg-lock/read-only (merge-pkg-dbs scope))))
|
||||
(merge-pkg-dbs scope)))
|
||||
(if (path? scope)
|
||||
(read-pkg-db)
|
||||
(case scope
|
||||
|
|
@ -414,6 +436,29 @@
|
|||
(for/fold ([ht (merge-next-pkg-dbs 'installation)]) ([(k v) (in-hash db)])
|
||||
(hash-set ht k v))])))
|
||||
|
||||
;; Finds the scope, in which `pkg-name' is installed; returns 'dir,
|
||||
;; 'installation, a path, or #f (where #f means "not installed"). If
|
||||
;; `next?' is true, search only scopes wider than the current one.
|
||||
(define (find-pkg-installation-scope pkg-name #:next? [next? #f])
|
||||
(case (current-pkg-scope)
|
||||
[(user)
|
||||
(or (and (not next?)
|
||||
(hash-ref (read-pkg-db) pkg-name #f)
|
||||
'user)
|
||||
(parameterize ([current-pkg-scope 'installation])
|
||||
(find-pkg-installation-scope pkg-name)))]
|
||||
[(installation)
|
||||
(or (and (not next?)
|
||||
(hash-ref (read-pkg-db) pkg-name #f)
|
||||
'installation)
|
||||
(for/or ([dir (in-list (get-pkgs-search-dirs))])
|
||||
(and (hash-ref (read-pkgs-db dir) pkg-name #f)
|
||||
dir)))]
|
||||
[else
|
||||
(and (not next?)
|
||||
(and (hash-ref (read-pkgs-db (current-pkg-scope)) pkg-name #f)
|
||||
(current-pkg-scope)))]))
|
||||
|
||||
(define (package-info pkg-name [fail? #t] #:db [given-db #f])
|
||||
(define db (or given-db (read-pkg-db)))
|
||||
(define pi (hash-ref db pkg-name #f))
|
||||
|
|
@ -435,40 +480,33 @@
|
|||
;; prints an error for packages that are not installed
|
||||
;; pkg-name db -> void
|
||||
(define (pkg-not-installed pkg-name db)
|
||||
(define installation-db
|
||||
(parameterize ([current-pkg-scope 'installation])
|
||||
(read-pkg-db)))
|
||||
(define user-db
|
||||
(parameterize ([current-pkg-scope 'user])
|
||||
(read-pkg-db)))
|
||||
|
||||
;; see if the package is installed in any scope
|
||||
(define-values (in-install? in-user?)
|
||||
(values
|
||||
(and (hash-ref installation-db pkg-name #f)
|
||||
"--installation")
|
||||
(and (hash-ref user-db pkg-name #f)
|
||||
"--user")))
|
||||
;; This may read narrower package scopes without holding the
|
||||
;; lock, but maybe that's ok for mere error reporting:
|
||||
(define s (parameterize ([current-pkg-scope 'user])
|
||||
(find-pkg-installation-scope pkg-name)))
|
||||
|
||||
(define not-installed-msg
|
||||
(cond [(or in-user? in-install?)
|
||||
=>
|
||||
(λ (scope-str)
|
||||
(~a "could not remove package\n"
|
||||
" package installed in a different scope: "
|
||||
(substring scope-str 2) "\n"
|
||||
" consider using the " scope-str " flag\n"))]
|
||||
[else (~a "could not remove package\n"
|
||||
" package not currently installed\n")]))
|
||||
|
||||
(pkg-error (~a not-installed-msg
|
||||
" current scope: ~a\n"
|
||||
" package: ~a\n"
|
||||
" currently installed:~a")
|
||||
(current-scope->string)
|
||||
pkg-name
|
||||
(format-list (hash-keys db))))
|
||||
(cond [s "package installed in a different scope"]
|
||||
[else "package not currently installed"]))
|
||||
|
||||
(apply pkg-error (~a not-installed-msg
|
||||
"\n package: ~a"
|
||||
"\n current scope: ~a"
|
||||
(if s
|
||||
"\n installed in scope: ~a"
|
||||
"")
|
||||
;; Probably too much information:
|
||||
#;
|
||||
"\n packages in current scope:~a")
|
||||
(append
|
||||
(list
|
||||
pkg-name
|
||||
(current-scope->string))
|
||||
(if s (list s) null)
|
||||
#;
|
||||
(list
|
||||
(format-list (hash-keys db))))))
|
||||
|
||||
(define (update-pkg-db! pkg-name info)
|
||||
(write-file-hash!
|
||||
(pkg-db-file)
|
||||
|
|
@ -564,10 +602,18 @@
|
|||
d)))))))
|
||||
|
||||
(define (pkg-directory pkg-name)
|
||||
;; Warning: takes locks individually.
|
||||
(pkg-directory** pkg-name
|
||||
(lambda (f)
|
||||
(with-pkg-lock/read-only
|
||||
(f)))))
|
||||
|
||||
(define (pkg-directory** pkg-name [call-with-pkg-lock (lambda (f) (f))])
|
||||
(for/or ([scope (in-list (get-scope-list))])
|
||||
(parameterize ([current-pkg-scope scope])
|
||||
(with-pkg-lock/read-only
|
||||
(pkg-directory* pkg-name)))))
|
||||
(call-with-pkg-lock
|
||||
(lambda ()
|
||||
(pkg-directory* pkg-name))))))
|
||||
|
||||
(define (pkg-directory* pkg-name #:db [db #f])
|
||||
(define info (package-info pkg-name #f #:db db))
|
||||
|
|
@ -580,6 +626,22 @@
|
|||
[_
|
||||
(build-path (pkg-installed-dir) pkg-name)]))))
|
||||
|
||||
(define (update-auto this-pkg-info auto?)
|
||||
(match-define (pkg-info orig-pkg checksum _) this-pkg-info)
|
||||
(if (sc-pkg-info? this-pkg-info)
|
||||
(sc-pkg-info orig-pkg checksum auto?
|
||||
(sc-pkg-info-collect this-pkg-info))
|
||||
(pkg-info orig-pkg checksum auto?)))
|
||||
|
||||
(define (demote-packages quiet? pkg-names)
|
||||
(define db (read-pkg-db))
|
||||
(for ([pkg-name (in-list pkg-names)])
|
||||
(define pi (package-info pkg-name #:db db))
|
||||
(unless (pkg-info-auto? pi)
|
||||
(unless quiet?
|
||||
(printf/flush "Demoting ~a to auto-installed\n" pkg-name))
|
||||
(update-pkg-db! pkg-name (update-auto pi #t)))))
|
||||
|
||||
(define ((remove-package quiet?) pkg-name)
|
||||
(unless quiet?
|
||||
(printf/flush "Removing ~a\n" pkg-name))
|
||||
|
|
@ -606,7 +668,10 @@
|
|||
#:root? (not (sc-pkg-info? pi)))
|
||||
(delete-directory/files pkg-dir)]))
|
||||
|
||||
(define (pkg-remove in-pkgs
|
||||
|
||||
|
||||
(define (pkg-remove given-pkgs
|
||||
#:demote? [demote? #f]
|
||||
#:force? [force? #f]
|
||||
#:auto? [auto? #f]
|
||||
#:quiet? [quiet? #f])
|
||||
|
|
@ -616,7 +681,8 @@
|
|||
(define all-pkgs-set
|
||||
(list->set all-pkgs))
|
||||
(define metadata-ns (make-metadata-namespace))
|
||||
(define pkgs
|
||||
(define in-pkgs (remove-duplicates given-pkgs))
|
||||
(define remove-pkgs
|
||||
(if auto?
|
||||
;; compute fixpoint:
|
||||
(let ([init-drop (set-union
|
||||
|
|
@ -640,13 +706,18 @@
|
|||
(loop still-drop
|
||||
(set-union keep delta)))))
|
||||
;; just given pkgs:
|
||||
(remove-duplicates in-pkgs)))
|
||||
(if demote?
|
||||
null
|
||||
in-pkgs)))
|
||||
(define setup-collects
|
||||
(get-setup-collects pkgs
|
||||
(get-setup-collects remove-pkgs
|
||||
db
|
||||
metadata-ns))
|
||||
(unless force?
|
||||
(define pkgs-set (list->set pkgs))
|
||||
(unless (or force? demote?)
|
||||
;; Check dependencies on `in-pkgs' (not `pkgs', which has already
|
||||
;; been filtered to remove package with dependencies if `auto?' is
|
||||
;; true).
|
||||
(define pkgs-set (list->set in-pkgs))
|
||||
(define remaining-pkg-db-set
|
||||
(set-subtract all-pkgs-set
|
||||
pkgs-set))
|
||||
|
|
@ -670,9 +741,19 @@
|
|||
remaining-pkg-db-set)))
|
||||
(~a p " (required by: " ds ")"))
|
||||
(set->list deps-to-be-removed))))))
|
||||
(for-each (remove-package quiet?) pkgs)
|
||||
|
||||
(when demote?
|
||||
;; Demote any package that is not going to be removed:
|
||||
(demote-packages
|
||||
quiet?
|
||||
(set->list (set-subtract (list->set in-pkgs)
|
||||
(list->set remove-pkgs)))))
|
||||
|
||||
(for-each (remove-package quiet?)
|
||||
remove-pkgs)
|
||||
|
||||
(cond
|
||||
[(null? pkgs)
|
||||
[(or (null? remove-pkgs) demote?)
|
||||
;; Did nothing, so no setup:
|
||||
'skip]
|
||||
[else
|
||||
|
|
@ -1073,6 +1154,7 @@
|
|||
descs)
|
||||
(define download-printf (if quiet? void printf/flush))
|
||||
(define check-sums? (not ignore-checksums?))
|
||||
(define current-scope-db (read-pkg-db))
|
||||
(define all-db (merge-pkg-dbs))
|
||||
(define path-pkg-cache (make-hash))
|
||||
(define (install-package/outer infos desc info)
|
||||
|
|
@ -1108,8 +1190,42 @@
|
|||
(values (install-info-name i) (install-info-directory i))))
|
||||
(cond
|
||||
[(and (not updating?) (hash-ref all-db pkg-name #f))
|
||||
(clean!)
|
||||
(pkg-error "package is already installed\n package: ~a" pkg-name)]
|
||||
(define this-pkg-info (hash-ref all-db pkg-name #f))
|
||||
(cond
|
||||
[(and (pkg-info-auto? this-pkg-info)
|
||||
(not (pkg-desc-auto? desc))
|
||||
;; Don't confuse a promotion request with a different-source install:
|
||||
(equal? (pkg-info-orig-pkg this-pkg-info) orig-pkg)
|
||||
;; Also, make sure it's installed in the scope that we're changing:
|
||||
(hash-ref current-scope-db pkg-name #f))
|
||||
;; promote an auto-installed package to a normally installed one
|
||||
(lambda ()
|
||||
(unless quiet?
|
||||
(download-printf "Promoting ~a from auto-installed to explicitly installed\n" pkg-name))
|
||||
(update-pkg-db! pkg-name (update-auto this-pkg-info #f)))]
|
||||
[else
|
||||
;; Fail --- already installed
|
||||
(clean!)
|
||||
(if (and (pkg-info-auto? this-pkg-info)
|
||||
(not (pkg-desc-auto? desc)))
|
||||
;; It failed either due to scope or source:
|
||||
(if (equal? (pkg-info-orig-pkg this-pkg-info) orig-pkg)
|
||||
(pkg-error (~a "package is currently installed in a wider scope\n"
|
||||
" package: ~a\n"
|
||||
" installed scope: ~a\n"
|
||||
" given scope: ~a")
|
||||
pkg-name
|
||||
(find-pkg-installation-scope pkg-name #:next? #t)
|
||||
(current-pkg-scope))
|
||||
(pkg-error (~a "package is already installed from a different source\n"
|
||||
" package: ~a\n"
|
||||
" installed source: ~a\n"
|
||||
" given source: ~a")
|
||||
pkg-name
|
||||
(pkg-info-orig-pkg this-pkg-info)
|
||||
orig-pkg))
|
||||
(pkg-error "package is already installed\n package: ~a"
|
||||
pkg-name))])]
|
||||
[(and
|
||||
(not force?)
|
||||
(for/or ([mp (in-set module-paths)])
|
||||
|
|
@ -1223,7 +1339,7 @@
|
|||
'version (lambda () "0.0"))
|
||||
#f))]
|
||||
[else
|
||||
(values (get-metadata metadata-ns (pkg-directory name)
|
||||
(values (get-metadata metadata-ns (pkg-directory** name)
|
||||
'version (lambda () "0.0"))
|
||||
#t)]))
|
||||
(define inst-vers (if (and this-platform?
|
||||
|
|
@ -1344,15 +1460,24 @@
|
|||
(pkg-desc-source desc)))
|
||||
(hash-set ht name desc))
|
||||
|
||||
(define all-descs (append old-descs descs))
|
||||
(define all-infos (append old-infos infos))
|
||||
|
||||
(define do-its
|
||||
(map (curry install-package/outer (append old-infos infos))
|
||||
(append old-descs descs)
|
||||
(append old-infos infos)))
|
||||
(map (curry install-package/outer all-infos)
|
||||
all-descs
|
||||
all-infos))
|
||||
(pre-succeed)
|
||||
|
||||
(define post-metadata-ns (make-metadata-namespace))
|
||||
(for-each (λ (t) (t)) do-its)
|
||||
|
||||
(define (is-promote? info)
|
||||
;; if the package name is in `current-scope-db', we must
|
||||
;; be simply promiting the package, and so it's
|
||||
;; already set up:
|
||||
(and (hash-ref current-scope-db (install-info-name info) #f) #t))
|
||||
|
||||
(define setup-collects
|
||||
(let ([db (read-pkg-db)])
|
||||
(get-setup-collects ((if updating?
|
||||
|
|
@ -1360,12 +1485,15 @@
|
|||
post-metadata-ns)
|
||||
values)
|
||||
(map install-info-name
|
||||
(append old-infos infos)))
|
||||
(if updating?
|
||||
all-infos
|
||||
(filter-not is-promote? all-infos))))
|
||||
db
|
||||
post-metadata-ns)))
|
||||
|
||||
(cond
|
||||
[(null? do-its)
|
||||
[(or (null? do-its)
|
||||
(and (not updating?) (andmap is-promote? all-infos)))
|
||||
;; No actions, so no setup:
|
||||
'skip]
|
||||
[else
|
||||
|
|
@ -1464,7 +1592,8 @@
|
|||
(or (pkg-desc-name d)
|
||||
(package-source->name (pkg-desc-source d)
|
||||
(pkg-desc-type d))))
|
||||
(not (hash-ref db pkg-name #f)))
|
||||
(define i (hash-ref db pkg-name #f))
|
||||
(or (not i) (pkg-info-auto? i)))
|
||||
descs)))
|
||||
pkg-desc=?))
|
||||
(with-handlers* ([vector?
|
||||
|
|
@ -2351,7 +2480,8 @@
|
|||
(->* ((listof string?))
|
||||
(#:auto? boolean?
|
||||
#:force? boolean?
|
||||
#:quiet? boolean?)
|
||||
#:quiet? boolean?
|
||||
#:demote? boolean?)
|
||||
(or/c #f 'skip (listof (or/c path-string? (non-empty-listof path-string?)))))]
|
||||
[pkg-show
|
||||
(->* (string?)
|
||||
|
|
@ -2446,4 +2576,7 @@
|
|||
(->* (path-string?)
|
||||
(#:name string?
|
||||
#:namespace namespace?)
|
||||
(or/c #f string?))]))
|
||||
(or/c #f string?))]
|
||||
[find-pkg-installation-scope (->* (string?)
|
||||
(#:next? boolean?)
|
||||
(or/c #f package-scope/c))]))
|
||||
|
|
|
|||
|
|
@ -1,6 +1,8 @@
|
|||
#lang racket/base
|
||||
(require racket/function
|
||||
racket/list
|
||||
racket/format
|
||||
racket/path
|
||||
raco/command-name
|
||||
setup/dirs
|
||||
net/url
|
||||
|
|
@ -30,7 +32,10 @@
|
|||
(string->symbol (format "~a ~a" (short-program+command-name) cmd))
|
||||
args))
|
||||
|
||||
(define (call-with-package-scope who given-scope scope-dir installation user thunk)
|
||||
|
||||
;; 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 thunk)
|
||||
(define scope
|
||||
(case given-scope
|
||||
[(installation user) given-scope]
|
||||
|
|
@ -39,7 +44,36 @@
|
|||
[installation 'installation]
|
||||
[user 'user]
|
||||
[scope-dir (path->complete-path scope-dir)]
|
||||
[else (default-pkg-scope)])]))
|
||||
[else
|
||||
(define default-scope (default-pkg-scope))
|
||||
(or (and pkgs
|
||||
;; Infer a scope from given package names:
|
||||
(parameterize ([current-pkg-scope 'user]
|
||||
[current-pkg-error (pkg-error who)])
|
||||
(with-pkg-lock/read-only
|
||||
(define-values (pkg scope)
|
||||
(for/fold ([prev-pkg #f] [prev-scope #f]) ([pkg (in-list pkgs)])
|
||||
(define scope (find-pkg-installation-scope pkg))
|
||||
(cond
|
||||
[(not prev-pkg) (values pkg scope)]
|
||||
[(equal? scope prev-scope) (values prev-pkg prev-scope)]
|
||||
[else
|
||||
((current-pkg-error)
|
||||
(~a "given packages are installed in different scopes\n"
|
||||
" package: ~a\n"
|
||||
" scope: ~a\n"
|
||||
" second package: ~a\n"
|
||||
" second scope: ~a")
|
||||
prev-pkg
|
||||
prev-scope
|
||||
pkg
|
||||
scope)])))
|
||||
(when (and scope
|
||||
(not (equal? scope default-scope)))
|
||||
(printf "Inferred package scope: ~a\n" scope))
|
||||
scope)))
|
||||
;; No inference, so use configured default scope:
|
||||
default-scope)])]))
|
||||
(parameterize ([current-pkg-scope scope]
|
||||
[current-pkg-error (pkg-error who)])
|
||||
(thunk)))
|
||||
|
|
@ -97,7 +131,7 @@
|
|||
#:args pkg-source
|
||||
(call-with-package-scope
|
||||
'install
|
||||
scope scope-dir installation user
|
||||
scope scope-dir installation user #f
|
||||
(lambda ()
|
||||
(unless (or (not name) (package-source->name name))
|
||||
((current-pkg-error) (format "~e is an invalid package name" name)))
|
||||
|
|
@ -152,7 +186,7 @@
|
|||
#:args pkg
|
||||
(call-with-package-scope
|
||||
'update
|
||||
scope scope-dir installation user
|
||||
scope scope-dir installation user pkg
|
||||
(lambda ()
|
||||
(define setup-collects
|
||||
(with-pkg-lock
|
||||
|
|
@ -165,6 +199,7 @@
|
|||
[remove
|
||||
"Remove packages"
|
||||
#:once-each
|
||||
[#:bool demote () "Demote to automatically installed, instead of removing"]
|
||||
[#:bool force () "Force removal of packages"]
|
||||
[#:bool auto () "Remove automatically installed packages with no dependencies"]
|
||||
#:once-any
|
||||
|
|
@ -182,11 +217,12 @@
|
|||
#:args pkg
|
||||
(call-with-package-scope
|
||||
'remove
|
||||
scope scope-dir installation user
|
||||
scope scope-dir installation user pkg
|
||||
(lambda ()
|
||||
(define setup-collects
|
||||
(with-pkg-lock
|
||||
(pkg-remove pkg
|
||||
#:demote? demote
|
||||
#:auto? auto
|
||||
#:force? force)))
|
||||
(setup no-setup setup-collects jobs)))]
|
||||
|
|
@ -220,7 +256,7 @@
|
|||
(for/list ([d (get-pkgs-search-dirs)])
|
||||
(if (equal? d main)
|
||||
'installation
|
||||
d))))
|
||||
(simple-form-path d)))))
|
||||
'(user)))])
|
||||
(when (or (equal? mode only-mode) (not only-mode))
|
||||
(unless only-mode
|
||||
|
|
@ -269,7 +305,7 @@
|
|||
#:args (from-version)
|
||||
(call-with-package-scope
|
||||
'migrate
|
||||
scope scope-dir installation user
|
||||
scope scope-dir installation user #f
|
||||
(lambda ()
|
||||
(define setup-collects
|
||||
(with-pkg-lock
|
||||
|
|
@ -326,7 +362,7 @@
|
|||
#:args key/val
|
||||
(call-with-package-scope
|
||||
'config
|
||||
scope #f installation user
|
||||
scope #f installation user #f
|
||||
(lambda ()
|
||||
(if set
|
||||
(with-pkg-lock
|
||||
|
|
|
|||
Loading…
Reference in New Issue
Block a user