raco pkg: add trash directory for removed/updated package installations
Packages that are installed as other than a link are not meant to be edited, but work can get lost if a package is edited and then removed or updated. Avoid that work loss by moving removed or updated packages to a trash folder. By default, the trash folder holds up to 512 packages for up to 48 hours. To disable the trash folder (for a given scope), use raco pkg config --set max-trash-packages 0 (I expect that some variant of Greenspun's rule predicted the eventual inclusion of "backup" management in the package system.)
This commit is contained in:
Matthew Flatt
parent
4bcdb9a3a3
commit
06c82877db
|
|
@ -45,6 +45,8 @@ to the @exec{raco pkg} sub-subcommands.
|
|||
@history[#:added "6.0.17"]}
|
||||
@defthing[pkg-archive-command procedure?]{Implements @command-ref{archive}.
|
||||
@history[#:added "6.1.0.8"]}
|
||||
@defthing[pkg-empty-trash-command procedure?]{Implements @command-ref{empty-trash}.
|
||||
@history[#:added "6.1.1.6"]}
|
||||
|
||||
@include-section["lib.scrbl"]
|
||||
@include-section["path.scrbl"]
|
||||
|
|
|
|||
|
|
@ -91,6 +91,18 @@ a parameter's value is @racket[#f], then the user's configuration is
|
|||
used.}
|
||||
|
||||
|
||||
@deftogether[(
|
||||
@defparam[current-pkg-trash-max-packages max-packages (or/c #f real?)]
|
||||
@defparam[current-pkg-trash-max-seconds max-seconds (or/c #f real?)]
|
||||
)]{
|
||||
|
||||
Parameters that determine the trash-directory limits. If
|
||||
a parameter's value is @racket[#f], then the user's configuration is
|
||||
used.
|
||||
|
||||
@history[#:added "6.1.1.6"]}
|
||||
|
||||
|
||||
@defproc[(pkg-directory [name string?]
|
||||
[#:cache cache (or/c #f (and/c hash? (not/c immutable?))) #f])
|
||||
(or/c path-string? #f)]{
|
||||
|
|
@ -234,7 +246,8 @@ is true, error messages may suggest specific command-line flags for
|
|||
[#:ignore-checksums? ignore-checksums? boolean? #f]
|
||||
[#:strict-doc-conflicts? strict-doc-conflicts? boolean? #f]
|
||||
[#:use-cache? use-cache? boolean? #t]
|
||||
[#:quiet? boolean? quiet? #f]
|
||||
[#:quiet? quiet? boolean? #f]
|
||||
[#:use-trash? use-trash? boolean? #f]
|
||||
[#:from-command-line? from-command-line? boolean? #f]
|
||||
[#:strip strip (or/c #f 'source 'binary 'binary-lib) #f]
|
||||
[#:force-strip? force-string? boolean? #f]
|
||||
|
|
@ -268,7 +281,11 @@ port, unless @racket[quiet?] is true.
|
|||
If @racket[from-command-line?] is true, error messages may suggest
|
||||
specific command-line flags for @command-ref{install}.
|
||||
|
||||
The package lock must be held; see @racket[with-pkg-lock].}
|
||||
The package lock must be held; see @racket[with-pkg-lock].
|
||||
|
||||
@history[#:changed "6.1.1.5" @elem{Added the @racket[#:multi-clone-mode]
|
||||
and @racket[#:infer-clone-from-dir?] arguments.}
|
||||
#:changed "6.1.1.6" @elem{Added the @racket[#:use-trash?] argument.}]}
|
||||
|
||||
|
||||
@defproc[(pkg-update [sources (listof (or/c string? pkg-desc?))]
|
||||
|
|
@ -281,7 +298,8 @@ The package lock must be held; see @racket[with-pkg-lock].}
|
|||
[#:ignore-checksums? ignore-checksums? boolean? #f]
|
||||
[#:strict-doc-conflicts? strict-doc-conflicts? boolean? #f]
|
||||
[#:use-cache? use-cache? quiet? #t]
|
||||
[#:quiet? boolean? quiet? #f]
|
||||
[#:quiet? quiet? boolean? #f]
|
||||
[#:use-trash? boolean? use-trash? #f]
|
||||
[#:from-command-line? from-command-line? boolean? #f]
|
||||
[#:strip strip (or/c #f 'source 'binary 'binary-lib) #f]
|
||||
[#:force-strip? force-string? boolean? #f]
|
||||
|
|
@ -318,14 +336,19 @@ corresponds to an existing repository-clone installation.
|
|||
If @racket[from-command-line?] is true, error messages may suggest
|
||||
specific command-line flags for @command-ref{update}.
|
||||
|
||||
The package lock must be held; see @racket[with-pkg-lock].}
|
||||
The package lock must be held; see @racket[with-pkg-lock].
|
||||
|
||||
@history[#:changed "6.1.1.5" @elem{Added the @racket[#:multi-clone-mode]
|
||||
and @racket[#:infer-clone-from-dir?] arguments.}
|
||||
#:changed "6.1.1.6" @elem{Added the @racket[#:use-trash?] argument.}]}
|
||||
|
||||
|
||||
@defproc[(pkg-remove [names (listof string?)]
|
||||
[#:demote? demote? boolean? #f]
|
||||
[#:auto? auto? boolean? #f]
|
||||
[#:force? force? boolean? #f]
|
||||
[#:quiet? boolean? quiet? #f]
|
||||
[#:quiet? quiet? boolean? #f]
|
||||
[#:use-trash? boolean? use-trash? #f]
|
||||
[#:from-command-line? from-command-line? boolean? #f])
|
||||
(or/c 'skip
|
||||
#f
|
||||
|
|
@ -339,7 +362,9 @@ Implements @racket[pkg-remove-command]. The result is the same as for
|
|||
If @racket[from-command-line?] is true, error messages may suggest
|
||||
specific command-line flags for @command-ref{remove}.
|
||||
|
||||
The package lock must be held; see @racket[with-pkg-lock].}
|
||||
The package lock must be held; see @racket[with-pkg-lock].
|
||||
|
||||
@history[#:changed "6.1.1.6" @elem{Added the @racket[#:use-trash?] argument.}]}
|
||||
|
||||
|
||||
@defproc[(pkg-new [name path-string?])
|
||||
|
|
@ -374,7 +399,7 @@ The package lock must be held to allow reads; see
|
|||
[#:use-cache? use-cache? boolean? #t]
|
||||
[#:ignore-checksums? ignore-checksums? boolean? #f]
|
||||
[#:strict-doc-conflicts? strict-doc-conflicts? boolean? #f]
|
||||
[#:quiet? boolean? quiet? #f]
|
||||
[#:quiet? quiet? boolean? #f]
|
||||
[#:from-command-line? from-command-line? boolean? #f]
|
||||
[#:strip strip (or/c #f 'source 'binary 'binary-lib) #f]
|
||||
[#:force-strip? force-string? boolean? #f])
|
||||
|
|
@ -471,6 +496,15 @@ would allow archiving to continue for other packages.
|
|||
@history[#:added "6.1.0.8"]}
|
||||
|
||||
|
||||
@defproc[(pkg-empty-trash [#:list? show-list? boolean? #f]
|
||||
[#:quiet? quiet? boolean? #t])
|
||||
void?]{
|
||||
|
||||
Implements @racket[pkg-empty-trash].
|
||||
|
||||
@history[#:added "6.1.1.6"]}
|
||||
|
||||
|
||||
@defproc[(pkg-catalog-update-local [#:catalogs catalogs (listof string?) (pkg-config-catalogs)]
|
||||
[#:catalog-file catalog-file path-string? (current-pkg-catalog-file)]
|
||||
[#:quiet? quiet? boolean? #f]
|
||||
|
|
|
|||
|
|
@ -573,11 +573,14 @@ sub-commands.
|
|||
@item{@DFlag{batch} --- Disables @deftech{interactive mode}, suppressing potential prompts for a user
|
||||
(e.g., about package dependencies or clone sharing).}
|
||||
|
||||
@item{@DFlag{no-trash} --- Refrain from moving updated or removed packages to a trash folder.}
|
||||
|
||||
@item{@DFlag{fail-fast} --- Breaks @exec{raco setup} as soon as any error is encountered.}
|
||||
]
|
||||
|
||||
@history[#:changed "6.1.1.5" @elem{Added the @DFlag{batch}, @DFlag{clone}, and
|
||||
@DFlag{multi-clone} flags.}]}
|
||||
@DFlag{multi-clone} flags.}
|
||||
#:changed "6.1.1.6" @elem{Added the @DFlag{no-trash} flag.}]}
|
||||
|
||||
|
||||
@subcommand{@command/toc{update} @nonterm{option} ... @nonterm{pkg-source} ...
|
||||
|
|
@ -671,12 +674,14 @@ the given @nonterm{pkg-source}s.
|
|||
@item{@DFlag{no-setup} --- Same as for @command-ref{install}.}
|
||||
@item{@DFlag{jobs} @nonterm{n} or @Flag{j} @nonterm{n} --- Same as for @command-ref{install}.}
|
||||
@item{@DFlag{batch} --- Same as for @command-ref{install}.}
|
||||
@item{@DFlag{no-trash} --- Same as for @command-ref{install}.}
|
||||
]
|
||||
|
||||
@history[#:changed "6.1.1.5" @elem{Added the @DFlag{batch}, @DFlag{clone}, and
|
||||
@DFlag{multi-clone} flags, and
|
||||
added update of enclosing package
|
||||
when no arguments are provided.}]}
|
||||
when no arguments are provided.}
|
||||
#:changed "6.1.1.6" @elem{Added the @DFlag{no-trash} flag.}]}
|
||||
|
||||
@subcommand{@command/toc{remove} @nonterm{option} ... @nonterm{pkg} ...
|
||||
--- Attempts to remove the given packages. By default, if a package is the dependency
|
||||
|
|
@ -705,9 +710,11 @@ the given @nonterm{pkg}s.
|
|||
@item{@DFlag{no-setup} --- Same as for @command-ref{install}.}
|
||||
@item{@DFlag{jobs} @nonterm{n} or @Flag{j} @nonterm{n} --- Same as for @command-ref{install}.}
|
||||
@item{@DFlag{batch} --- Same as for @command-ref{install}.}
|
||||
@item{@DFlag{no-trash} --- Same as for @command-ref{install}.}
|
||||
]
|
||||
|
||||
@history[#:changed "6.1.1.5" @elem{Added the @DFlag{batch} flag.}]}
|
||||
@history[#:changed "6.1.1.5" @elem{Added the @DFlag{batch} flag.}
|
||||
#:changed "6.1.1.6" @elem{Added the @DFlag{no-trash} flag.}]}
|
||||
|
||||
|
||||
@subcommand{@command/toc{new} @nonterm{pkg} ---
|
||||
|
|
@ -856,8 +863,16 @@ for @nonterm{key}.
|
|||
documentation; an empty string, which is the default, disables
|
||||
the URL so that the local filesystem is used. This key can be
|
||||
set only in @exec{installation} scope.}
|
||||
@item{@exec{trash-max-packages} --- A limit on the number of package implementations
|
||||
that are kept in a trash folder when the package is removed or updated.}
|
||||
@item{@exec{trash-max-seconds} --- A limit on the time since a package is removed or
|
||||
updated that its implementation is kept in the trash folder. Package implementations are
|
||||
removed from a trash folder only when another package is potentially added
|
||||
to the trash folder or @command-ref{empty-trash} is used.}
|
||||
]
|
||||
}
|
||||
|
||||
@history[#:changed "6.1.1.6" @elem{Added @exec{trash-max-packages} and @exec{trash-max-seconds}.}]}
|
||||
|
||||
|
||||
@subcommand{@command/toc{catalog-show} @nonterm{option} ... @nonterm{package-name} ...
|
||||
--- Consults @tech{package catalogs} for a package (that is not necessarily installed)
|
||||
|
|
@ -961,12 +976,35 @@ for @nonterm{key}.
|
|||
@item{@DFlag{exclude} @nonterm{pkg} --- Omits the specified @nonterm{pkg} from the
|
||||
resulting catalog. This also causes the dependencies of @nonterm{pkg} to be
|
||||
omitted if @DFlag{include-deps} is specified. This flag can be provided multiple times.}
|
||||
@item{@DFlag{relative} --- Write package sources to @nonterm{dest-catalog} in relative-path form.}
|
||||
@item{@DFlag{relative} --- Writes package sources to @nonterm{dest-catalog} in relative-path form.}
|
||||
]
|
||||
|
||||
@history[#:added "6.1.0.8"]
|
||||
}
|
||||
|
||||
@subcommand{@command/toc{empty-trash} @nonterm{option} ...
|
||||
--- Removes or lists package implementations that were previously removed or updated and
|
||||
are currently in the trash directory
|
||||
for the specified @tech{package scope}. The @exec{trash-max-packages} and
|
||||
@exec{trash-max-seconds} configuration keys (see @command-ref{config}) control
|
||||
how many packages are kept in the trash directory and for how long.
|
||||
|
||||
The @exec{empty-trash} sub-command accepts
|
||||
the following @nonterm{option}s:
|
||||
|
||||
@itemlist[
|
||||
@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}.}
|
||||
@item{@DFlag{scope-dir} @nonterm{dir} --- Same as for @command-ref{install}.}
|
||||
|
||||
@item{@DFlag{list} or @Flag{l} --- Shows the trash directory path and its content, instead of
|
||||
removing the current content.}
|
||||
]
|
||||
|
||||
@history[#:added "6.1.1.6"]
|
||||
}
|
||||
|
||||
@; ----------------------------------------
|
||||
|
||||
@section[#:tag "metadata"]{Package Metadata}
|
||||
|
|
|
|||
|
|
@ -49,6 +49,7 @@
|
|||
"update-deps"
|
||||
"update-auto"
|
||||
"scope"
|
||||
"trash"
|
||||
"migrate"
|
||||
"versions"
|
||||
"platform"
|
||||
|
|
|
|||
|
|
@ -17,7 +17,7 @@
|
|||
$ "raco pkg show -l -u -a -d" =stdout> #rx"Package\\[\\*=auto\\] +Checksum +Source +Directory\npkg-test1 +[a-f0-9]+ .*pkg-test1\"\n"
|
||||
$ "racket -e '(require pkg-test1)'" =exit> 0
|
||||
$ "racket -e '(file-or-directory-permissions (collection-path \"pkg-test1\") #o500)'"
|
||||
$ "raco pkg remove pkg-test1" =exit> 1
|
||||
$ "raco pkg remove --no-trash pkg-test1" =exit> 1
|
||||
$ "racket -e '(require pkg-test1)'" =exit> 1)
|
||||
|
||||
(shelly-case
|
||||
|
|
|
|||
|
|
@ -53,7 +53,7 @@
|
|||
$ "raco pkg install -u --copy test-pkgs/pkg-test1"
|
||||
$ "racket -l pkg-test1" =stdout> #rx"main loaded"
|
||||
$ "raco pkg install -i --copy test-pkgs/pkg-test1" =exit> 1 =stderr> #rx"packages in different scopes conflict"
|
||||
$ "raco pkg remove pkg-test1" =stdout> "Removing pkg-test1\n")
|
||||
$ "raco pkg remove --no-trash pkg-test1" =stdout> "Removing pkg-test1\n")
|
||||
|
||||
(shelly-case
|
||||
"override conflist, installation first"
|
||||
|
|
@ -62,7 +62,7 @@
|
|||
$ "raco pkg install -u --name pkg-test1 --copy test-pkgs/pkg-test1-v2" =exit> 1
|
||||
$ "raco pkg install --force -u --name pkg-test1 --copy test-pkgs/pkg-test1-v2"
|
||||
$ "racket -l racket/base -l pkg-test1/number -e '(number)'" =stdout> "2\n"
|
||||
$ "raco pkg remove pkg-test1" =stdout> "Removing pkg-test1\n"
|
||||
$ "raco pkg remove --no-trash pkg-test1" =stdout> "Removing pkg-test1\n"
|
||||
$ "racket -l racket/base -l pkg-test1/number -e '(number)'" =stdout> "1\n"
|
||||
$ "raco pkg remove pkg-test1" =stdout> #rx"Inferred package scope: installation")
|
||||
|
||||
|
|
@ -73,7 +73,7 @@
|
|||
$ "raco pkg install -i --name pkg-test1 --copy test-pkgs/pkg-test1-v2" =exit> 1
|
||||
$ "raco pkg install --force -i --name pkg-test1 --copy test-pkgs/pkg-test1-v2"
|
||||
$ "racket -l racket/base -l pkg-test1/number -e '(number)'" =stdout> "1\n"
|
||||
$ "raco pkg remove pkg-test1" =stdout> "Removing pkg-test1\n"
|
||||
$ "raco pkg remove --no-trash pkg-test1" =stdout> "Removing pkg-test1\n"
|
||||
$ "racket -l racket/base -l pkg-test1/number -e '(number)'" =stdout> "2\n"
|
||||
$ "raco pkg remove pkg-test1" =stdout> #rx"Inferred package scope: installation")
|
||||
|
||||
|
|
|
|||
53
pkgs/racket-test/tests/pkg/tests-trash.rkt
Normal file
53
pkgs/racket-test/tests/pkg/tests-trash.rkt
Normal file
|
|
@ -0,0 +1,53 @@
|
|||
#lang racket/base
|
||||
(require "util.rkt"
|
||||
"shelly.rkt")
|
||||
|
||||
(this-test-is-run-by-the-main-test)
|
||||
|
||||
(pkg-tests
|
||||
(with-fake-root
|
||||
(shelly-begin
|
||||
|
||||
(define (check-empty)
|
||||
(shelly-begin
|
||||
$ "raco pkg empty-trash -l" =stdout> #rx" \\[(none|does not exist)\\]\n"))
|
||||
|
||||
(define (add-remove)
|
||||
(shelly-begin
|
||||
$ "raco pkg install test-pkgs/pkg-test1.zip"
|
||||
$ "raco pkg remove pkg-test1"))
|
||||
|
||||
(define (check-single)
|
||||
(shelly-begin
|
||||
$ "raco pkg empty-trash -l" =stdout> #rx"Content:\n [0-9]+-0-pkg-test1\n$"))
|
||||
|
||||
(define (check-double)
|
||||
(shelly-begin
|
||||
$ "raco pkg empty-trash -l" =stdout> #rx"Content:\n [0-9]+-0-pkg-test1\n [0-9]*-.-pkg-test1\n$"))
|
||||
|
||||
$ "raco pkg install test-pkgs/pkg-test1.zip"
|
||||
$ "raco pkg remove --no-trash pkg-test1"
|
||||
(check-empty)
|
||||
|
||||
|
||||
(add-remove)
|
||||
(check-single)
|
||||
|
||||
(add-remove)
|
||||
(check-double)
|
||||
|
||||
$ "raco pkg empty-trash"
|
||||
(check-empty)
|
||||
|
||||
$ "raco pkg config --set trash-max-packages 1"
|
||||
(add-remove)
|
||||
(check-single)
|
||||
(add-remove)
|
||||
(check-single)
|
||||
$ "raco pkg config --set trash-max-packages 10"
|
||||
(add-remove)
|
||||
(check-double)
|
||||
|
||||
$ "raco pkg config --set trash-max-seconds 0"
|
||||
(add-remove)
|
||||
(check-single))))
|
||||
|
|
@ -25,7 +25,8 @@
|
|||
"private/catalog-update.rkt"
|
||||
"private/catalog-archive.rkt"
|
||||
"private/suggestions.rkt"
|
||||
"private/archive.rkt")
|
||||
"private/archive.rkt"
|
||||
"private/trash.rkt")
|
||||
|
||||
(define dep-behavior/c
|
||||
(or/c #f 'fail 'force 'search-ask 'search-auto))
|
||||
|
|
@ -62,6 +63,10 @@
|
|||
(parameter/c (or/c #f real?))]
|
||||
[current-pkg-download-cache-max-bytes
|
||||
(parameter/c (or/c #f real?))]
|
||||
[current-pkg-trash-max-packages
|
||||
(parameter/c (or/c #f real?))]
|
||||
[current-pkg-trash-max-seconds
|
||||
(parameter/c (or/c #f real?))]
|
||||
[pkg-directory
|
||||
(->* (string?)
|
||||
(#:cache (or/c #f (and/c hash? (not/c immutable?))))
|
||||
|
|
@ -98,6 +103,7 @@
|
|||
#:update-deps? boolean?
|
||||
#:update-implies? boolean?
|
||||
#:quiet? boolean?
|
||||
#:use-trash? boolean?
|
||||
#:from-command-line? boolean?
|
||||
#:all-platforms? boolean?
|
||||
#:force? boolean?
|
||||
|
|
@ -116,6 +122,7 @@
|
|||
(#:auto? boolean?
|
||||
#:force? boolean?
|
||||
#:quiet? boolean?
|
||||
#:use-trash? boolean?
|
||||
#:from-command-line? boolean?
|
||||
#:demote? boolean?)
|
||||
(or/c #f 'skip (listof (or/c path-string? (non-empty-listof path-string?)))))]
|
||||
|
|
@ -137,6 +144,7 @@
|
|||
#:use-cache? boolean?
|
||||
#:skip-installed? boolean?
|
||||
#:quiet? boolean?
|
||||
#:use-trash? boolean?
|
||||
#:from-command-line? boolean?
|
||||
#:strip (or/c #f 'source 'binary 'binary-lib)
|
||||
#:force-strip? boolean?
|
||||
|
|
@ -186,6 +194,11 @@
|
|||
#:quiet? boolean?
|
||||
#:package-exn-handler (string? exn:fail? . -> . any))
|
||||
void?)]
|
||||
[pkg-empty-trash
|
||||
(->* ()
|
||||
(#:list? boolean?
|
||||
#:quiet? boolean?)
|
||||
void)]
|
||||
[default-pkg-scope
|
||||
(-> package-scope/c)]
|
||||
[installed-pkg-names
|
||||
|
|
|
|||
|
|
@ -134,6 +134,7 @@
|
|||
(syntax-case stx ()
|
||||
[(_ #:scope-flags (scope-flags ...)
|
||||
#:job-flags (job-flags ...)
|
||||
#:trash-flags (trash-flags ...)
|
||||
#:catalog-flags (catalog-flags ...)
|
||||
#:install-type-flags (install-type-flags ...)
|
||||
#:install-dep-flags (install-dep-flags ...)
|
||||
|
|
@ -146,6 +147,7 @@
|
|||
#:install-copy-checks (install-copy-checks ...))
|
||||
(with-syntax ([([scope-flags ...]
|
||||
[job-flags ...]
|
||||
[trash-flags ...]
|
||||
[catalog-flags ...]
|
||||
[install-type-flags ...]
|
||||
[(install-dep-flags ... (dep-desc ...))]
|
||||
|
|
@ -157,6 +159,7 @@
|
|||
[install-copy-checks ...])
|
||||
(syntax-local-introduce #'([scope-flags ...]
|
||||
[job-flags ...]
|
||||
[trash-flags ...]
|
||||
[catalog-flags ...]
|
||||
[install-type-flags ...]
|
||||
[install-dep-flags ...]
|
||||
|
|
@ -194,6 +197,7 @@
|
|||
install-force-flags ...
|
||||
install-clone-flags ...
|
||||
job-flags ...
|
||||
trash-flags ...
|
||||
[#:bool fail-fast () ("Break `raco setup' when it discovers an error")]
|
||||
#:args pkg-source
|
||||
install-copy-defns ...
|
||||
|
|
@ -250,6 +254,7 @@
|
|||
'fail
|
||||
'ask))
|
||||
#:link-dirs? link-dirs?
|
||||
#:use-trash? (not no-trash)
|
||||
(for/list ([p (in-list sources)])
|
||||
(pkg-desc p a-type* name checksum #f
|
||||
#:path (and (eq? a-type* 'clone)
|
||||
|
|
@ -279,6 +284,7 @@
|
|||
install-force-flags ...
|
||||
install-clone-flags ...
|
||||
job-flags ...
|
||||
trash-flags ...
|
||||
#:args pkg-source
|
||||
install-copy-defns ...
|
||||
(let ([pkg-source
|
||||
|
|
@ -342,7 +348,8 @@
|
|||
'fail
|
||||
'ask))
|
||||
#:link-dirs? link-dirs?
|
||||
#:infer-clone-from-dir? (not (or link static-link copy))))))
|
||||
#:infer-clone-from-dir? (not (or link static-link copy))
|
||||
#:use-trash? (not no-trash)))))
|
||||
(setup "updated" no-setup #f setup-collects jobs))))]
|
||||
;; ----------------------------------------
|
||||
[remove
|
||||
|
|
@ -355,6 +362,7 @@
|
|||
scope-flags ...
|
||||
#:once-each
|
||||
job-flags ...
|
||||
trash-flags ...
|
||||
#:args pkg
|
||||
(call-with-package-scope
|
||||
'remove
|
||||
|
|
@ -366,7 +374,8 @@
|
|||
#:from-command-line? #t
|
||||
#:demote? demote
|
||||
#:auto? auto
|
||||
#:force? force)))
|
||||
#:force? force
|
||||
#:use-trash? (not no-trash))))
|
||||
(setup "removed" no-setup #f setup-collects jobs)))]
|
||||
;; ----------------------------------------
|
||||
[new
|
||||
|
|
@ -597,7 +606,21 @@
|
|||
(cons pkg pkgs)
|
||||
#:include-deps? include-deps
|
||||
#:exclude (exclude-list)
|
||||
#:relative-sources? relative))]))]))
|
||||
#:relative-sources? relative))]
|
||||
;; ----------------------------------------
|
||||
[empty-trash
|
||||
"Delete old package installations from the trash directory"
|
||||
#:once-any
|
||||
scope-flags ...
|
||||
#:once-each
|
||||
[#:bool list ("-l") "Show trash content without emptying"]
|
||||
#:args ()
|
||||
(call-with-package-scope
|
||||
'empty-trash
|
||||
scope scope-dir installation user #f #f #f #f
|
||||
(lambda ()
|
||||
(pkg-empty-trash #:list? list
|
||||
#:quiet? #f)))]))]))
|
||||
(make-commands
|
||||
#:scope-flags
|
||||
([(#:sym scope [installation user] #f) scope ()
|
||||
|
|
@ -611,6 +634,8 @@
|
|||
([#:bool no-setup () ("Don't `raco setup' after changing packages (usually a bad idea)")]
|
||||
[(#:num n #f) jobs ("-j") "Setup with <n> parallel jobs"]
|
||||
[#:bool batch () ("Disable interactive mode and all prompts")])
|
||||
#:trash-flags
|
||||
([#:bool no-trash () ("Delete uninstalled/updated, instead of moving to a trash folder")])
|
||||
#:catalog-flags
|
||||
([(#:str catalog #f) catalog () "Use <catalog> instead of configured catalogs"])
|
||||
#:install-type-flags
|
||||
|
|
|
|||
|
|
@ -109,12 +109,13 @@
|
|||
[(sub-path? < p d)
|
||||
;; Under the installation mode's package directory.
|
||||
;; We assume that no one else writes there, so the
|
||||
;; next path element is the package name (or the package
|
||||
;; name followed by "+<n>")
|
||||
;; next path element is the package name, the package
|
||||
;; name followed by "+<n>", or ".trash"
|
||||
(define len (length d))
|
||||
(define pkg-name (path-element->string (list-ref p len)))
|
||||
(if (regexp-match? #rx"pkgs[.]rktd" pkg-name)
|
||||
(values #f #f #f #f) ; don't count the database as a package
|
||||
(if (or (regexp-match? #rx"pkgs[.]rktd" pkg-name)
|
||||
(regexp-match? #rx"[.]trash" pkg-name))
|
||||
(values #f #f #f #f) ; don't count the database or trash can as a package
|
||||
(values (if (regexp-match? #rx"[+]" pkg-name) ; +<n> used as an alternate path, sometimes
|
||||
(regexp-replace #rx"[+].*$" pkg-name "")
|
||||
pkg-name)
|
||||
|
|
|
|||
|
|
@ -26,6 +26,13 @@
|
|||
(or (current-pkg-download-cache-max-bytes)
|
||||
(read-pkg-cfg/def 'download-cache-max-bytes)))
|
||||
|
||||
(define (get-trash-max-packages)
|
||||
(or (current-pkg-trash-max-packages)
|
||||
(read-pkg-cfg/def 'trash-max-packages)))
|
||||
(define (get-trash-max-seconds)
|
||||
(or (current-pkg-trash-max-seconds)
|
||||
(read-pkg-cfg/def 'trash-max-seconds)))
|
||||
|
||||
(define (read-pkg-cfg/def k)
|
||||
;; Lock is held for the current scope, but if
|
||||
;; the key is not found in the current scope,
|
||||
|
|
@ -42,6 +49,8 @@
|
|||
"download-cache")]
|
||||
['download-cache-max-files 1024]
|
||||
['download-cache-max-bytes (* 64 1024 1024)]
|
||||
['trash-max-packages 512]
|
||||
['trash-max-seconds (* 60 60 24 2)] ; 2 days
|
||||
[_ #f]))
|
||||
(define c (read-pkg-file-hash (pkg-config-file)))
|
||||
(define v (hash-ref c k 'none))
|
||||
|
|
@ -113,7 +122,9 @@
|
|||
"download-cache-max-files"
|
||||
"download-cache-max-bytes"
|
||||
"download-cache-dir"
|
||||
"doc-open-url")))
|
||||
"doc-open-url"
|
||||
"trash-max-packages"
|
||||
"trash-max-seconds")))
|
||||
(pkg-error (~a "missing value for config key\n"
|
||||
" config key: ~a")
|
||||
key)]
|
||||
|
|
@ -122,7 +133,10 @@
|
|||
"name"
|
||||
"download-cache-max-files"
|
||||
"download-cache-max-bytes"
|
||||
"download-cache-dir"))
|
||||
"download-cache-dir"
|
||||
"doc-open-url"
|
||||
"trash-max-packages"
|
||||
"trash-max-seconds"))
|
||||
val
|
||||
another-val
|
||||
more-vals)
|
||||
|
|
@ -155,7 +169,9 @@
|
|||
(path->string
|
||||
(path->complete-path val))))]
|
||||
[(list (and key (or "download-cache-max-files"
|
||||
"download-cache-max-bytes"))
|
||||
"download-cache-max-bytes"
|
||||
"trash-max-packages"
|
||||
"trash-max-seconds"))
|
||||
val)
|
||||
(unless (real? (string->number val))
|
||||
(pkg-error (~a "invalid value for config key\n"
|
||||
|
|
@ -187,7 +203,9 @@
|
|||
(printf "~a~a\n" indent (read-pkg-cfg/def 'installation-name))]
|
||||
[(or "download-cache-dir"
|
||||
"download-cache-max-files"
|
||||
"download-cache-max-bytes")
|
||||
"download-cache-max-bytes"
|
||||
"trash-max-packages"
|
||||
"trash-max-seconds")
|
||||
(printf "~a~a\n" indent (read-pkg-cfg/def (string->symbol key)))]
|
||||
["doc-open-url"
|
||||
(printf "~a~a\n" indent (or (read-pkg-cfg/def 'doc-open-url) ""))]
|
||||
|
|
@ -207,7 +225,9 @@
|
|||
"default-scope"
|
||||
"download-cache-dir"
|
||||
"download-cache-max-files"
|
||||
"download-cache-max-bytes"))])
|
||||
"download-cache-max-bytes"
|
||||
"trash-max-packages"
|
||||
"trash-max-seconds"))])
|
||||
(printf "~a:\n" key)
|
||||
(show (list key) " "))]
|
||||
[_ (show key+vals "")])]))
|
||||
|
|
|
|||
|
|
@ -135,6 +135,7 @@
|
|||
#:force? force?
|
||||
#:all-platforms? all-platforms?
|
||||
#:quiet? quiet?
|
||||
#:use-trash? use-trash?
|
||||
#:from-command-line? from-command-line?
|
||||
#:conversation conversation
|
||||
#:strip strip-mode
|
||||
|
|
@ -424,7 +425,7 @@
|
|||
(let ()
|
||||
(define (continue conversation)
|
||||
(raise (vector #t infos pkg-name update-pkgs
|
||||
(λ () (for-each (compose (remove-package quiet?) pkg-desc-name) update-pkgs))
|
||||
(λ () (for-each (compose (remove-package quiet? use-trash?) pkg-desc-name) update-pkgs))
|
||||
conversation
|
||||
clone-info)))
|
||||
(match (if (andmap (lambda (dep) (set-member? implies (pkg-desc-name dep)))
|
||||
|
|
@ -526,7 +527,7 @@
|
|||
#:from-command-line? from-command-line?
|
||||
#:link-dirs? link-dirs?)
|
||||
update-pkgs)])
|
||||
(λ () (for-each (compose (remove-package quiet?) pkg-desc-name) to-update))))
|
||||
(λ () (for-each (compose (remove-package quiet? use-trash?) pkg-desc-name) to-update))))
|
||||
(match this-dep-behavior
|
||||
['fail
|
||||
(clean!)
|
||||
|
|
@ -776,6 +777,7 @@
|
|||
#:catalog-lookup-cache [catalog-lookup-cache (make-hash)]
|
||||
#:updating? [updating? #f]
|
||||
#:quiet? [quiet? #f]
|
||||
#:use-trash? [use-trash? #f]
|
||||
#:from-command-line? [from-command-line? #f]
|
||||
#:conversation [conversation #f]
|
||||
#:strip [strip-mode #f]
|
||||
|
|
@ -785,9 +787,9 @@
|
|||
#:multi-clone-behavior [old-clone-behavior 'fail]
|
||||
#:repo-descs [old-repo-descs (initial-repo-descs
|
||||
(read-pkg-db)
|
||||
(if quiet? void printf))]
|
||||
(if quiet? void printf/flush))]
|
||||
#:convert-to-non-clone? [convert-to-non-clone? #f])
|
||||
(define download-printf (if quiet? void printf))
|
||||
(define download-printf (if quiet? void printf/flush))
|
||||
|
||||
(define descs
|
||||
(map (convert-clone-name-to-clone-repo/install catalog-lookup-cache
|
||||
|
|
@ -833,6 +835,9 @@
|
|||
#:catalog-lookup-cache catalog-lookup-cache
|
||||
#:pre-succeed (lambda () (pre-succeed) (more-pre-succeed))
|
||||
#:updating? updating?
|
||||
#:quiet? quiet?
|
||||
#:use-trash? use-trash?
|
||||
#:from-command-line? from-command-line?
|
||||
#:conversation conv
|
||||
#:strip strip-mode
|
||||
#:force-strip? force-strip?
|
||||
|
|
@ -858,11 +863,12 @@
|
|||
#:catalog-lookup-cache catalog-lookup-cache
|
||||
#:pre-succeed (λ ()
|
||||
(for ([pkg-name (in-hash-keys extra-updating)])
|
||||
((remove-package quiet?) pkg-name))
|
||||
((remove-package quiet? use-trash?) pkg-name))
|
||||
(pre-succeed))
|
||||
#:updating? updating?
|
||||
#:extra-updating extra-updating
|
||||
#:quiet? quiet?
|
||||
#:use-trash? use-trash?
|
||||
#:from-command-line? from-command-line?
|
||||
#:conversation conversation
|
||||
#:strip strip-mode
|
||||
|
|
@ -1093,6 +1099,7 @@
|
|||
#:update-deps? [update-deps? #f]
|
||||
#:update-implies? [update-implies? #t]
|
||||
#:quiet? [quiet? #f]
|
||||
#:use-trash? [use-trash? #f]
|
||||
#:from-command-line? [from-command-line? #f]
|
||||
#:strip [strip-mode #f]
|
||||
#:force-strip? [force-strip? #f]
|
||||
|
|
@ -1100,7 +1107,7 @@
|
|||
#:infer-clone-from-dir? [infer-clone-from-dir? #f]
|
||||
#:lookup-for-clone? [lookup-for-clone? #f]
|
||||
#:multi-clone-behavior [clone-behavior 'fail])
|
||||
(define download-printf (if quiet? void printf))
|
||||
(define download-printf (if quiet? void printf/flush))
|
||||
(define metadata-ns (make-metadata-namespace))
|
||||
(define db (read-pkg-db))
|
||||
(define all-mode? (and all? (empty? in-pkgs)))
|
||||
|
|
@ -1157,13 +1164,14 @@
|
|||
(flush-output))
|
||||
(pkg-install
|
||||
#:updating? #t
|
||||
#:pre-succeed (λ () (for-each (compose (remove-package quiet?) pkg-desc-name) to-update))
|
||||
#:pre-succeed (λ () (for-each (compose (remove-package quiet? use-trash?) pkg-desc-name) to-update))
|
||||
#:dep-behavior dep-behavior
|
||||
#:update-deps? update-deps?
|
||||
#:update-implies? update-implies?
|
||||
#:update-cache update-cache
|
||||
#:catalog-lookup-cache catalog-lookup-cache
|
||||
#:quiet? quiet?
|
||||
#:use-trash? use-trash?
|
||||
#:from-command-line? from-command-line?
|
||||
#:strip strip-mode
|
||||
#:force-strip? force-strip?
|
||||
|
|
|
|||
|
|
@ -27,3 +27,8 @@
|
|||
(define current-pkg-download-cache-max-bytes
|
||||
(make-parameter #f))
|
||||
|
||||
(define current-pkg-trash-max-packages
|
||||
(make-parameter #f))
|
||||
(define current-pkg-trash-max-seconds
|
||||
(make-parameter #f))
|
||||
|
||||
|
|
|
|||
|
|
@ -10,7 +10,8 @@
|
|||
"collects.rkt"
|
||||
"params.rkt"
|
||||
"print.rkt"
|
||||
"get-info.rkt")
|
||||
"get-info.rkt"
|
||||
"trash.rkt")
|
||||
|
||||
(provide remove-package
|
||||
pkg-remove)
|
||||
|
|
@ -24,7 +25,7 @@
|
|||
(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)
|
||||
(define ((remove-package quiet? use-trash?) pkg-name)
|
||||
(unless quiet?
|
||||
(printf/flush "Removing ~a\n" pkg-name))
|
||||
(define db (read-pkg-db))
|
||||
|
|
@ -48,8 +49,14 @@
|
|||
#:user? user?
|
||||
#:file (scope->links-file scope)
|
||||
#:root? (not (sc-pkg-info? pi)))
|
||||
(delete-directory/files pkg-dir)]))
|
||||
|
||||
(cond
|
||||
[(and use-trash?
|
||||
(select-trash-dest pkg-name))
|
||||
=> (lambda (trash-dest)
|
||||
(printf/flush "Moving ~a to trash: ~a\n" pkg-name trash-dest)
|
||||
(rename-file-or-directory pkg-dir trash-dest))]
|
||||
[else
|
||||
(delete-directory/files pkg-dir)])]))
|
||||
|
||||
|
||||
(define (pkg-remove given-pkgs
|
||||
|
|
@ -57,6 +64,7 @@
|
|||
#:force? [force? #f]
|
||||
#:auto? [auto? #f]
|
||||
#:quiet? [quiet? #f]
|
||||
#:use-trash? [use-trash? #f]
|
||||
#:from-command-line? [from-command-line? #f])
|
||||
(define db (read-pkg-db))
|
||||
(define all-pkgs
|
||||
|
|
@ -134,7 +142,7 @@
|
|||
(set->list (set-subtract (list->set in-pkgs)
|
||||
(list->set remove-pkgs)))))
|
||||
|
||||
(for-each (remove-package quiet?)
|
||||
(for-each (remove-package quiet? use-trash?)
|
||||
remove-pkgs)
|
||||
|
||||
(cond
|
||||
|
|
|
|||
76
racket/collects/pkg/private/trash.rkt
Normal file
76
racket/collects/pkg/private/trash.rkt
Normal file
|
|
@ -0,0 +1,76 @@
|
|||
#lang racket/base
|
||||
(require racket/list
|
||||
racket/file
|
||||
"config.rkt"
|
||||
"dirs.rkt"
|
||||
"print.rkt"
|
||||
"params.rkt")
|
||||
|
||||
(provide select-trash-dest
|
||||
pkg-empty-trash)
|
||||
|
||||
(define (find-trash-dir) (build-path (pkg-dir #f) ".trash"))
|
||||
|
||||
(define (select-trash-dest pkg-name
|
||||
#:remove-printf [remove-printf void])
|
||||
(define max-packages (get-trash-max-packages))
|
||||
(define max-seconds (get-trash-max-seconds))
|
||||
(define trash-dir (find-trash-dir))
|
||||
(make-directory* trash-dir)
|
||||
(define (delete-trash f)
|
||||
(define p (build-path trash-dir f))
|
||||
(remove-printf "Removing trash directory ~a\n" p)
|
||||
(log-pkg-info "Removing trash directory ~a" p)
|
||||
(delete-directory/files p))
|
||||
(define l (if (directory-exists? trash-dir)
|
||||
(directory-list trash-dir)
|
||||
null))
|
||||
(let loop ([l l])
|
||||
(cond
|
||||
[(and (pair? l)
|
||||
((length l) . > . (sub1 max-packages)))
|
||||
(delete-trash (car l))
|
||||
(loop (cdr l))]
|
||||
[(and (pair? l)
|
||||
(let ([m (regexp-match #rx"^([0-9]+)-" (car l))])
|
||||
(and m
|
||||
((string->number (cadr m)) . < . (- (current-seconds)
|
||||
max-seconds)))))
|
||||
(delete-trash (car l))
|
||||
(loop (cdr l))]
|
||||
[(max-packages . < . 1) #f]
|
||||
[(not pkg-name) #f]
|
||||
[else
|
||||
(let loop ([n 0])
|
||||
(define name (format "~a-~a-~a" (current-seconds) n pkg-name))
|
||||
(define p (build-path trash-dir name))
|
||||
(if (or (directory-exists? p)
|
||||
(file-exists? p)
|
||||
(link-exists? p))
|
||||
(loop (add1 n))
|
||||
p))])))
|
||||
|
||||
(define (pkg-empty-trash #:list? [show-list? #f]
|
||||
#:quiet? [quiet? #t])
|
||||
(cond
|
||||
[show-list?
|
||||
(define trash-dir (find-trash-dir))
|
||||
(printf "Trash directory for ~s scope:\n ~a\nContent:\n"
|
||||
(current-pkg-scope)
|
||||
trash-dir)
|
||||
(define exists? (directory-exists? trash-dir))
|
||||
(define l (if exists?
|
||||
(directory-list trash-dir)
|
||||
null))
|
||||
(cond
|
||||
[(not exists?)
|
||||
(printf " [does not exist]\n")]
|
||||
[(null? l)
|
||||
(printf " [none]\n")]
|
||||
[else
|
||||
(for ([i (in-list l)])
|
||||
(printf " ~a\n" i))])]
|
||||
[else
|
||||
(parameterize ([current-pkg-trash-max-packages 0])
|
||||
(select-trash-dest #t #:remove-printf (if quiet? void printf/flush)))
|
||||
(void)]))
|
||||
Loading…
Reference in New Issue
Block a user