Browse Source

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.
version-0.8.3
Ludovic Courtès 10 years ago
parent
commit
34811f02bf
  1. 46
      guix-build.in
  2. 8
      guix/store.scm

46
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)

8
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.

Loading…
Cancel
Save