diff options
| -rw-r--r-- | guix/scripts/archive.scm | 16 | ||||
| -rw-r--r-- | guix/scripts/build.scm | 17 | ||||
| -rw-r--r-- | guix/scripts/environment.scm | 18 | ||||
| -rw-r--r-- | guix/scripts/package.scm | 24 | ||||
| -rw-r--r-- | guix/scripts/system.scm | 34 | ||||
| -rw-r--r-- | guix/ui.scm | 28 | ||||
| -rw-r--r-- | tests/ui.scm | 31 |
7 files changed, 85 insertions, 83 deletions
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: |