~ruther/guix-local

cdb5b075d545dd4e0b2a03bdc62fa0d1f6e00fc3 — Cyrill Schenkel 10 years ago 9aafbc0
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>
3 files changed, 31 insertions(+), 1 deletions(-)

M guix/scripts/gc.scm
M guix/store.scm
M tests/guix-gc.sh
M guix/scripts/gc.scm => guix/scripts/gc.scm +1 -1
@@ 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)

M guix/store.scm => guix/store.scm +10 -0
@@ 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)))

M tests/guix-gc.sh => tests/guix-gc.sh +20 -0
@@ 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"