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'.
This commit is contained in:
Ludovic Courtès 2013-02-27 23:16:00 +01:00
parent fae31edcec
commit ba8b732d20
3 changed files with 73 additions and 7 deletions

View file

@ -657,6 +657,18 @@ store---i.e., files and directories no longer reachable from any root.
@item --list-live @item --list-live
Show the list of live store files and directories. 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 @end table

View file

@ -20,6 +20,7 @@ (define-module (guix scripts gc)
#:use-module (guix ui) #:use-module (guix ui)
#:use-module (guix store) #:use-module (guix store)
#:use-module (ice-9 match) #:use-module (ice-9 match)
#:use-module (ice-9 regex)
#:use-module (srfi srfi-1) #:use-module (srfi srfi-1)
#:use-module (srfi srfi-26) #:use-module (srfi srfi-26)
#:use-module (srfi srfi-37) #:use-module (srfi srfi-37)
@ -47,6 +48,11 @@ (define (show-help)
(display (_ " (display (_ "
--list-live list live paths")) --list-live list live paths"))
(newline) (newline)
(display (_ "
--references list the references of PATHS"))
(display (_ "
--referrers list the referrers of PATHS"))
(newline)
(display (_ " (display (_ "
-h, --help display this help and exit")) -h, --help display this help and exit"))
(display (_ " (display (_ "
@ -125,6 +131,14 @@ (define %options
(option '("list-live") #f #f (option '("list-live") #f #f
(lambda (opt name arg result) (lambda (opt name arg result)
(alist-cons 'action 'list-live (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)))))) (alist-delete 'action result))))))
@ -142,9 +156,37 @@ (define (parse-options)
(alist-cons 'argument arg result)) (alist-cons 'argument arg result))
%default-options)) %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 (with-error-handling
(let ((opts (parse-options)) (let* ((opts (parse-options))
(store (open-connection))) (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) (case (assoc-ref opts 'action)
((collect-garbage) ((collect-garbage)
(let ((min-freed (assoc-ref opts 'min-freed))) (let ((min-freed (assoc-ref opts 'min-freed)))
@ -152,11 +194,11 @@ (define (parse-options)
(collect-garbage store min-freed) (collect-garbage store min-freed)
(collect-garbage store)))) (collect-garbage store))))
((delete) ((delete)
(let ((paths (filter-map (match-lambda (delete-paths store paths))
(('argument . arg) arg) ((list-references)
(_ #f)) (list-relatives references))
opts))) ((list-referrers)
(delete-paths store paths))) (list-relatives referrers))
((list-dead) ((list-dead)
(for-each (cut simple-format #t "~a~%" <>) (for-each (cut simple-format #t "~a~%" <>)
(dead-paths store))) (dead-paths store)))

View file

@ -25,6 +25,18 @@ guix gc --version
trap "rm -f guix-gc-root" EXIT trap "rm -f guix-gc-root" EXIT
rm -f guix-gc-root 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. # Add then reclaim a .drv file.
drv="`guix build idutils -d`" drv="`guix build idutils -d`"
test -f "$drv" test -f "$drv"