diff options
| -rw-r--r-- | guix-build.in | 46 | ||||
| -rw-r--r-- | guix/store.scm | 8 |
2 files changed, 52 insertions, 2 deletions
diff --git a/guix-build.in b/guix-build.in index bd32ce951e..7089a74731 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 34421a11df..5ac98d80bb 100644 --- a/guix/store.scm +++ b/guix/store.scm @@ -49,6 +49,7 @@ add-text-to-store add-to-store build-derivations + add-indirect-root current-build-output-port @@ -419,6 +420,13 @@ again until #t is returned or an error is raised." 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. |