mirror of
git://git.savannah.gnu.org/guix.git
synced 2023-12-14 03:33:07 +01:00
gc: ignore trailing slash or subdirectories for `guix gc -d'
Fixes <http://bugs.gnu.org/19757>. * guix/scripts/gc.scm (guix-gc): Convert paths to direct store paths. * guix/store.scm (direct-store-path): Get rid of subdirectories in store path. * tests/guix-gc.sh: New tests. Co-authored-by: Ludovic Courtès <ludo@gnu.org>
This commit is contained in:
parent
9aafbc0c13
commit
cdb5b075d5
3 changed files with 31 additions and 1 deletions
|
@ -168,7 +168,7 @@ Invoke the garbage collector.\n"))
|
|||
(collect-garbage store min-freed)
|
||||
(collect-garbage store))))
|
||||
((delete)
|
||||
(delete-paths store paths))
|
||||
(delete-paths store (map direct-store-path paths)))
|
||||
((list-references)
|
||||
(list-relatives references))
|
||||
((list-requisites)
|
||||
|
|
|
@ -121,6 +121,7 @@
|
|||
derivation-path?
|
||||
store-path-package-name
|
||||
store-path-hash-part
|
||||
direct-store-path
|
||||
log-file))
|
||||
|
||||
(define %protocol-version #x10c)
|
||||
|
@ -1012,6 +1013,15 @@ valid inputs."
|
|||
(let ((len (+ 1 (string-length (%store-prefix)))))
|
||||
(not (string-index (substring path len) #\/)))))
|
||||
|
||||
(define (direct-store-path path)
|
||||
"Return the direct store path part of PATH, stripping components after
|
||||
'/gnu/store/xxxx-foo'."
|
||||
(let ((prefix-length (+ (string-length (%store-prefix)) 35)))
|
||||
(if (> (string-length path) prefix-length)
|
||||
(let ((slash (string-index path #\/ prefix-length)))
|
||||
(if slash (string-take path slash) path))
|
||||
path)))
|
||||
|
||||
(define (derivation-path? path)
|
||||
"Return #t if PATH is a derivation path."
|
||||
(and (store-path? path) (string-suffix? ".drv" path)))
|
||||
|
|
|
@ -64,3 +64,23 @@ guix gc -C 1KiB
|
|||
# Check trivial error cases.
|
||||
if guix gc --delete /dev/null;
|
||||
then false; else true; fi
|
||||
|
||||
# Bug #19757
|
||||
out="`guix build guile-bootstrap`"
|
||||
test -d "$out"
|
||||
|
||||
guix gc --delete "$out"
|
||||
|
||||
! test -d "$out"
|
||||
|
||||
out="`guix build guile-bootstrap`"
|
||||
test -d "$out"
|
||||
|
||||
guix gc --delete "$out/"
|
||||
|
||||
! test -d "$out"
|
||||
|
||||
out="`guix build guile-bootstrap`"
|
||||
test -d "$out"
|
||||
|
||||
guix gc --delete "$out/bin/guile"
|
||||
|
|
Loading…
Reference in a new issue