diff options
| -rw-r--r-- | doc/guix.texi | 12 | ||||
| -rw-r--r-- | guix/scripts/gc.scm | 56 | ||||
| -rw-r--r-- | 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) @@ -48,6 +49,11 @@ Invoke the garbage collector.\n")) --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 (_ " -V, --version display version information and exit")) @@ -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" |