mirror of
https://git.in.rschanz.org/ryan77627/guix.git
synced 2024-12-24 21:38:07 -05:00
guix build: Accept multiple '-s' options.
* guix/scripts/build.scm (%default-options): Remove 'system'. (%options) <--system>: Keep previous occurrences of 'system in RESULT. (options->derivations)[system]: Remove. [systems, things-to-build]: New variables. [compute-derivation]: New procedure. Iterate on all of SYSTEMS to compute the derivations of THINGS-TO-BUILD. * tests/guix-build.sh: Add test for one and multiple '-s' flags. * doc/guix.texi (Additional Build Options): Document this behavior.
This commit is contained in:
parent
296da6e624
commit
ea261dea0c
3 changed files with 70 additions and 48 deletions
|
@ -8030,7 +8030,9 @@ The following derivations will be built:
|
||||||
@item --system=@var{system}
|
@item --system=@var{system}
|
||||||
@itemx -s @var{system}
|
@itemx -s @var{system}
|
||||||
Attempt to build for @var{system}---e.g., @code{i686-linux}---instead of
|
Attempt to build for @var{system}---e.g., @code{i686-linux}---instead of
|
||||||
the system type of the build host.
|
the system type of the build host. The @command{guix build} command allows
|
||||||
|
you to repeat this option several times, in which case it builds for all the
|
||||||
|
specified systems; other commands ignore extraneous @option{-s} options.
|
||||||
|
|
||||||
@quotation Note
|
@quotation Note
|
||||||
The @code{--system} flag is for @emph{native} compilation and must not
|
The @code{--system} flag is for @emph{native} compilation and must not
|
||||||
|
|
|
@ -635,8 +635,7 @@ (define %standard-build-options
|
||||||
|
|
||||||
(define %default-options
|
(define %default-options
|
||||||
;; Alist of default option values.
|
;; Alist of default option values.
|
||||||
`((system . ,(%current-system))
|
`((build-mode . ,(build-mode normal))
|
||||||
(build-mode . ,(build-mode normal))
|
|
||||||
(graft? . #t)
|
(graft? . #t)
|
||||||
(substitutes? . #t)
|
(substitutes? . #t)
|
||||||
(build-hook? . #t)
|
(build-hook? . #t)
|
||||||
|
@ -729,8 +728,7 @@ (define %options
|
||||||
rest)))
|
rest)))
|
||||||
(option '(#\s "system") #t #f
|
(option '(#\s "system") #t #f
|
||||||
(lambda (opt name arg result)
|
(lambda (opt name arg result)
|
||||||
(alist-cons 'system arg
|
(alist-cons 'system arg result)))
|
||||||
(alist-delete 'system result eq?))))
|
|
||||||
(option '("target") #t #f
|
(option '("target") #t #f
|
||||||
(lambda (opt name arg result)
|
(lambda (opt name arg result)
|
||||||
(alist-cons 'target arg
|
(alist-cons 'target arg
|
||||||
|
@ -811,56 +809,71 @@ (define package->derivation
|
||||||
(cut package-cross-derivation <> <> triplet <>))))
|
(cut package-cross-derivation <> <> triplet <>))))
|
||||||
|
|
||||||
(define src (assoc-ref opts 'source))
|
(define src (assoc-ref opts 'source))
|
||||||
(define system (assoc-ref opts 'system))
|
|
||||||
(define graft? (assoc-ref opts 'graft?))
|
(define graft? (assoc-ref opts 'graft?))
|
||||||
|
(define systems
|
||||||
|
(match (filter-map (match-lambda
|
||||||
|
(('system . system) system)
|
||||||
|
(_ #f))
|
||||||
|
opts)
|
||||||
|
(() (list (%current-system)))
|
||||||
|
(systems systems)))
|
||||||
|
|
||||||
|
(define things-to-build
|
||||||
|
(map (cut transform store <>)
|
||||||
|
(options->things-to-build opts)))
|
||||||
|
|
||||||
|
(define (compute-derivation obj system)
|
||||||
|
;; Compute the derivation of OBJ for SYSTEM.
|
||||||
|
(match obj
|
||||||
|
((? package? p)
|
||||||
|
(let ((p (or (and graft? (package-replacement p)) p)))
|
||||||
|
(match src
|
||||||
|
(#f
|
||||||
|
(list (package->derivation store p system)))
|
||||||
|
(#t
|
||||||
|
(match (package-source p)
|
||||||
|
(#f
|
||||||
|
(format (current-error-port)
|
||||||
|
(G_ "~a: warning: \
|
||||||
|
package '~a' has no source~%")
|
||||||
|
(location->string (package-location p))
|
||||||
|
(package-name p))
|
||||||
|
'())
|
||||||
|
(s
|
||||||
|
(list (package-source-derivation store s)))))
|
||||||
|
(proc
|
||||||
|
(map (cut package-source-derivation store <>)
|
||||||
|
(proc p))))))
|
||||||
|
((? derivation? drv)
|
||||||
|
(list drv))
|
||||||
|
((? procedure? proc)
|
||||||
|
(list (run-with-store store
|
||||||
|
(mbegin %store-monad
|
||||||
|
(set-guile-for-build (default-guile))
|
||||||
|
(proc))
|
||||||
|
#:system system)))
|
||||||
|
((? file-like? obj)
|
||||||
|
(list (run-with-store store
|
||||||
|
(lower-object obj system
|
||||||
|
#:target (assoc-ref opts 'target))
|
||||||
|
#:system system)))
|
||||||
|
((? gexp? gexp)
|
||||||
|
(list (run-with-store store
|
||||||
|
(mbegin %store-monad
|
||||||
|
(set-guile-for-build (default-guile))
|
||||||
|
(gexp->derivation "gexp" gexp
|
||||||
|
#:system system))
|
||||||
|
#:system system)))))
|
||||||
|
|
||||||
;; We may get 'unbound-variable' errors while evaluating the 'inputs' fields
|
;; We may get 'unbound-variable' errors while evaluating the 'inputs' fields
|
||||||
;; of user packages. Since 'guix build' is the primary tool for people
|
;; of user packages. Since 'guix build' is the primary tool for people
|
||||||
;; testing new packages, report such errors gracefully.
|
;; testing new packages, report such errors gracefully.
|
||||||
(with-unbound-variable-handling
|
(with-unbound-variable-handling
|
||||||
(parameterize ((%graft? graft?))
|
(parameterize ((%graft? graft?))
|
||||||
(append-map (match-lambda
|
(append-map (lambda (system)
|
||||||
((? package? p)
|
(append-map (cut compute-derivation <> system)
|
||||||
(let ((p (or (and graft? (package-replacement p)) p)))
|
things-to-build))
|
||||||
(match src
|
systems))))
|
||||||
(#f
|
|
||||||
(list (package->derivation store p system)))
|
|
||||||
(#t
|
|
||||||
(match (package-source p)
|
|
||||||
(#f
|
|
||||||
(format (current-error-port)
|
|
||||||
(G_ "~a: warning: \
|
|
||||||
package '~a' has no source~%")
|
|
||||||
(location->string (package-location p))
|
|
||||||
(package-name p))
|
|
||||||
'())
|
|
||||||
(s
|
|
||||||
(list (package-source-derivation store s)))))
|
|
||||||
(proc
|
|
||||||
(map (cut package-source-derivation store <>)
|
|
||||||
(proc p))))))
|
|
||||||
((? derivation? drv)
|
|
||||||
(list drv))
|
|
||||||
((? procedure? proc)
|
|
||||||
(list (run-with-store store
|
|
||||||
(mbegin %store-monad
|
|
||||||
(set-guile-for-build (default-guile))
|
|
||||||
(proc))
|
|
||||||
#:system system)))
|
|
||||||
((? file-like? obj)
|
|
||||||
(list (run-with-store store
|
|
||||||
(lower-object obj system
|
|
||||||
#:target (assoc-ref opts 'target))
|
|
||||||
#:system system)))
|
|
||||||
((? gexp? gexp)
|
|
||||||
(list (run-with-store store
|
|
||||||
(mbegin %store-monad
|
|
||||||
(set-guile-for-build (default-guile))
|
|
||||||
(gexp->derivation "gexp" gexp
|
|
||||||
#:system system))
|
|
||||||
#:system system))))
|
|
||||||
(map (cut transform store <>)
|
|
||||||
(options->things-to-build opts))))))
|
|
||||||
|
|
||||||
(define (show-build-log store file urls)
|
(define (show-build-log store file urls)
|
||||||
"Show the build log for FILE, falling back to remote logs from URLS if
|
"Show the build log for FILE, falling back to remote logs from URLS if
|
||||||
|
|
|
@ -44,6 +44,13 @@ guix build -e '(@@ (gnu packages bootstrap) %bootstrap-guile)'
|
||||||
guix build -e '(@@ (gnu packages bootstrap) %bootstrap-guile)'; \
|
guix build -e '(@@ (gnu packages bootstrap) %bootstrap-guile)'; \
|
||||||
then exit 1; fi )
|
then exit 1; fi )
|
||||||
|
|
||||||
|
# Passing one '-s' flag.
|
||||||
|
test `guix build sed -s x86_64-linux -d | wc -l` = 1
|
||||||
|
|
||||||
|
# Passing multiple '-s' flags.
|
||||||
|
all_systems="-s x86_64-linux -s i686-linux -s armhf-linux -s aarch64-linux"
|
||||||
|
test `guix build sed $all_systems -d | sort -u | wc -l` = 4
|
||||||
|
|
||||||
# Check --sources option with its arguments
|
# Check --sources option with its arguments
|
||||||
module_dir="t-guix-build-$$"
|
module_dir="t-guix-build-$$"
|
||||||
mkdir "$module_dir"
|
mkdir "$module_dir"
|
||||||
|
|
Loading…
Reference in a new issue