diff --git a/pkgs/racket-doc/pkg/scribblings/apis.scrbl b/pkgs/racket-doc/pkg/scribblings/apis.scrbl index 140c4224e3..437eef5d85 100644 --- a/pkgs/racket-doc/pkg/scribblings/apis.scrbl +++ b/pkgs/racket-doc/pkg/scribblings/apis.scrbl @@ -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"] diff --git a/pkgs/racket-doc/pkg/scribblings/lib.scrbl b/pkgs/racket-doc/pkg/scribblings/lib.scrbl index 7b60034c1a..080624fb67 100644 --- a/pkgs/racket-doc/pkg/scribblings/lib.scrbl +++ b/pkgs/racket-doc/pkg/scribblings/lib.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] diff --git a/pkgs/racket-doc/pkg/scribblings/pkg.scrbl b/pkgs/racket-doc/pkg/scribblings/pkg.scrbl index 1100598cc5..537d5fb4b9 100644 --- a/pkgs/racket-doc/pkg/scribblings/pkg.scrbl +++ b/pkgs/racket-doc/pkg/scribblings/pkg.scrbl @@ -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} diff --git a/pkgs/racket-test/tests/pkg/test.rkt b/pkgs/racket-test/tests/pkg/test.rkt index 6ab0444df4..d4e222c558 100644 --- a/pkgs/racket-test/tests/pkg/test.rkt +++ b/pkgs/racket-test/tests/pkg/test.rkt @@ -49,6 +49,7 @@ "update-deps" "update-auto" "scope" + "trash" "migrate" "versions" "platform" diff --git a/pkgs/racket-test/tests/pkg/tests-failure.rkt b/pkgs/racket-test/tests/pkg/tests-failure.rkt index d84f00f6a2..50b32a4742 100644 --- a/pkgs/racket-test/tests/pkg/tests-failure.rkt +++ b/pkgs/racket-test/tests/pkg/tests-failure.rkt @@ -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 diff --git a/pkgs/racket-test/tests/pkg/tests-scope.rkt b/pkgs/racket-test/tests/pkg/tests-scope.rkt index fc5bd46edc..27788f8788 100644 --- a/pkgs/racket-test/tests/pkg/tests-scope.rkt +++ b/pkgs/racket-test/tests/pkg/tests-scope.rkt @@ -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") diff --git a/pkgs/racket-test/tests/pkg/tests-trash.rkt b/pkgs/racket-test/tests/pkg/tests-trash.rkt new file mode 100644 index 0000000000..d411ad5c02 --- /dev/null +++ b/pkgs/racket-test/tests/pkg/tests-trash.rkt @@ -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)))) diff --git a/racket/collects/pkg/lib.rkt b/racket/collects/pkg/lib.rkt index 1b5fbf82fc..a7db4c1ba1 100644 --- a/racket/collects/pkg/lib.rkt +++ b/racket/collects/pkg/lib.rkt @@ -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 diff --git a/racket/collects/pkg/main.rkt b/racket/collects/pkg/main.rkt index 1ffb50c07b..7a4f4d3a27 100644 --- a/racket/collects/pkg/main.rkt +++ b/racket/collects/pkg/main.rkt @@ -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 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 instead of configured catalogs"]) #:install-type-flags diff --git a/racket/collects/pkg/path.rkt b/racket/collects/pkg/path.rkt index 473df9e11f..35c4b2d88a 100644 --- a/racket/collects/pkg/path.rkt +++ b/racket/collects/pkg/path.rkt @@ -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 "+") + ;; next path element is the package name, the package + ;; name followed by "+", 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) ; + used as an alternate path, sometimes (regexp-replace #rx"[+].*$" pkg-name "") pkg-name) diff --git a/racket/collects/pkg/private/config.rkt b/racket/collects/pkg/private/config.rkt index 07c1a3bdad..f41215f1bb 100644 --- a/racket/collects/pkg/private/config.rkt +++ b/racket/collects/pkg/private/config.rkt @@ -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 "")])])) diff --git a/racket/collects/pkg/private/install.rkt b/racket/collects/pkg/private/install.rkt index dbeb9c2915..bd96bafb6e 100644 --- a/racket/collects/pkg/private/install.rkt +++ b/racket/collects/pkg/private/install.rkt @@ -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? diff --git a/racket/collects/pkg/private/params.rkt b/racket/collects/pkg/private/params.rkt index e55b294907..541979f441 100644 --- a/racket/collects/pkg/private/params.rkt +++ b/racket/collects/pkg/private/params.rkt @@ -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)) + diff --git a/racket/collects/pkg/private/remove.rkt b/racket/collects/pkg/private/remove.rkt index be1bcee4bf..6dec6e6c0f 100644 --- a/racket/collects/pkg/private/remove.rkt +++ b/racket/collects/pkg/private/remove.rkt @@ -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 diff --git a/racket/collects/pkg/private/trash.rkt b/racket/collects/pkg/private/trash.rkt new file mode 100644 index 0000000000..d410e4f9a0 --- /dev/null +++ b/racket/collects/pkg/private/trash.rkt @@ -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)]))