rekahsoft
/
guix
1
1
Fork 0
Code Issues Pull Requests Releases Wiki Activity

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.
This commit is contained in:
Ludovic Courtès 2015-02-25 23:31:51 +01:00
parent 72bfebf58d
commit b3f213893b
7 changed files with 85 additions and 83 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

16
guix/scripts/archive.scm
View File

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

17
guix/scripts/build.scm
View File

@ -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

18
guix/scripts/environment.scm
View File

@ -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

24
guix/scripts/package.scm
View File

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

34
guix/scripts/system.scm
View File

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

28
guix/ui.scm
View File

@ -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.~%"))

31
tests/ui.scm
View File

@ -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: