* 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 --- module/Makefile.am | 1 + module/ice-9/command-line-processor.scm | 646 +++++++++++++++++++ test-suite/Makefile.am | 1 + test-suite/tests/command-line-processor.test | 155 +++++ 4 files changed, 803 insertions(+) create mode 100644 module/ice-9/command-line-processor.scm create mode 100644 test-suite/tests/command-line-processor.test
diff --git a/module/Makefile.am b/module/Makefile.am index 7d3f3280a..48e8faca2 100644 --- a/module/Makefile.am +++ b/module/Makefile.am @@ -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 \ diff --git a/module/ice-9/command-line-processor.scm b/module/ice-9/command-line-processor.scm new file mode 100644 index 000000000..8bd5690cc --- /dev/null +++ b/module/ice-9/command-line-processor.scm @@ -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-qf1...@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-mc...@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 ...))))) diff --git a/test-suite/Makefile.am b/test-suite/Makefile.am index 8158aaf44..c25ede6ad 100644 --- a/test-suite/Makefile.am +++ b/test-suite/Makefile.am @@ -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 \ diff --git a/test-suite/tests/command-line-processor.test b/test-suite/tests/command-line-processor.test new file mode 100644 index 000000000..7560ad102 --- /dev/null +++ b/test-suite/tests/command-line-processor.test @@ -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-qf1...@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-mc...@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 -- 2.20.1
