dmbcs/guile
1
0
Fork 0
Code Issues Pull requests Projects Releases Packages Wiki Activity Actions

Introduce (ice-9 command-line-processor) module.

Browse source 
* modules/ice-9/command-line-processor.scm:  new file
* modules/Makefile.am:  build command-line-processor.scm
* test-suite/tests/command-line-processor.test:  new file
* test-suite/Makefile.am:  run command-line-processor tests
This commit is contained in:
Dale Mellor 2020-04-29 22:15:47 +01:00
commit 661b23df67
4 changed files with 803 additions and 0 deletions
Download patch file Download diff file Expand all files Collapse all files

1
module/Makefile.am
View file

@ -65,6 +65,7 @@ SOURCES = \
ice-9/futures.scm \
ice-9/gap-buffer.scm \
ice-9/getopt-long.scm \
ice-9/command-line-processor.scm \
ice-9/hash-table.scm \
ice-9/hcons.scm \
ice-9/history.scm \

646
module/ice-9/command-line-processor.scm Normal file
View file

@ -0,0 +1,646 @@
;;;; command-line-processor.scm --- command-line options processing
;;;; -*- scheme -*-
;;;;
;;;; Copyright (C) 1998, 2001, 2006, 2009, 2011, 2020
;;;; Free Software Foundation, Inc.
;;;;
;;;; This library is free software; you can redistribute it and/or
;;;; modify it under the terms of the GNU Lesser General Public
;;;; License as published by the Free Software Foundation; either
;;;; version 3 of the License, or (at your option) any later version.
;;;;
;;;; This library is distributed in the hope that it will be useful,
;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
;;;; Lesser General Public License for more details.
;;;;
;;;; You should have received a copy of the GNU Lesser General Public
;;;; License along with this library; if not, write to the Free Software
;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
;;;; 02110-1301 USA
;;; Author: Dale Mellor <guile-qf1qmg@rdmp.org> May, 2020
;;; Commentary:
;;; Where the Guile (ice-9 getopt-long) module, modelled after the GNU C
;;; libraryʼs ‘getopt_long’ function, allows an application to construct
;;; a grammar prescribing the decomposition of the command-line options,
;;; this module, inspired by the C libraryʼs ‘argp’ parser, gives the
;;; application a higher-level paradigm in which the command-line
;;; processing is specified declaratively. This includes enough of the
;;; application meta-data and some fragmentary help strings for the
;;; completely automatic generation of responses to GNU-standard
;;; ‘--help’, ‘--version’ and ‘--usage’ options, thus alleviating the
;;; need of the application itself to deal with these things.
;;;
;;; The module has three specific aims.
;;;
;;; 1) Provide higher-level declarative interface, easier to use.
;;;
;;; 2) Automatically respond to --help, --version and --usage
;;; options.
;;;
;;; 3) Allow amalgamation of specifications, so that an application
;;; can mix in requirements from modules into its own option
;;; specification--THIS IS NOT CURRENTLY IMPLEMENTED.
;;;
;;; There is just one function which needs to be called to get all of
;;; this functionality: it is ‘process-command-line’, and has the side
;;; effect that new variable bindings appear in the current module
;;; corresponding to all the options. For example, if a declared option
;;; is ‘--do-this’, then a variable called, literally, ‘--do-this’ will
;;; be injected in the current namespace and will have the value
;;; provided on the command-line, or simply #t or #f to indicate whether
;;; or not that option was present on the command line.
;;;
;;; Alternatively, it is possible to create and compose the
;;; specification in separate steps, and then call the above method with
;;; the results. The functions ‘command-line-specification’ and
;;; ‘merge-command-line-specifications’ are provided to this end.
;;; (process-command-line COMMAND-LINE SPECIFICATION)
;;; Process the COMMAND-LINE according to the application SPECIFICATION.
;;;
;;; COMMAND-LINE is a list of strings, such as that returned from the
;;; core ‘command-line’ function.
;;;
;;; SPECIFICATION is a form holding a space-separated mix of selection
;;; words followed by their respective declarations. The selection
;;; words are ‘application’, ‘author’, ‘bug-address’, ‘copyright’,
;;; ‘help-preamble’, ‘help-postamble’, ‘license’, ‘option’, ‘usage’ and
;;; ‘version’, and can appear in any order.
;;;
;;; ‘application’ should be followed by a string: the name of the
;;; application with possibly the package name in
;;; parentheses afterwards
;;; ‘author’ should be followed by a string giving the name of one of
;;; the packageʼs authors. This selection word can be
;;; repeated as many times as necessary to provide the names
;;; of all authors.
;;; ‘bug-address’ should be followed by a string giving the URL of a
;;; contact-point for sending bug reports, such as an
;;; e-mail address or web address of bug-tracking system
;;; interface
;;; ‘copyright’ should be followed by a string containing a list of
;;; years and an entity to whom the copyright is assigned.
;;; This may be repeated to list other assignees
;;; ‘help-preamble’ should be followed by a number of strings which
;;; make up a short paragraph of text displayed before
;;; a full list of the available program options
;;; ‘help-postamble’, like the preamble, is followed by strings which
;;; make up a paragraph of text, shown after the list
;;; of options
;;; ‘license’ can be followed by one of the words ‘GPLv3’ [this is
;;; currently the only standard choice implemented], or else
;;; a string which briefly gives out the terms of the license
;;; ‘option’ is followed by an option declaration, described below
;;; ‘usage’ is followed by a string describing the usage of the
;;; application on one line
;;; ‘version’ is followed by a string providing the current version
;;; number of this program
;;;
;;; The ‘option’ declaration is followed by another form bracketed by
;;; parentheses and holding a space-separated mix of declarations (order
;;; irrelevant).
;;;
;;; A word beginning with two hyphens, an optional exclamation point,
;;; alphabetic letters, an optional equals sign, and an optional
;;; further word. There must be exactly one of these, and they
;;; determine the long name of the option. An exclamation point
;;; indicates that the option MUST appear on the command line, an
;;; equals indicates that the option MUST have a value unless it is
;;; followed in the specification by a value, in which case the value
;;; on the command-line is optional and the one in the specification
;;; will be taken as the default when not given on the command line.
;;;
;;; A word comprised of one hyphen and one letter. There can be
;;; exactly zero or one of these, and it declares that the option has
;;; this short form available on the command-line. As a very special
;;; exception: if you want to use ‘-i’ as an option, it must be
;;; specified with the identifier ‘short-i’ (a naked /-i/ is read as
;;; a complex number); ditto ‘short-I’ for ‘-I’.
;;;
;;; A number of strings which are catenated together to provide a
;;; short, succinct description of the option. These strings should
;;; be approximately half the width of a page, i.e. about 40
;;; characters.
;;;
;;; A function which will be used as a predicate to decide if a value
;;; is allowable for this option. There should be zero or one of
;;; these.
;;;
;;; For the precise presentation of options on the command-line, the
;;; reader should refer to the description of the ‘getopt-long’ module,
;;; which underlies the present one.
;;;
;;; At this point a short example is in order. The main entry point for
;;; the GNU Mcron program has as its first clause
;;;
;;; (process-command-line (command-line)
;;; application "mcron"
;;; version "1.4"
;;; usage "[OPTIONS]... [FILES]..."
;;; help-preamble
;;; "Run an mcron process according to the specifications in the FILE... "
;;; "(`-' for standard input), or use all the files in ~/.config/cron "
;;; "(or the deprecated ~/.cron) with .guile or .vixie extensions.\n"
;;; "Note that --daemon and --schedule are mutually exclusive."
;;; option (--daemon -d
;;; "run as a daemon process")
;;; option (--stdin=guile -i (λ (in) (or (string=? in "guile")
;;; (string=? in "vixie")))
;;; "format of data passed as standard input or file "
;;; "arguments, 'guile' or 'vixie' (default guile)")
;;; option (--schedule=8 -s string->number
;;; "display the next N (or 8) jobs that will be run")
;;; help-postamble
;;; "Mandatory or optional arguments to long options are also mandatory or "
;;; "optional for any corresponding short options."
;;; bug-address "bug-mcron@gnu.org"
;;; copyright "2003, 2006, 2014, 2020 Free Software Foundation, Inc."
;;; license GPLv3)
;;;
;;; after which there are four new variable bindings in the present
;;; namespace: --daemon, --stdin, --schedule and --! (the latter holds
;;; all the command-line arguments that did not partake in option
;;; processing) whose values depend on the specific command-line options
;;; the end user furnished.
;;; (command-line-specification SPECIFICATION)
;;; Compiles an object which encapsulates the given SPECIFICATION.
;;;
;;; For details of how to give a SPECIFICATION, see the description of
;;; the full ‘process-command-line’ function above. The return from
;;; this method can be used in the partial version of
;;; ‘process-command-line’ described below, and in the following
;;; ‘merge-command-line-specifications’ function.
;;; (merge-command-line-specifications SPECIFICATION_OBJECT ...) Make a
;;; single specification object which embodies the amalgamation of all
;;; of the specification objects given as arguments.
;;;
;;; Order is important: if two option items specify the same short form
;;; for the option (a single letter), then only the first option will
;;; actually have that short form available at the command-line.
;;; Similarly, if two options have exactly the same name, the second (or
;;; later) ones will have a numerical digit appended to their name.
;;; (process-command-line COMMAND-LINE SPECIFICATION-OBJECT) Perform
;;; exactly the same function as the full ‘process-command-line’
;;; function described above, but takes a pre-made specification object
;;; produced using the two functions above.
;;; Bugs/To do
;;;
;;; 1) This stuff currently only works in the top-level module.
;;;
;;; 2) Want to be able to amalgamate command-line specifications from
;;; different modules. Will need to get to the bottom of the first
;;; issue before we can tackle this one (somehow need to put the
;;; --option variable bindings into the right places, or at least
;;; replicate them all in all modules which want to do some processing
;;; of the command line).
;;;
;;; 3) Want more license boilerplate text; currently we only have GPLv3.
;;; Code:
(define-module (ice-9 command-line-processor)
#:use-module (srfi srfi-1) ;; fold
#:use-module (srfi srfi-9) ;; Records
#:use-module (srfi srfi-9 gnu) ;; set/get-fields
#:use-module (ice-9 getopt-long)
#:use-module (ice-9 regex)
#:export (specific option item
obtain-getopt-long-results
process-getopt-long-results
;; These are the real public exports.
process-command-line
command-line-specification
merge-command-line-specifications))
(define-record-type <<specification>>
(make-specification- preamble postamble copyright authors options)
specification?
(name spec:name spec:set-name!)
(version spec:version spec:set-version!)
(usage spec:usage spec:set-usage!)
(preamble spec:preamble spec:set-preamble!)
(postamble spec:postamble spec:set-postamble!)
(bug-address spec:bugs spec:set-bugs!)
(copyright spec:copyright spec:set-copyright!)
(license spec:license spec:set-license!)
(authors spec:authors spec:set-authors!)
(options spec:options spec:set-all-options!))
(define (make-specification) (make-specification- '() '() '() '() '()))
(define-record-type <<option>>
(make-option- description)
option?
(name option:name option:set-name!)
(required? option:required?)
(short-letter option:short option:set-short!)
(value? option:value?)
(default option:default)
(description option:description option:set-description!)
(predicate option:predicate option:set-predicate!))
(define (make-option) (make-option- '()))
(define (has-option-short-form spec letter)
(if (not letter)
#f
(let loop ((o (spec:options spec)))
(cond ((null? o) #f)
((eq? letter (option:short (car o))) #t)
(else (loop (cdr o)))))))
(define (has-option-name spec name)
(let loop ((o (spec:options spec)))
(cond ((null? o) #f)
((string=? (option:name (car o)) name) #t)
(else (loop (cdr o))))))
(define (merge-command-line-specifications A . B)
"- Scheme Procedure: merge-command-line-specifications A B Append the
list of options in A with those in B, but drop any short-forms in B
which clash with existing ones, and if a long option name clashes then
append a number to make it unique. A and B will be mutilated in the
process, a new specification object will be returned."
(for-each (λ (b-spec)
(for-each (λ (b-option)
(when (has-option-short-form A (option:short b-option))
(option:set-short! b-option #f))
(when (has-option-name A (option:name b-option))
(let ((base-name (option:name b-option)))
(let loop ((count 1))
(let ((new-name (string-append base-name "-"
(number->string count))))
(if (has-option-name A new-name)
(loop (1+ count))
(option:set-name! b-option new-name))))))
(spec:set-all-options! A (append (spec:options A)
(list b-option))))
(spec:options b-spec)))
B)
A)
(define long-re (make-regexp "^--(!)?([a-zA-Z][-_0-9a-zA-Z]*)(=(.+)?)?$"))
(define short-re (make-regexp "^-[a-zA-Z]$"))
(define-syntax item ;; As in, an option item (long name, short form...).
(λ (x) (syntax-case x (short-i short-I)
;; No more work to do.
((item O) #'#t)
;; Next option is a string: take as description.
((item O desc args ...)
(string? (syntax->datum #'desc))
#'(begin (option:set-description! O (append (option:description O)
(list desc)))
(item O args ...)))
;; Next option is short-form.
((item O short-i args ...)
#`(begin (option:set-short! O #\i)
(item O args ...)))
((item O short-I args ...)
#`(begin (option:set-short! O #\I)
(item O args ...)))
((item O short args ...)
(and (identifier? #'short)
(regexp-exec short-re (symbol->string (syntax->datum #'short))))
#`(begin (option:set-short! O (string-ref (symbol->string 'short) 1))
(item O args ...)))
;; Next option is long-form.
((item O long args ...)
(and (identifier? #'long)
(regexp-exec long-re (symbol->string (syntax->datum #'long))))
#`(begin (let ((match (regexp-exec long-re
(symbol->string (syntax->datum #'long)))))
(set! O
(set-fields O
((option:name) (match:substring match 2))
((option:required?) (if (match:substring match 1) #t #f))
((option:value?)
(cond ((not (match:substring match 3)) #f)
((match:substring match 4) 'optional)
(else #t)))
((option:default) (match:substring match 4)))))
(item O args ...)))
;; Next option is a procedure: take as predicate.
((item O (lambda args ...) Args ...)
#'(begin (option:set-predicate! O (lambda args ...))
(item O Args ...)))
((item O pred args ...)
(and (identifier? #'pred)
;; (procedure? (primitive-eval (syntax->datum #'pred)))
)
#'(begin (option:set-predicate! O pred)
(item O args ...))))))
(define-syntax-rule (option args ...)
(let ((O (make-option))) (item O args ...) O))
(define-syntax specific
(λ (x) (syntax-case x (application author bug-address
copyright help-preamble help-postamble
license option usage
version)
((specific spec application A args ...)
(string? (syntax->datum #'A))
#'(begin (spec:set-name! spec A)
(specific spec args ...)))
((specific spec author A args ...)
(string? (syntax->datum #'A))
#'(begin (spec:set-author! spec (append (spec:authors spec)
(list A)))
(specific spec args ...)))
((specific spec bug-address B args ...)
(string? (syntax->datum #'B))
#'(begin (spec:set-bugs! spec B)
(specific spec args ...)))
((specific spec copyright C args ...)
(string? (syntax->datum #'C))
#'(begin (spec:set-copyright! spec (append (spec:copyright spec)
(list C)))
(specific spec args ...)))
((specific spec help-preamble id args ...)
(identifier? #'id)
#'(specific spec id args ...))
((specific spec help-preamble quotation args ...)
(string? (syntax->datum #'quotation))
#'(begin (spec:set-preamble! spec (append (spec:preamble spec)
(list quotation)))
(specific spec help-preamble args ...)))
((specific spec help-postamble id args ...)
(identifier? #'id)
#'(specific spec id args ...))
((specific spec help-postamble quotation args ...)
(string? (syntax->datum #'quotation))
#'(begin (spec:set-postamble! spec (append (spec:postamble spec)
(list quotation)))
(specific spec help-postamble args ...)))
((specific spec license L args ...)
(identifier? #'L)
#'(begin (spec:set-license! spec 'L)
(specific spec args ...)))
((specific spec license L args ...)
(string? (syntax->datum #'L))
#'(begin (spec:set-license! spec L)
(specific spec args ...)))
((specific spec option (args ...) Args ...)
#'(begin (spec:set-all-options! spec
(append (spec:options spec)
(list (option args ...))))
(specific spec Args ...)))
((specific spec usage U args ...)
(string? (syntax->datum #'U))
#'(begin (spec:set-usage! spec U)
(specific spec args ...)))
((specific spec version V args ...)
(string? (syntax->datum #'V))
#'(begin (spec:set-version! spec V)
(specific spec args ...)))
((specific spec) #'#t))))
(define-syntax-rule (command-line-specification args ...)
;; " - Scheme Procedure: command-line-specification ARGS ...
;; Furnish an application specification object with attributes specified in
;; ARGS followed by a number of values for the attribute. Please refer to
;; full documentation for a proper description of a specification object.
;; The attributes are
;; application: string: the formal name of this application. Must appear
;; exactly once.
;; author: string: the name of an author. May appear any number of times.
;; bug-address: string: The URI to which bug reports should be addressed.
;; May appear zero or one times.
;; copyright: string: list of years and owning entity. May appear any
;; number of times.
;; help-preamble: string: text to precede the list of options in a
;; response to the --help option. This attribute may appear any
;; number of times, and each occurrence can be followed by one or
;; more strings which will be assembled together into paragraphs.
;; help-postamble: string: text to succeed the list of options in a help
;; message. Same considerations apply as to ‘help-preamble’.
;; license: identifier or string: either the identifier ‘GPLv3’ or a
;; string describing the terms of the license.
;; option: (sub-form): the sub-form must contain one identifier composed
;; of two hyphens, an optional exclamation point, a token of
;; letters, numbers, underscore and hyphen, an optional equals
;; sign, and an optional word; the sub-form may have zero or one
;; identifiers composed of a hyphen and a single letter; any
;; number of strings which will be composed into a paragraph of
;; help for the option (these should be sized to half-line
;; lengths); and zero or one procedures which will be applied as a
;; predicate on allowable option values. Any number of these
;; option attributes may appear in the specification.
;; usage: string: a single line of text prototyping the command line.
;; Zero or one of these may appear.
;; version: string: the version number of this application. Zero or one
;; of these attributes may appear."
(let ((spec (make-specification)))
(specific spec args ...)
spec))
(define (version-string spec)
(with-output-to-string (λ ()
(display (if (string? (spec:name spec))
(spec:name spec)
(car (command-line))))
(when (string? (spec:version spec))
(display " ") (display (spec:version spec)) (newline))
(unless (null? (spec:copyright spec))
(display "Copyright © ")
(display (string-join (spec:copyright spec) "\n "))
(newline))
(cond ((eq? (spec:license spec) 'GPLv3)
(display (string-append
"License GPLv3+: GNU GPL version 3 or later "
"<https://gnu.org/licenses/gpl.html>.\nThis is "
"free software: you are free to change and "
"redistribute it.\nThere is NO WARRANTY, to the "
"extent permitted by law.\n")))
((string? (spec:license spec))
(display (spec:license spec)) (newline)))
(unless (null? (spec:authors spec))
(display (string-append "Written by "
(case (length (spec:authors spec))
((1 2) (string-join (spec:authors spec) " and "))
(else
(let loop ((a (cdr (spec:authors spec)))
(ret (car (spec:authors spec))))
(if (null? (cdr a))
(string-append ret " and " (car a))
(loop (cdr a) (string-append ret ", "
(car a)))))))
".\n"))))))
(define (usage-string spec)
(string-append "Usage: " (spec:name spec) " " (spec:usage spec) "\n"))
(define (help-string spec)
(with-output-to-string (λ ()
(display (usage-string spec))
(display (string-join (spec:preamble spec) "\n"))
(display "\n\n")
(let ((max-length (fold (λ (o r) (max r (string-length (option:name o))))
0
(spec:options spec))))
(for-each (λ (o)
(display " ")
(cond ((option:short o)
(display "-") (display (option:short o))
(case (option:value? o) ((#t) (display "N, "))
((optional) (display "[N], "))
(else (display ", "))))
(else (display " ")))
(display "--")
(display (option:name o))
(case (option:value? o) ((#t) (display "=N "))
((optional) (display "[=N]"))
(else (display " ")))
(display (make-string (- max-length
(string-length (option:name o)))
#\space))
(display " ")
(when (option:required? o) (display "*REQUIRED*: "))
(display (string-join (option:description o)
(string-append "\n"
(make-string max-length
#\space)
" ")))
(newline))
(spec:options spec)))
(newline)
(display (string-join (spec:postamble spec) "\n"))
(when (spec:bugs spec)
(display "\nSend bug reports to ")
(display (spec:bugs spec))
(display ".\n")))))
(define (make-getopt-long-input spec)
(map (λ (o)
(append (list (string->symbol (option:name o)))
(cond ((option:short o)
=> (λ (x) (list (list 'single-char x))))
(else '()))
(list (list 'required? (option:required? o)))
(list (list 'value (if (option:default o)
'optional
(option:value? o))))
(cond ((option:predicate o)
=> (λ (x) (list (list 'predicate x))))
(else '()))))
(spec:options spec)))
(define (obtain-getopt-long-results args spec)
(getopt-long args (make-getopt-long-input spec)))
(define (distill-getopt-long-results go-l spec)
(cons (cons "!" (option-ref go-l '() '()))
(map (λ (o)
(let ((g (option-ref go-l
(string->symbol (option:name o))
#f)))
(when (eq? g #t)
(case (string->symbol (option:name o))
((help) (display (help-string spec)) (exit 0))
((version) (display (version-string spec)) (exit 0))
((usage) (display (usage-string spec)) (exit 0))))
(cons (option:name o)
(if (and (eq? #t g)
(not (eq? #f (option:default o))))
(option:default o)
g))))
(spec:options spec))))
(define (process-getopt-long-results go-l spec)
(for-each (λ (option)
(module-define!
(current-module)
(string->symbol (string-append "--" (car option)))
(cdr option)))
(distill-getopt-long-results go-l spec)))
(define-syntax process-command-line
;; "- Scheme Procedure: process-command-line COMMAND-LINE SPECS [...]
;; Process the COMMAND-LINE according to the SPECS, extracting options and
;; their values, dealing with --help, --version and --usage requests. The
;; procedure has no return values, but has the side effect of creating
;; variable bindings in the current module corresponding to the long form
;; of the options, plus a variable called ‘--!’ which gets a list of all
;; the arguments on the command-line which did not participate in option
;; processing.
;; The COMMAND-LINE is a list of strings, starting with the name of the
;; program and containing all the tokens passed to the program on the
;; command line, such as returned from the core ‘command-line’ procedure.
;; The SPECS should have been obtained with the
;; ‘command-line-specification’ procedure, or, as a short-cut, can be
;; supplied directly as arguments to this procedure."
(syntax-rules (GO)
((_ command-line specs GO)
(let ((S (merge-command-line-specifications
specs
(command-line-specification
option (-h --help "display this help and exit")
option (-V --version "output version information and exit")
option (-u --usage "show brief usage summary")))))
(process-getopt-long-results
(obtain-getopt-long-results command-line S)
S)))
((_ command-line specs)
(process-command-line command-line specs GO))
((_ command-line item ...)
(process-command-line
command-line
(command-line-specification item ...)))))

1
test-suite/Makefile.am
View file

@ -34,6 +34,7 @@ SCM_TESTS = tests/00-initial-env.test \
tests/c-api.test \
tests/chars.test \
tests/coding.test \
tests/command-line-processor.test \
tests/common-list.test \
tests/compiler.test \
tests/control.test \

155
test-suite/tests/command-line-processor.test Normal file
View file

@ -0,0 +1,155 @@
;;;; command-line-processor.test --- long options processing -*- scheme -*-
;;;;
;;;; Copyright (C) 2001, 2006, 2011 Free Software Foundation, Inc.
;;;;
;;;; This library is free software; you can redistribute it and/or
;;;; modify it under the terms of the GNU Lesser General Public
;;;; License as published by the Free Software Foundation; either
;;;; version 3 of the License, or (at your option) any later version.
;;;;
;;;; This library is distributed in the hope that it will be useful,
;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
;;;; Lesser General Public License for more details.
;;;;
;;;; You should have received a copy of the GNU Lesser General Public
;;;; License along with this library; if not, write to the Free Software
;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston,
;;;; MA 02110-1301 USA
;;; Author: Dale Mellor <guile-qf1qmg@rdmp.org> --- May 2020
(use-modules (test-suite lib)
(ice-9 command-line-processor)
(ice-9 regex))
(define-syntax-rule (pass-if-fatal-exception name exn exp)
(let ((port (open-output-string)))
(with-error-to-port port
(λ ()
(run-test
name #t
(λ ()
(catch (car exn)
(λ () exp #f)
(λ (k . args)
(let ((output (get-output-string port)))
(close-port port)
(if (string-match (cdr exn) output)
#t
(error "Unexpected output" output)))))))))))
(defmacro deferr (name-frag re)
(let ((name (symbol-append 'exception: name-frag)))
`(define ,name (cons 'quit ,re))))
(deferr no-such-option "no such option")
(deferr option-predicate-failed "option predicate failed")
(deferr option-does-not-support-arg "option does not support argument")
(deferr option-must-be-specified "option must be specified")
(deferr option-must-have-arg "option must be specified with argument")
(with-test-prefix "exported procs"
(pass-if "‘option’ defined" (defined? 'process-command-line)))
(with-test-prefix "extended mcron options"
(define stdin-predicate (λ (in) (or (string=? in "guile")
(string=? in "vixie"))))
(define app (command-line-specification
application "mcron"
version "1.4"
usage "[OPTIONS]... [FILES]..."
help-preamble
"Run an mcron process according to the specifications in the FILE... "
"(`-' for standard input), or use all the files in ~/.config/cron "
"(or the deprecated ~/.cron) with .guile or .vixie extensions.\n"
"Note that --daemon and --schedule are mutually exclusive."
option (--daemon -d
"run as a daemon process")
option (--stdin=guile -j (λ (in) (or (string=? in "guile")
(string=? in "vixie")))
"format of data passed as standard input or file "
"arguments, 'guile' or 'vixie' (default guile)")
option (--stdin-2=guile -k (lambda (in) (or (string=? in "guile")
(string=? in "vixie")))
"format of data passed as standard input or file "
"arguments, 'guile' or 'vixie' (default guile)")
option (--stdin-3=guile -l stdin-predicate
"format of data passed as standard input or file "
"arguments, 'guile' or 'vixie' (default guile)")
option (--schedule=8 -s string->number
"display the next N (or 8) jobs that will be run")
option (--not-complex short-i "this should just work")
help-postamble
"Mandatory or optional arguments to long options are also mandatory or "
"optional for any corresponding short options."
bug-address "bug-mcron@gnu.org"
copyright "2003, 2006, 2014, 2020 Free Software Foundation, Inc."
license GPLv3))
(pass-if "specification transformed" #t)
(process-command-line '("test" "-d" "leftover0" "--schedule=3" "leftover1"
"--stdin=vixie" "--stdin-2=guile" "--stdin-3" "vixie"
"-i")
app)
(pass-if "process-command-line completed" #t)
(pass-if "-d" (eq? --daemon #t))
(pass-if "--schedule=3" (string=? --schedule "3"))
(pass-if "--!" (equal? --! '("leftover0" "leftover1")))
(pass-if "-j" (string=? --stdin "vixie"))
(pass-if "-k" (string=? --stdin-2 "guile"))
(pass-if "-l" (string=? --stdin-3 "vixie"))
(pass-if "-i" (eq? --not-complex #t))
(process-command-line '("test" "-s9") app)
(pass-if "! -d" (eq? --daemon #f))
(pass-if "-s9" (string=? --schedule "9"))
)
(with-test-prefix "option merging"
(process-command-line (string-split "prog -a -b -d -h" #\space)
(merge-command-line-specifications
(command-line-specification
application "test-1"
option (-a --alpha "option alpha")
option (-b --beta "option beta")
option (-h --eta "option eta"))
(command-line-specification
application "test-2"
option (-b --beta "option beta")
option (-d --delta "option delta"))))
(pass-if "--alpha" (eq? #t --alpha))
(pass-if "--beta" (eq? #t --beta))
(pass-if "--delta" (eq? #t --delta))
(pass-if "--eta" (eq? #t --eta))
(pass-if "--beta-1" (eq? #f --beta-1))
(pass-if "--help" (eq? #f --help))
)
(with-test-prefix "all option combinations"
(define app (command-line-specification option (--alpha -a)))
(pass-if "specification transformed" #t)
)
;;; command-line-processor.test ends here