From aa72d9afdfe2d65e73c426c280667323181ae592 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Fri, 13 Feb 2015 17:23:17 +0100 Subject: gexp: Implement 'imported-modules' & co. using 'gexp->derivation'. * guix/derivations.scm (imported-files): Keep private. (%imported-modules, %compiled-modules, build-expression->derivation): Mark as deprecated. (imported-modules, compiled-modules): Remove. * guix/gexp.scm (%mkdir-p-definition): New variable. (imported-files, search-path*, imported-modules, compiled-modules): New procedures. * tests/derivations.scm ("imported-files"): Remove. * tests/gexp.scm ("imported-files", "gexp->derivation #:modules"): New tests. --- tests/derivations.scm | 17 ----------------- tests/gexp.scm | 34 ++++++++++++++++++++++++++++++++++ 2 files changed, 34 insertions(+), 17 deletions(-) (limited to 'tests') diff --git a/tests/derivations.scm b/tests/derivations.scm index 80aabad3a8..e23bdeed77 100644 --- a/tests/derivations.scm +++ b/tests/derivations.scm @@ -670,23 +670,6 @@ (let ((p (derivation->output-path drv))) (string-contains (call-with-input-file p read-line) "GNU"))))) -(test-assert "imported-files" - (let* ((files `(("x" . ,(search-path %load-path "ice-9/q.scm")) - ("a/b/c" . ,(search-path %load-path - "guix/derivations.scm")) - ("p/q" . ,(search-path %load-path "guix.scm")) - ("p/z" . ,(search-path %load-path "guix/store.scm")))) - (drv (imported-files %store files))) - (and (build-derivations %store (list drv)) - (let ((dir (derivation->output-path drv))) - (every (match-lambda - ((path . source) - (equal? (call-with-input-file (string-append dir "/" path) - get-bytevector-all) - (call-with-input-file source - get-bytevector-all)))) - files))))) - (test-assert "build-expression->derivation with modules" (let* ((builder `(begin (use-modules (guix build utils)) diff --git a/tests/gexp.scm b/tests/gexp.scm index 03722e4669..68c470d3b6 100644 --- a/tests/gexp.scm +++ b/tests/gexp.scm @@ -360,6 +360,40 @@ (string=? (readlink (string-append out "/" two "/one")) one))))))) +(test-assertm "imported-files" + (mlet* %store-monad + ((files -> `(("x" . ,(search-path %load-path "ice-9/q.scm")) + ("a/b/c" . ,(search-path %load-path + "guix/derivations.scm")) + ("p/q" . ,(search-path %load-path "guix.scm")) + ("p/z" . ,(search-path %load-path "guix/store.scm")))) + (drv (imported-files files))) + (mbegin %store-monad + (built-derivations (list drv)) + (let ((dir (derivation->output-path drv))) + (return + (every (match-lambda + ((path . source) + (equal? (call-with-input-file (string-append dir "/" path) + get-bytevector-all) + (call-with-input-file source + get-bytevector-all)))) + files)))))) + +(test-assertm "gexp->derivation #:modules" + (mlet* %store-monad + ((build -> #~(begin + (use-modules (guix build utils)) + (mkdir-p (string-append #$output "/guile/guix/nix")) + #t)) + (drv (gexp->derivation "test-with-modules" build + #:modules '((guix build utils))))) + (mbegin %store-monad + (built-derivations (list drv)) + (let* ((p (derivation->output-path drv)) + (s (stat (string-append p "/guile/guix/nix")))) + (return (eq? (stat:type s) 'directory)))))) + (test-assertm "gexp->derivation #:references-graphs" (mlet* %store-monad ((one (text-file "one" "hello, world")) -- cgit v1.2.3 From ce45eb4c385e3b473bc6746a8b58452865f69977 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Fri, 13 Feb 2015 23:14:05 +0100 Subject: gexp: Add #:graft? parameter to 'gexp->derivation'. * guix/gexp.scm (gexp->derivation): Add #:graft? parameter and honor it. * tests/gexp.scm ("gexp->derivation vs. grafts"): New test. * doc/guix.texi (G-Expressions): Update 'gexp->derivation' documentation. --- doc/guix.texi | 11 +++++++---- guix/gexp.scm | 62 ++++++++++++++++++++++++++++++++-------------------------- tests/gexp.scm | 17 ++++++++++++++++ 3 files changed, 58 insertions(+), 32 deletions(-) (limited to 'tests') diff --git a/doc/guix.texi b/doc/guix.texi index 04b9b4aaae..50a7084fec 100644 --- a/doc/guix.texi +++ b/doc/guix.texi @@ -2580,7 +2580,7 @@ below allow you to do that (@pxref{The Store Monad}, for more information about monads.) @deffn {Monadic Procedure} gexp->derivation @var{name} @var{exp} @ - [#:system (%current-system)] [#:target #f] [#:inputs '()] @ + [#:system (%current-system)] [#:target #f] [#:graft? #t] @ [#:hash #f] [#:hash-algo #f] @ [#:recursive? #f] [#:env-vars '()] [#:modules '()] @ [#:module-path @var{%load-path}] @ @@ -2591,12 +2591,15 @@ Return a derivation @var{name} that runs @var{exp} (a gexp) with is true, it is used as the cross-compilation target triplet for packages referred to by @var{exp}. -Make @var{modules} available in the evaluation context of @var{EXP}; -@var{MODULES} is a list of names of Guile modules searched in -@var{MODULE-PATH} to be copied in the store, compiled, and made available in +Make @var{modules} available in the evaluation context of @var{exp}; +@var{modules} is a list of names of Guile modules searched in +@var{module-path} to be copied in the store, compiled, and made available in the load path during the execution of @var{exp}---e.g., @code{((guix build utils) (guix build gnu-build-system))}. +@var{graft?} determines whether packages referred to by @var{exp} should be grafted when +applicable. + When @var{references-graphs} is true, it must be a list of tuples of one of the following forms: diff --git a/guix/gexp.scm b/guix/gexp.scm index 0620683078..a8349c7d6e 100644 --- a/guix/gexp.scm +++ b/guix/gexp.scm @@ -153,6 +153,7 @@ names and file names suitable for the #:allowed-references argument to (modules '()) (module-path %load-path) (guile-for-build (%guile-for-build)) + (graft? (%graft?)) references-graphs allowed-references local-build?) @@ -165,6 +166,9 @@ names of Guile modules searched in MODULE-PATH to be copied in the store, compiled, and made available in the load path during the execution of EXP---e.g., '((guix build utils) (guix build gnu-build-system)). +GRAFT? determines whether packages referred to by EXP should be grafted when +applicable. + When REFERENCES-GRAPHS is true, it must be a list of tuples of one of the following forms: @@ -198,10 +202,10 @@ The other arguments are as for 'derivation'." (cons file-name thing))) graphs)) - (mlet* %store-monad (;; The following binding is here to force - ;; '%current-system' and '%current-target-system' to be - ;; looked up at >>= time. - (unused (return #f)) + (mlet* %store-monad (;; The following binding forces '%current-system' and + ;; '%current-target-system' to be looked up at >>= + ;; time. + (graft? (set-grafting graft?)) (system -> (or system (%current-system))) (target -> (if (eq? target 'current) @@ -245,30 +249,32 @@ The other arguments are as for 'derivation'." (return guile-for-build) (package->derivation (default-guile) system)))) - (raw-derivation name - (string-append (derivation->output-path guile) - "/bin/guile") - `("--no-auto-compile" - ,@(if (pair? %modules) - `("-L" ,(derivation->output-path modules) - "-C" ,(derivation->output-path compiled)) - '()) - ,builder) - #:outputs outputs - #:env-vars env-vars - #:system system - #:inputs `((,guile) - (,builder) - ,@(if modules - `((,modules) (,compiled) ,@inputs) - inputs) - ,@(match graphs - (((_ . inputs) ...) inputs) - (_ '()))) - #:hash hash #:hash-algo hash-algo #:recursive? recursive? - #:references-graphs (and=> graphs graphs-file-names) - #:allowed-references allowed - #:local-build? local-build?))) + (mbegin %store-monad + (set-grafting graft?) ;restore the initial setting + (raw-derivation name + (string-append (derivation->output-path guile) + "/bin/guile") + `("--no-auto-compile" + ,@(if (pair? %modules) + `("-L" ,(derivation->output-path modules) + "-C" ,(derivation->output-path compiled)) + '()) + ,builder) + #:outputs outputs + #:env-vars env-vars + #:system system + #:inputs `((,guile) + (,builder) + ,@(if modules + `((,modules) (,compiled) ,@inputs) + inputs) + ,@(match graphs + (((_ . inputs) ...) inputs) + (_ '()))) + #:hash hash #:hash-algo hash-algo #:recursive? recursive? + #:references-graphs (and=> graphs graphs-file-names) + #:allowed-references allowed + #:local-build? local-build?)))) (define* (gexp-inputs exp #:optional (references gexp-references)) "Return the input list for EXP, using REFERENCES to get its list of diff --git a/tests/gexp.scm b/tests/gexp.scm index 68c470d3b6..0b189b570b 100644 --- a/tests/gexp.scm +++ b/tests/gexp.scm @@ -249,6 +249,23 @@ (equal? refs (list (dirname (dirname guile)))) (equal? refs2 (list file)))))) +(test-assertm "gexp->derivation vs. grafts" + (mlet* %store-monad ((p0 -> (dummy-package "dummy" + (arguments + '(#:implicit-inputs? #f)))) + (r -> (package (inherit p0) (name "DuMMY"))) + (p1 -> (package (inherit p0) (replacement r))) + (exp0 -> (gexp (frob (ungexp p0) (ungexp output)))) + (exp1 -> (gexp (frob (ungexp p1) (ungexp output)))) + (void (set-guile-for-build %bootstrap-guile)) + (drv0 (gexp->derivation "t" exp0)) + (drv1 (gexp->derivation "t" exp1)) + (drv1* (gexp->derivation "t" exp1 #:graft? #f))) + (return (and (not (string=? (derivation->output-path drv0) + (derivation->output-path drv1))) + (string=? (derivation->output-path drv0) + (derivation->output-path drv1*)))))) + (test-assertm "gexp->derivation, composed gexps" (mlet* %store-monad ((exp0 -> (gexp (begin (mkdir (ungexp output)) -- cgit v1.2.3 From cc9b70d3ea708e4364b0a090d8a6efebabd8c0e9 Mon Sep 17 00:00:00 2001 From: Eric Bavier Date: Fri, 20 Feb 2015 16:02:43 -0600 Subject: import: cpan: Update tests for dependency handling. * tests/cpan.scm (test-json): Remove core module dependencies. [cpan->guix-package]: Add mock url handling for module api. Adjust expected native-inputs and license. --- tests/cpan.scm | 14 +++----------- 1 file changed, 3 insertions(+), 11 deletions(-) (limited to 'tests') diff --git a/tests/cpan.scm b/tests/cpan.scm index af7b36e684..2f9513519e 100644 --- a/tests/cpan.scm +++ b/tests/cpan.scm @@ -28,15 +28,8 @@ "{ \"metadata\" : { \"prereqs\" : { - \"configure\" : { - \"requires\" : { - \"ExtUtils::MakeMaker\" : \"0\", - \"Module::Build\" : \"0.28\" - } - }, \"runtime\" : { \"requires\" : { - \"Getopt::Std\" : \"0\", \"Test::Script\" : \"1.05\", } } @@ -70,6 +63,8 @@ (match url ("http://api.metacpan.org/release/Foo-Bar" test-json) + ("http://api.metacpan.org/module/Test::Script" + "{ \"distribution\" : \"Test-Script\" }") ("http://example.com/Foo-Bar-0.1.tar.gz" test-source) (_ (error "Unexpected URL: " url)))))))) @@ -85,16 +80,13 @@ ('base32 (? string? hash))))) ('build-system 'perl-build-system) - ('native-inputs - ('quasiquote - (("perl-module-build" ('unquote 'perl-module-build))))) ('inputs ('quasiquote (("perl-test-script" ('unquote 'perl-test-script))))) ('home-page "http://search.cpan.org/dist/Foo-Bar") ('synopsis "Fizzle Fuzz") ('description 'fill-in-yourself!) - ('license 'gpl1+)) + ('license (package-license perl))) (string=? (bytevector->nix-base32-string (call-with-input-string test-source port-sha256)) hash)) -- cgit v1.2.3 From 12d720fd1a9c43019f2d5afa051b45c7633b3ab0 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Mon, 23 Feb 2015 23:41:26 +0100 Subject: tests: Factorize the network reachability test. * guix/tests.scm (network-reachable?): New procedure. * tests/builders.scm (network-reachable?): Remove. Replace references to it with calls to the new 'network-reachable?' procedure. * tests/derivations.scm (%coreutils): Use 'network-reachable?' instead of 'getaddrinfo'. * tests/packages.scm: Likewise. * tests/union.scm: Likewise. --- guix/tests.scm | 5 +++++ tests/builders.scm | 7 ++----- tests/derivations.scm | 2 +- tests/packages.scm | 6 ++---- tests/union.scm | 6 ++---- 5 files changed, 12 insertions(+), 14 deletions(-) (limited to 'tests') diff --git a/guix/tests.scm b/guix/tests.scm index 1171bb4dfb..d004a50a36 100644 --- a/guix/tests.scm +++ b/guix/tests.scm @@ -31,6 +31,7 @@ #:export (open-connection-for-tests random-text random-bytevector + network-reachable? mock %substitute-directory with-derivation-narinfo @@ -77,6 +78,10 @@ (loop (1+ i))) bv)))) +(define (network-reachable?) + "Return true if we can reach the Internet." + (false-if-exception (getaddrinfo "www.gnu.org" "80" AI_NUMERICSERV))) + (define-syntax-rule (mock (module proc replacement) body ...) "Within BODY, replace the definition of PROC from MODULE with the definition given by REPLACEMENT." diff --git a/tests/builders.scm b/tests/builders.scm index e5acc3e038..3c2a3edc8e 100644 --- a/tests/builders.scm +++ b/tests/builders.scm @@ -56,16 +56,13 @@ (package-native-search-paths package))) (@@ (gnu packages commencement) %boot0-inputs))) -(define network-reachable? - (false-if-exception (getaddrinfo "www.gnu.org" "80" AI_NUMERICSERV))) - (define url-fetch* (store-lower url-fetch)) (test-begin "builders") -(unless network-reachable? (test-skip 1)) +(unless (network-reachable?) (test-skip 1)) (test-assert "url-fetch" (let* ((url '("http://ftp.gnu.org/gnu/hello/hello-2.8.tar.gz" "ftp://ftp.gnu.org/gnu/hello/hello-2.8.tar.gz")) @@ -97,7 +94,7 @@ (test-assert "gnu-build-system" (build-system? gnu-build-system)) -(unless network-reachable? (test-skip 1)) +(unless (network-reachable?) (test-skip 1)) (test-assert "gnu-build" (let* ((url "http://ftp.gnu.org/gnu/hello/hello-2.8.tar.gz") (hash (nix-base32-string->bytevector diff --git a/tests/derivations.scm b/tests/derivations.scm index e23bdeed77..72d253c465 100644 --- a/tests/derivations.scm +++ b/tests/derivations.scm @@ -463,7 +463,7 @@ (define %coreutils (false-if-exception - (and (getaddrinfo "www.gnu.org" "80" AI_NUMERICSERV) + (and (network-reachable?) (or (package-derivation %store %bootstrap-coreutils&co) (nixpkgs-derivation "coreutils"))))) diff --git a/tests/packages.scm b/tests/packages.scm index 851520b343..5725b0a8a9 100644 --- a/tests/packages.scm +++ b/tests/packages.scm @@ -176,8 +176,7 @@ (and (direct-store-path? source) (string-suffix? "utils.scm" source)))) -(unless (false-if-exception (getaddrinfo "www.gnu.org" "80" AI_NUMERICSERV)) - (test-skip 1)) +(unless (network-reachable?) (test-skip 1)) (test-equal "package-source-derivation, snippet" "OK" (let* ((file (search-bootstrap-binary "guile-2.0.9.tar.xz" @@ -532,8 +531,7 @@ (%current-target-system "foo64-linux-gnu")) (equal? drv (bag->derivation %store bag)))))) -(unless (false-if-exception (getaddrinfo "www.gnu.org" "80" AI_NUMERICSERV)) - (test-skip 1)) +(unless (network-reachable?) (test-skip 1)) (test-assert "GNU Make, bootstrap" ;; GNU Make is the first program built during bootstrap; we choose it ;; here so that the test doesn't last for too long. diff --git a/tests/union.scm b/tests/union.scm index 7e55670b86..22ba67ce99 100644 --- a/tests/union.scm +++ b/tests/union.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2012, 2013, 2014 Ludovic Courtès +;;; Copyright © 2012, 2013, 2014, 2015 Ludovic Courtès ;;; ;;; This file is part of GNU Guix. ;;; @@ -84,9 +84,7 @@ (call-with-input-file "bar/two" get-string-all)) (not (file-exists? "bar/one"))))))) -(test-skip (if (and %store - (false-if-exception - (getaddrinfo "www.gnu.org" "80" AI_NUMERICSERV))) +(test-skip (if (and %store (network-reachable?)) 0 1)) -- cgit v1.2.3 From b69c5c2ced1e41fdb5c2e747b1fb3a338ca63768 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Mon, 23 Feb 2015 23:52:28 +0100 Subject: tests: Skip tests that would fail due to the shebang length. MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit Reported by Daniel Kochmański . Fixes . * guix/tests.scm (shebang-too-long?): New procedure. * tests/builders.scm ("gnu-build"): Conditionalize on not (shebang-too-long?). * tests/packages.scm ("GNU Make, bootstrap"): Likewise. * tests/guix-package.sh (shebang_not_too_long): New function. Use it to determine whether to build 'gnu-make-boot0'. --- guix/tests.scm | 12 ++++++++++++ tests/builders.scm | 3 ++- tests/guix-package.sh | 13 +++++++++++-- tests/packages.scm | 3 ++- 4 files changed, 27 insertions(+), 4 deletions(-) (limited to 'tests') diff --git a/guix/tests.scm b/guix/tests.scm index d004a50a36..0896e842da 100644 --- a/guix/tests.scm +++ b/guix/tests.scm @@ -32,6 +32,7 @@ random-text random-bytevector network-reachable? + shebang-too-long? mock %substitute-directory with-derivation-narinfo @@ -185,6 +186,17 @@ CONTENTS." (delete-file (string-append dir "/example.out")) (delete-file (string-append dir "/example.nar"))))) +(define (shebang-too-long?) + "Return true if the typical shebang in the current store would exceed +Linux's static limit---the BINPRM_BUF_SIZE constant, normally 128 characters +all included." + (define shebang + (string-append "#!" (%store-prefix) "/" + (make-string 32 #\a) + "-bootstrap-binaries-0/bin/bash\0")) + + (> (string-length shebang) 128)) + (define-syntax with-derivation-substitute (syntax-rules (sha256 =>) "Evaluate BODY in a context where DRV is substitutable with the given diff --git a/tests/builders.scm b/tests/builders.scm index 3c2a3edc8e..a7c3e42830 100644 --- a/tests/builders.scm +++ b/tests/builders.scm @@ -94,7 +94,8 @@ (test-assert "gnu-build-system" (build-system? gnu-build-system)) -(unless (network-reachable?) (test-skip 1)) +(when (or (not (network-reachable?)) (shebang-too-long?)) + (test-skip 1)) (test-assert "gnu-build" (let* ((url "http://ftp.gnu.org/gnu/hello/hello-2.8.tar.gz") (hash (nix-base32-string->bytevector diff --git a/tests/guix-package.sh b/tests/guix-package.sh index d4917bbf90..94cf927420 100644 --- a/tests/guix-package.sh +++ b/tests/guix-package.sh @@ -28,6 +28,14 @@ readlink_base () basename `readlink "$1"` } +# Return true if a typical shebang in the store would not exceed Linux's +# default static limit. +shebang_not_too_long () +{ + test `echo $NIX_STORE_DIR/aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa-bootstrap-binaries-0/bin/bash | wc -c` \ + -lt 128 +} + module_dir="t-guix-package-$$" profile="t-profile-$$" rm -f "$profile" @@ -55,8 +63,9 @@ test -f "$profile/bin/guile" guix package --search-paths -p "$profile" test "`guix package --search-paths -p "$profile" | wc -l`" = 0 -# Check whether we have network access. -if guile -c '(getaddrinfo "www.gnu.org" "80" AI_NUMERICSERV)' 2> /dev/null +# Check whether we have network access and an acceptable shebang length. +if guile -c '(getaddrinfo "www.gnu.org" "80" AI_NUMERICSERV)' 2> /dev/null \ + && shebang_not_too_long then boot_make="(@@ (gnu packages commencement) gnu-make-boot0)" boot_make_drv="`guix build -e "$boot_make" | grep -v -e -debug`" diff --git a/tests/packages.scm b/tests/packages.scm index 5725b0a8a9..d6371b3b49 100644 --- a/tests/packages.scm +++ b/tests/packages.scm @@ -531,7 +531,8 @@ (%current-target-system "foo64-linux-gnu")) (equal? drv (bag->derivation %store bag)))))) -(unless (network-reachable?) (test-skip 1)) +(when (or (not (network-reachable?)) (shebang-too-long?)) + (test-skip 1)) (test-assert "GNU Make, bootstrap" ;; GNU Make is the first program built during bootstrap; we choose it ;; here so that the test doesn't last for too long. -- cgit v1.2.3 From b3f213893b67620840597213b8f46af1ddfb4934 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Wed, 25 Feb 2015 23:31:51 +0100 Subject: ui: Factorize command-line + env. var. option parsing. * guix/ui.scm (%default-argument-handler, parse-command-line): New procedures. (environment-build-options): Make private. * guix/scripts/archive.scm (guix-archive)[parse-options, parse-options-from]: Remove. Use 'parse-command-line' instead. * guix/scripts/build.scm (guix-build): Likewise. * guix/scripts/environment.scm (guix-environment): Likewise. * guix/scripts/package.scm (guix-package): Likewise. * guix/scripts/system.scm (guix-system): Likewise. * tests/ui.scm (with-environment-variable): New macro. ("parse-command-line"): New test. --- guix/scripts/archive.scm | 16 +--------------- guix/scripts/build.scm | 17 ++--------------- guix/scripts/environment.scm | 18 ++++-------------- guix/scripts/package.scm | 24 +++++++----------------- guix/scripts/system.scm | 34 +++++++++++++--------------------- guix/ui.scm | 28 +++++++++++++++++++++++++++- tests/ui.scm | 31 +++++++++++++++++++++++++++++++ 7 files changed, 85 insertions(+), 83 deletions(-) (limited to 'tests') diff --git a/guix/scripts/archive.scm b/guix/scripts/archive.scm index b85119a0ff..ea6801a6eb 100644 --- a/guix/scripts/archive.scm +++ b/guix/scripts/archive.scm @@ -297,20 +297,6 @@ the input port." (cut write-acl acl <>))))) (define (guix-archive . args) - (define (parse-options) - ;; Return the alist of option values. - (append (parse-options-from args) - (parse-options-from (environment-build-options)))) - - (define (parse-options-from args) - ;; Actual parsing takes place here. - (args-fold* args %options - (lambda (opt name arg result) - (leave (_ "~A: unrecognized option~%") name)) - (lambda (arg result) - (alist-cons 'argument arg result)) - %default-options)) - (define (lines port) ;; Return lines read from PORT. (let loop ((line (read-line port)) @@ -324,7 +310,7 @@ the input port." ;; Ask for absolute file names so that .drv file names passed from the ;; user to 'read-derivation' are absolute when it returns. (with-fluids ((%file-port-name-canonicalization 'absolute)) - (let ((opts (parse-options))) + (let ((opts (parse-command-line args %options (list %default-options)))) (cond ((assoc-ref opts 'generate-key) => generate-key-pair) diff --git a/guix/scripts/build.scm b/guix/scripts/build.scm index 07ced30484..370c2a37ff 100644 --- a/guix/scripts/build.scm +++ b/guix/scripts/build.scm @@ -405,25 +405,12 @@ arguments with packages that use the specified source." ;;; (define (guix-build . args) - (define (parse-options) - ;; Return the alist of option values. - (append (parse-options-from args) - (parse-options-from (environment-build-options)))) - - (define (parse-options-from args) - ;; Actual parsing takes place here. - (args-fold* args %options - (lambda (opt name arg result) - (leave (_ "~A: unrecognized option~%") name)) - (lambda (arg result) - (alist-cons 'argument arg result)) - %default-options)) - (with-error-handling ;; Ask for absolute file names so that .drv file names passed from the ;; user to 'read-derivation' are absolute when it returns. (with-fluids ((%file-port-name-canonicalization 'absolute)) - (let* ((opts (parse-options)) + (let* ((opts (parse-command-line args %options + (list %default-options))) (store (open-connection)) (drv (options->derivations store opts)) (roots (filter-map (match-lambda diff --git a/guix/scripts/environment.scm b/guix/scripts/environment.scm index bb2ce53caf..c96ca351c4 100644 --- a/guix/scripts/environment.scm +++ b/guix/scripts/environment.scm @@ -217,22 +217,12 @@ packages." ;; Entry point. (define (guix-environment . args) - (define (parse-options) - ;; Return the alist of option values. - (append (parse-options-from args) - (parse-options-from (environment-build-options)))) - - (define (parse-options-from args) - ;; Actual parsing takes place here. - (args-fold* args %options - (lambda (opt name arg result) - (leave (_ "~A: unrecognized option~%") name)) - (lambda (arg result) - (alist-cons 'package arg result)) - %default-options)) + (define (handle-argument arg result) + (alist-cons 'package arg result)) (with-store store - (let* ((opts (parse-options)) + (let* ((opts (parse-command-line args %options (list %default-options) + #:argument-handler handle-argument)) (pure? (assoc-ref opts 'pure)) (command (assoc-ref opts 'exec)) (inputs (packages->transitive-inputs diff --git a/guix/scripts/package.scm b/guix/scripts/package.scm index fc116d8f6c..c27207f29a 100644 --- a/guix/scripts/package.scm +++ b/guix/scripts/package.scm @@ -692,22 +692,11 @@ doesn't need it." ;;; (define (guix-package . args) - (define (parse-options) - ;; Return the alist of option values. - (append (parse-options-from args) - (parse-options-from (environment-build-options)))) - - (define (parse-options-from args) - ;; Actual parsing takes place here. - (args-fold* args %options - (lambda (opt name arg result arg-handler) - (leave (_ "~A: unrecognized option~%") name)) - (lambda (arg result arg-handler) - (if arg-handler - (arg-handler arg result) - (leave (_ "~A: extraneous argument~%") arg))) - %default-options - #f)) + (define (handle-argument arg result arg-handler) + ;; Process non-option argument ARG by calling back ARG-HANDLER. + (if arg-handler + (arg-handler arg result) + (leave (_ "~A: extraneous argument~%") arg))) (define (ensure-default-profile) ;; Ensure the default profile symlink and directory exist and are @@ -987,7 +976,8 @@ more information.~%")) (_ #f)))) - (let ((opts (parse-options))) + (let ((opts (parse-command-line args %options (list %default-options #f) + #:argument-handler handle-argument))) (with-error-handling (or (process-query opts) (parameterize ((%store (open-connection))) diff --git a/guix/scripts/system.scm b/guix/scripts/system.scm index b15bb8bb0d..1b64e6fb92 100644 --- a/guix/scripts/system.scm +++ b/guix/scripts/system.scm @@ -487,26 +487,15 @@ Build the operating system declared in FILE according to ACTION.\n")) ;;; (define (guix-system . args) - (define (parse-options) - ;; Return the alist of option values. - (append (parse-options-from args) - (parse-options-from (environment-build-options)))) - - (define (parse-options-from args) - ;; Actual parsing takes place here. - (args-fold* args %options - (lambda (opt name arg result) - (leave (_ "~A: unrecognized option~%") name)) - (lambda (arg result) - (if (assoc-ref result 'action) - (alist-cons 'argument arg result) - (let ((action (string->symbol arg))) - (case action - ((build vm vm-image disk-image reconfigure init) - (alist-cons 'action action result)) - (else (leave (_ "~a: unknown action~%") - action)))))) - %default-options)) + (define (parse-sub-command arg result) + ;; Parse sub-command ARG and augment RESULT accordingly. + (if (assoc-ref result 'action) + (alist-cons 'argument arg result) + (let ((action (string->symbol arg))) + (case action + ((build vm vm-image disk-image reconfigure init) + (alist-cons 'action action result)) + (else (leave (_ "~a: unknown action~%") action)))))) (define (match-pair car) ;; Return a procedure that matches a pair with CAR. @@ -534,7 +523,10 @@ Build the operating system declared in FILE according to ACTION.\n")) args)) (with-error-handling - (let* ((opts (parse-options)) + (let* ((opts (parse-command-line args %options + (list %default-options) + #:argument-handler + parse-sub-command)) (args (option-arguments opts)) (file (first args)) (action (assoc-ref opts 'action)) diff --git a/guix/ui.scm b/guix/ui.scm index 382b5b1e0d..09cb6f48ff 100644 --- a/guix/ui.scm +++ b/guix/ui.scm @@ -66,7 +66,7 @@ string->generations string->duration args-fold* - environment-build-options + parse-command-line run-guix-command program-name guix-warning-port @@ -754,6 +754,32 @@ reporting." "Return additional build options passed as environment variables." (arguments-from-environment-variable "GUIX_BUILD_OPTIONS")) +(define %default-argument-handler + ;; The default handler for non-option command-line arguments. + (lambda (arg result) + (alist-cons 'argument arg result))) + +(define* (parse-command-line args options seeds + #:key + (argument-handler %default-argument-handler)) + "Parse the command-line arguments ARGS as well as arguments passed via the +'GUIX_BUILD_OPTIONS' environment variable according to OPTIONS (a list of +SRFI-37 options) and return the result, seeded by SEEDS. +Command-line options take precedence those passed via 'GUIX_BUILD_OPTIONS'. + +ARGUMENT-HANDLER is called for non-option arguments, like the 'operand-proc' +parameter of 'args-fold'." + (define (parse-options-from args) + ;; Actual parsing takes place here. + (apply args-fold* args options + (lambda (opt name arg . rest) + (leave (_ "~A: unrecognized option~%") name)) + argument-handler + seeds)) + + (append (parse-options-from args) + (parse-options-from (environment-build-options)))) + (define (show-guix-usage) (format (current-error-port) (_ "Try `guix --help' for more information.~%")) diff --git a/tests/ui.scm b/tests/ui.scm index 25fc709431..c71fc71cc1 100644 --- a/tests/ui.scm +++ b/tests/ui.scm @@ -22,6 +22,8 @@ #:use-module (guix profiles) #:use-module (guix store) #:use-module (guix derivations) + #:use-module ((guix scripts build) + #:select (%standard-build-options)) #:use-module (srfi srfi-1) #:use-module (srfi srfi-11) #:use-module (srfi srfi-19) @@ -52,9 +54,34 @@ interface, and powerful string processing.") (item "/gnu/store/...") (output "out"))) +(define-syntax-rule (with-environment-variable variable value body ...) + "Run BODY with VARIABLE set to VALUE." + (let ((orig (getenv variable))) + (dynamic-wind + (lambda () + (setenv variable value)) + (lambda () + body ...) + (lambda () + (if orig + (setenv variable orig) + (unsetenv variable)))))) + (test-begin "ui") +(test-equal "parse-command-line" + '((argument . "bar") (argument . "foo") + (cores . 10) ;takes precedence + (substitutes? . #f) (keep-failed? . #t) + (max-jobs . 77) (cores . 42)) + + (with-environment-variable "GUIX_BUILD_OPTIONS" "-c 42 -M 77" + (parse-command-line '("--keep-failed" "--no-substitutes" + "--cores=10" "foo" "bar") + %standard-build-options + (list '())))) + (test-assert "fill-paragraph" (every (lambda (column) (every (lambda (width) @@ -246,3 +273,7 @@ Second line" 24)) (exit (= (test-runner-fail-count (test-runner-current)) 0)) + +;;; Local Variables: +;;; eval: (put 'with-environment-variable 'scheme-indent-function 2) +;;; End: -- cgit v1.2.3 From cf6ce3e6ef96abc36a40293b2d9f732d462d2a94 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Thu, 26 Feb 2015 00:00:04 +0100 Subject: ui: Honor --no-* options passed via $GUIX_BUILD_OPTIONS. Reported by Alex Kost at . * guix/ui.scm (parse-command-line)[parse-options-from]: Add 'seeds' parameter. Thread the result of the first 'parse-options-from' call to the second. --- guix/ui.scm | 10 +++++++--- tests/ui.scm | 9 +++++++++ 2 files changed, 16 insertions(+), 3 deletions(-) (limited to 'tests') diff --git a/guix/ui.scm b/guix/ui.scm index 09cb6f48ff..9558d38ca8 100644 --- a/guix/ui.scm +++ b/guix/ui.scm @@ -769,7 +769,7 @@ Command-line options take precedence those passed via 'GUIX_BUILD_OPTIONS'. ARGUMENT-HANDLER is called for non-option arguments, like the 'operand-proc' parameter of 'args-fold'." - (define (parse-options-from args) + (define (parse-options-from args seeds) ;; Actual parsing takes place here. (apply args-fold* args options (lambda (opt name arg . rest) @@ -777,8 +777,12 @@ parameter of 'args-fold'." argument-handler seeds)) - (append (parse-options-from args) - (parse-options-from (environment-build-options)))) + (call-with-values + (lambda () + (parse-options-from (environment-build-options) seeds)) + (lambda seeds + ;; ARGS take precedence over what the environment variable specifies. + (parse-options-from args seeds)))) (define (show-guix-usage) (format (current-error-port) diff --git a/tests/ui.scm b/tests/ui.scm index c71fc71cc1..1478fe213e 100644 --- a/tests/ui.scm +++ b/tests/ui.scm @@ -82,6 +82,15 @@ interface, and powerful string processing.") %standard-build-options (list '())))) +(test-equal "parse-command-line and --no options" + '((argument . "foo") + (substitutes? . #f)) ;takes precedence + + (with-environment-variable "GUIX_BUILD_OPTIONS" "--no-substitutes" + (parse-command-line '("foo") + %standard-build-options + (list '((substitutes? . #t)))))) + (test-assert "fill-paragraph" (every (lambda (column) (every (lambda (width) -- cgit v1.2.3