From 34811f02bf176c307ebe329aaefab8ed616a10df Mon Sep 17 00:00:00 2001
From: =?UTF-8?q?Ludovic=20Court=C3=A8s?= <ludo@gnu.org>
Date: Tue, 30 Oct 2012 00:20:53 +0100
Subject: [PATCH] guix-build: Add `--root'.
* guix/store.scm (add-indirect-root): New operation.
* guix-build.in (show-help): Document `--root'.
(%options): Add `--root'.
(guix-build)[register-root]: New procedure. Call it when `--root' is
passed.
---
guix-build.in | 46 ++++++++++++++++++++++++++++++++++++++++++++--
guix/store.scm | 8 ++++++++
2 files changed, 52 insertions(+), 2 deletions(-)
diff --git a/guix-build.in b/guix-build.in
index bd32ce951ef..7089a747316 100644
--- a/guix-build.in
+++ b/guix-build.in
@@ -101,6 +101,9 @@ Build the given PACKAGE-OR-DERIVATION and return their output paths.\n"))
--no-substitutes build instead of resorting to pre-built substitutes"))
(display (_ "
-c, --cores=N allow the use of up to N CPU cores for the build"))
+ (display (_ "
+ -r, --root=FILE make FILE a symlink to the result, and register it
+ as a garbage collector root"))
(newline)
(display (_ "
-h, --help display this help and exit"))
@@ -151,7 +154,10 @@ Report bugs to: ~a.~%") "@PACKAGE_BUGREPORT@"))
(option '("no-substitutes") #f #f
(lambda (opt name arg result)
(alist-cons 'substitutes? #f
- (alist-delete 'substitutes? result))))))
+ (alist-delete 'substitutes? result))))
+ (option '(#\r "root") #t #f
+ (lambda (opt name arg result)
+ (alist-cons 'gc-root arg result)))))
;;;
@@ -168,6 +174,33 @@ Report bugs to: ~a.~%") "@PACKAGE_BUGREPORT@"))
(alist-cons 'argument arg result))
%default-options))
+ (define (register-root drv root)
+ ;; Register ROOT as an indirect GC root for DRV's outputs.
+ (let* ((root (string-append (canonicalize-path (dirname root))
+ "/" root))
+ (drv* (call-with-input-file drv read-derivation))
+ (outputs (derivation-outputs drv*))
+ (outputs* (map (compose derivation-output-path cdr) outputs)))
+ (catch 'system-error
+ (lambda ()
+ (match outputs*
+ ((output)
+ (symlink output root)
+ (add-indirect-root %store root))
+ ((outputs ...)
+ (fold (lambda (output count)
+ (let ((root (string-append root "-" (number->string count))))
+ (symlink output root)
+ (add-indirect-root %store root))
+ (+ 1 count))
+ 0
+ outputs))))
+ (lambda args
+ (format (current-error-port)
+ (_ "failed to create GC root `~a': ~a~%")
+ root (strerror (system-error-errno args)))
+ (exit 1)))))
+
(setlocale LC_ALL "")
(textdomain "guix")
(setvbuf (current-output-port) _IOLBF)
@@ -244,7 +277,16 @@ Report bugs to: ~a.~%") "@PACKAGE_BUGREPORT@"))
(derivation-path->output-path
d out-name)))
(derivation-outputs drv)))))
- drv)))))))
+ drv)
+ (let ((roots (filter-map (match-lambda
+ (('gc-root . root)
+ root)
+ (_ #f))
+ opts)))
+ (when roots
+ (for-each (cut register-root <> <>)
+ drv roots)
+ #t))))))))
;; Local Variables:
;; eval: (put 'guard 'scheme-indent-function 1)
diff --git a/guix/store.scm b/guix/store.scm
index 34421a11df4..5ac98d80bb7 100644
--- a/guix/store.scm
+++ b/guix/store.scm
@@ -49,6 +49,7 @@ (define-module (guix store)
add-text-to-store
add-to-store
build-derivations
+ add-indirect-root
current-build-output-port
@@ -419,6 +420,13 @@ (define-operation (build-derivations (string-list derivations))
Return #t on success."
boolean)
+(define-operation (add-indirect-root (string file-name))
+ "Make FILE-NAME an indirect root for the garbage collector; FILE-NAME
+can be anywhere on the file system, but it must be an absolute file
+name--it is the caller's responsibility to ensure that it is an absolute
+file name. Return #t on success."
+ boolean)
+
;;;
;;; Store paths.
--
GitLab