From ba8b732d209a891455ef08b81125796dab797435 Mon Sep 17 00:00:00 2001
From: =?UTF-8?q?Ludovic=20Court=C3=A8s?= <ludo@gnu.org>
Date: Wed, 27 Feb 2013 23:16:00 +0100
Subject: [PATCH] guix gc: Add `--references' and `--referrers'.

* guix/scripts/gc.scm (show-help): Update.
  (%options): Add `--references' and `--referrers'.
  (guix-gc)[symlink-target, store-directory]: New procedures.
  Handle the `list-references' and `list-referrers' actions.
* tests/guix-gc.sh: Add tests for `--references'.
* doc/guix.texi (Invoking guix gc): Document `--references' and
  `--referrers'.
---
 doc/guix.texi       | 12 ++++++++++
 guix/scripts/gc.scm | 56 +++++++++++++++++++++++++++++++++++++++------
 tests/guix-gc.sh    | 12 ++++++++++
 3 files changed, 73 insertions(+), 7 deletions(-)

diff --git a/doc/guix.texi b/doc/guix.texi
index 6a9ebab1f6..ec784ce349 100644
--- a/doc/guix.texi
+++ b/doc/guix.texi
@@ -657,6 +657,18 @@ store---i.e., files and directories no longer reachable from any root.
 
 @item --list-live
 Show the list of live store files and directories.
+
+@end table
+
+In addition, the references among existing store files can be queried:
+
+@table @code
+
+@item --references
+@itemx --referrers
+List the references (respectively, the referrers) of store files given
+as arguments.
+
 @end table
 
 
diff --git a/guix/scripts/gc.scm b/guix/scripts/gc.scm
index f2d2e17d4b..12d80fd171 100644
--- a/guix/scripts/gc.scm
+++ b/guix/scripts/gc.scm
@@ -20,6 +20,7 @@
   #:use-module (guix ui)
   #:use-module (guix store)
   #:use-module (ice-9 match)
+  #:use-module (ice-9 regex)
   #:use-module (srfi srfi-1)
   #:use-module (srfi srfi-26)
   #:use-module (srfi srfi-37)
@@ -47,6 +48,11 @@ Invoke the garbage collector.\n"))
   (display (_ "
       --list-live        list live paths"))
   (newline)
+  (display (_ "
+      --references       list the references of PATHS"))
+  (display (_ "
+      --referrers        list the referrers of PATHS"))
+  (newline)
   (display (_ "
   -h, --help             display this help and exit"))
   (display (_ "
@@ -125,6 +131,14 @@ interpreted."
         (option '("list-live") #f #f
                 (lambda (opt name arg result)
                   (alist-cons 'action 'list-live
+                              (alist-delete 'action result))))
+        (option '("references") #f #f
+                (lambda (opt name arg result)
+                  (alist-cons 'action 'list-references
+                              (alist-delete 'action result))))
+        (option '("referrers") #f #f
+                (lambda (opt name arg result)
+                  (alist-cons 'action 'list-referrers
                               (alist-delete 'action result))))))
 
 
@@ -142,9 +156,37 @@ interpreted."
                  (alist-cons 'argument arg result))
                %default-options))
 
+  (define (symlink-target file)
+    (let ((s (false-if-exception (lstat file))))
+      (if (and s (eq? 'symlink (stat:type s)))
+          (symlink-target (readlink file))
+          file)))
+
+  (define (store-directory file)
+    ;; Return the store directory that holds FILE if it's in the store,
+    ;; otherwise return FILE.
+    (or (and=> (string-match (string-append "^" (regexp-quote (%store-prefix))
+                                            "/([^/]+)")
+                             file)
+               (compose (cut string-append (%store-prefix) "/" <>)
+                        (cut match:substring <> 1)))
+        file))
+
   (with-error-handling
-    (let ((opts  (parse-options))
-          (store (open-connection)))
+    (let* ((opts  (parse-options))
+           (store (open-connection))
+           (paths (filter-map (match-lambda
+                               (('argument . arg) arg)
+                               (_ #f))
+                              opts)))
+      (define (list-relatives relatives)
+        (for-each (compose (lambda (path)
+                             (for-each (cut simple-format #t "~a~%" <>)
+                                       (relatives store path)))
+                           store-directory
+                           symlink-target)
+                  paths))
+
       (case (assoc-ref opts 'action)
         ((collect-garbage)
          (let ((min-freed (assoc-ref opts 'min-freed)))
@@ -152,11 +194,11 @@ interpreted."
                (collect-garbage store min-freed)
                (collect-garbage store))))
         ((delete)
-         (let ((paths (filter-map (match-lambda
-                                   (('argument . arg) arg)
-                                   (_ #f))
-                                  opts)))
-           (delete-paths store paths)))
+         (delete-paths store paths))
+        ((list-references)
+         (list-relatives references))
+        ((list-referrers)
+         (list-relatives referrers))
         ((list-dead)
          (for-each (cut simple-format #t "~a~%" <>)
                    (dead-paths store)))
diff --git a/tests/guix-gc.sh b/tests/guix-gc.sh
index a90d085ab2..eac9d82e89 100644
--- a/tests/guix-gc.sh
+++ b/tests/guix-gc.sh
@@ -25,6 +25,18 @@ guix gc --version
 trap "rm -f guix-gc-root" EXIT
 rm -f guix-gc-root
 
+# Check the references of a .drv.
+drv="`guix build guile-bootstrap -d`"
+out="`guix build guile-bootstrap`"
+test -f "$drv" && test -d "$out"
+
+guix gc --references "$drv" | grep -e -bash
+guix gc --references "$out"
+guix gc --references "$out/bin/guile"
+
+if guix gc --references /dev/null;
+then false; else true; fi
+
 # Add then reclaim a .drv file.
 drv="`guix build idutils -d`"
 test -f "$drv"