From cdb5b075d545dd4e0b2a03bdc62fa0d1f6e00fc3 Mon Sep 17 00:00:00 2001
From: Cyrill Schenkel <cyrill.schenkel@gmail.com>
Date: Sun, 24 May 2015 14:04:15 +0200
Subject: [PATCH] gc: ignore trailing slash or subdirectories for `guix gc -d'
MIME-Version: 1.0
Content-Type: text/plain; charset=UTF-8
Content-Transfer-Encoding: 8bit

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>
---
 guix/scripts/gc.scm |  2 +-
 guix/store.scm      | 10 ++++++++++
 tests/guix-gc.sh    | 20 ++++++++++++++++++++
 3 files changed, 31 insertions(+), 1 deletion(-)

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 @@ (define (list-relatives relatives)
                (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 @@ (define-module (guix store)
             derivation-path?
             store-path-package-name
             store-path-hash-part
+            direct-store-path
             log-file))
 
 (define %protocol-version #x10c)
@@ -1012,6 +1013,15 @@ (define (direct-store-path? path)
        (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)))
diff --git a/tests/guix-gc.sh b/tests/guix-gc.sh
index eac9d82e89..c1eb66cef5 100644
--- a/tests/guix-gc.sh
+++ b/tests/guix-gc.sh
@@ -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"