futurile/guix-play
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

guix-build: Make `--root' effective for .drv files too.

Browse Source 
* guix-build.in (guix-build)[register-root]: Change first argument to
  `paths', which should be a list of store paths.  Update caller to call
  `derivation-path->output-paths' on DRV.  When `derivations-only?',
  also register root for .drv files.
This commit is contained in:
Ludovic Courtès 2013-01-06 00:18:43 +01:00
parent 7244a5f74e
commit 2646c55b03
1 changed files with 26 additions and 25 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

51
guix-build.in
View File

@ -171,27 +171,24 @@ Build the given PACKAGE-OR-DERIVATION and return their output paths.\n"))
(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)))
(define (register-root paths root)
;; Register ROOT as an indirect GC root for all of PATHS.
(let* ((root (string-append (canonicalize-path (dirname root))
"/" root)))
(catch 'system-error
(lambda ()
(match outputs*
((output)
(symlink output root)
(match paths
((path)
(symlink path root)
(add-indirect-root (%store) root))
((outputs ...)
(fold (lambda (output count)
((paths ...)
(fold (lambda (path count)
(let ((root (string-append root "-" (number->string count))))
(symlink output root)
(symlink path root)
(add-indirect-root (%store) root))
(+ 1 count))
0
outputs))))
paths))))
(lambda args
(format (current-error-port)
(_ "failed to create GC root `~a': ~a~%")
@ -234,7 +231,11 @@ Build the given PACKAGE-OR-DERIVATION and return their output paths.\n"))
(append (remove (compose (cut valid-path? (%store) <>)
derivation-path->output-path)
drv)
(map derivation-input-path req)))))
(map derivation-input-path req))))
(roots (filter-map (match-lambda
(('gc-root . root) root)
(_ #f))
opts)))
(if (assoc-ref opts 'dry-run?)
(format (current-error-port)
(N_ "~:[the following derivation would be built:~%~{ ~a~%~}~;~]"
@ -255,7 +256,10 @@ Build the given PACKAGE-OR-DERIVATION and return their output paths.\n"))
#:verbosity (assoc-ref opts 'verbosity))
(if (assoc-ref opts 'derivations-only?)
(format #t "~{~a~%~}" drv)
(begin
(format #t "~{~a~%~}" drv)
(for-each (cut register-root <> <>)
(map list drv) roots))
(or (assoc-ref opts 'dry-run?)
(and (build-derivations (%store) drv)
(for-each (lambda (d)
@ -268,15 +272,12 @@ Build the given PACKAGE-OR-DERIVATION and return their output paths.\n"))
d out-name)))
(derivation-outputs drv)))))
drv)
(let ((roots (filter-map (match-lambda
(('gc-root . root)
root)
(_ #f))
opts)))
(when roots
(for-each (cut register-root <> <>)
drv roots)
#t))))))))))
(for-each (cut register-root <> <>)
(map (lambda (drv)
(map cdr
(derivation-path->output-paths drv)))
drv)
roots)))))))))
;; Local Variables:
;; eval: (put 'guard 'scheme-indent-function 1)