summaryrefslogtreecommitdiff
path: root/guix
diff options
context:
space:
mode:
authorCyrill Schenkel <cyrill.schenkel@gmail.com>2015-05-24 14:04:15 +0200
committerLudovic Courtès <ludo@gnu.org>2015-05-26 22:26:01 +0200
commitcdb5b075d545dd4e0b2a03bdc62fa0d1f6e00fc3 (patch)
tree45acbdd1be71153881dc51c76e9ae6006547e026 /guix
parent9aafbc0c1382ab78059804eb16b0900fd3b10ee4 (diff)
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>
Diffstat (limited to 'guix')
-rw-r--r--guix/scripts/gc.scm2
-rw-r--r--guix/store.scm10
2 files changed, 11 insertions, 1 deletions
diff --git a/guix/scripts/gc.scm b/guix/scripts/gc.scm
index 4bae65a1ec..a250cdc197 100644
--- a/guix/scripts/gc.scm
+++ b/guix/scripts/gc.scm
@@ -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)
diff --git a/guix/store.scm b/guix/store.scm
index fc2f8d92ca..8905a5a558 100644
--- a/guix/store.scm
+++ b/guix/store.scm
@@ -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)))