diff options
Diffstat (limited to 'src/mcron')
| -rw-r--r-- | src/mcron/command-line-processor.scm | 653 | ||||
| -rw-r--r-- | src/mcron/getopt-long.scm | 552 |
2 files changed, 1205 insertions, 0 deletions
diff --git a/src/mcron/command-line-processor.scm b/src/mcron/command-line-processor.scm new file mode 100644 index 0000000..5b5491b --- /dev/null +++ b/src/mcron/command-line-processor.scm @@ -0,0 +1,653 @@ +;;;; -*- scheme -*- +;;;; command-line-processor.scm --- command-line options processing +;;;; +;;;; 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 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, +;;; alpha-numeric characters, 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 or number. 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 short-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 (mcron 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 (mcron 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!)) + +;; We initialize the fields which are supposed to be lists, but +;; generally this procedure should *not* be considered to be producing a +;; properly specified <<specification>> record. +(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!)) + +;; As above, this initializer does *not* return a properly defined +;; object. +(define (make-option) (make-option- '())) + + + +(define (has-option-short-form spec letter) + (not (or (not letter) + (eq? #f (find (λ (a) (eqv? letter (option:short a))) + (spec:options spec)))))) + +(define (has-option-name spec name) + (not (eq? #f (find (λ (a) (string=? (option:name a) name)) + (spec:options spec))))) + +(define (merge-command-line-specifications- A B) + (for-each (λ (b-option) + (when (has-option-short-form A (option:short b-option)) + (option:set-short! b-option #f)) + (let ((base-name (option:name b-option))) + (when (has-option-name A base-name) + (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)) + A) + +(define-syntax merge-command-line-specifications + (syntax-rules () + "- 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. All of the +arguments will be mutilated in the process, and a new specification +object will be returned." + ((_ A B) (merge-command-line-specifications- A B)) + ((_ A B . C) (merge-command-line-specifications + (merge-command-line-specifications- A B) + . C)))) + + + +(define long-re (make-regexp "^--(!)?([[:alnum:]][-_[:alnum:]]*)(=(.+)?)?$")) +(define short-re (make-regexp "^-[[:alnum:]]$")) + + +(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. + ((_ O) #'#t) + + ;; Next option is a string: take as description. + ((_ 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. + ((_ O short-i . args) + #'(begin (option:set-short! O #\i) + (item O . args))) + + ((_ O short-I . args) + #'(begin (option:set-short! O #\I) + (item O . args))) + + ((_ 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. + ((_ 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. + + ((_ O (lambda args ...) . Args) + #'(begin (option:set-predicate! O (lambda args ...)) + (item O . Args))) + + ((_ 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)) + (for-each display `(" " ,(spec:version spec) "\n"))) + (unless (null? (spec:copyright spec)) + (for-each display `("Copyright © " + ,(string-join (spec:copyright spec) "\n ") + "\n"))) + (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 (λ () + (for-each display `(,(usage-string spec) + ,(string-join (spec:preamble spec) "\n") + "\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) + (for-each display + `("\nSend bug reports to " ,(spec:bugs spec) ".\n")))))) + + + +;; Make a list out of the args, omitting any #f. +(define (compose-list . args) + (let loop ((ret '()) (args args)) + (cond ((null? args) (reverse ret)) + ((not (car args)) (loop ret (cdr args))) + (else (loop (cons (car args) ret) (cdr args)))))) + +(define (make-getopt-long-input spec) + (map (λ (o) + (compose-list (string->symbol (option:name o)) + (and=> (option:short o) (λ (x) `(single-char ,x))) + `(required? ,(option:required? o)) + `(value ,(if (option:default o) + 'optional + (option:value? o))) + (and=> (option:predicate o) (λ (x) `(predicate ,x))))) + (spec:options spec))) + + + +(define-syntax-rule (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 g + (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 () + ((_ command-line specs) + (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 item ...) + (process-command-line + command-line + (command-line-specification item ...))))) diff --git a/src/mcron/getopt-long.scm b/src/mcron/getopt-long.scm new file mode 100644 index 0000000..b05c9a8 --- /dev/null +++ b/src/mcron/getopt-long.scm @@ -0,0 +1,552 @@ +;;;; getopt-long.scm --- long 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: Russ McManus +;;; Rewritten by Thien-Thi Nguyen +;;; Rewritten by Dale Mellor 2020-04-14 + +;;; Commentary: + +;;; This module implements some complex command line option parsing, in +;;; the spirit of the GNU C library function ‘getopt_long’. Both long +;;; and short options are supported. +;;; +;;; The theory is that people should be able to constrain the set of +;;; options they want to process using a grammar, rather than some ad +;;; hoc procedure. The grammar makes the option descriptions easy to +;;; read. +;;; +;;; ‘getopt-long’ is a procedure for parsing command-line arguments in a +;;; manner consistent with other GNU programs. ‘option-ref’ is a procedure +;;; that facilitates processing of the ‘getopt-long’ return value. + +;;; (getopt-long ARGS GRAMMAR) +;;; Parse the arguments ARGS according to the argument list grammar GRAMMAR. +;;; +;;; ARGS should be a list of strings. Its first element should be the +;;; name of the program, and subsequent elements should be the arguments +;;; that were passed to the program on the command line. The +;;; ‘program-arguments’ procedure returns a list of this form. +;;; +;;; GRAMMAR is a list of the form: +;;; ((OPTION (PROPERTY VALUE) ...) ...) +;;; +;;; Each OPTION should be a symbol. ‘getopt-long’ will accept a +;;; command-line option named ‘--OPTION’. +;;; Each option can have the following (PROPERTY VALUE) pairs: +;;; +;;; (single-char CHAR) --- Accept ‘-CHAR’ as a single-character +;;; equivalent to ‘--OPTION’. This is how to specify traditional +;;; Unix-style flags. +;;; (required? BOOL) --- If BOOL is true, the option is required. +;;; getopt-long will raise an error if it is not found in ARGS. +;;; (value BOOL) --- If BOOL is #t, the option accepts a value; if +;;; it is #f, it does not; and if it is the symbol +;;; ‘optional’, the option may appear in ARGS with or +;;; without a value. +;;; (predicate FUNC) --- If the option accepts a value (i.e. you +;;; specified ‘(value #t)’ or ‘(value 'optional)’ for this +;;; option), then getopt will apply FUNC to the value, and +;;; will not take the value if it returns #f. FUNC should +;;; be a procedure which accepts a string and returns a +;;; boolean value; you may need to use quasiquotes to get it +;;; into GRAMMAR. +;;; +;;; The (PROPERTY VALUE) pairs may occur in any order, but each +;;; property may occur only once. By default, options do not have +;;; single-character equivalents, are not required, and do not take +;;; values. +;;; +;;; In ARGS, single-character options may be combined, in the usual +;;; Unix fashion: ("-x" "-y") is equivalent to ("-xy"). If an option +;;; accepts values, then it must be the last option in the +;;; combination; the value is the next argument. So, for example, using +;;; the following grammar: +;;; ((apples (single-char #\a)) +;;; (blimps (single-char #\b) (value #t)) +;;; (catalexis (single-char #\c) (value #t))) +;;; the following argument lists would be acceptable: +;;; ("-a" "-b" "bang" "-c" "couth") ("bang" and "couth" are the values +;;; for "blimps" and "catalexis") +;;; ("-ab" "bang" "-c" "couth") (same) +;;; ("-ac" "couth" "-b" "bang") (same) +;;; +;;; If an option's value is optional, then ‘getopt-long’ decides whether +;;; it has a value by looking at what follows it in ARGS. If the next +;;; element does not appear to be an option itself, and passes a +;;; predicate if given, then that element is taken to be the option's +;;; value. Note that predicate functions are invaluable in this respect +;;; for differentiating options and option values, and in the case of +;;; options with optional values, PREDICATES REALLY SHOULD BE GIVEN. If +;;; an option is supposed to take a numerical value, then +;;; ‘string->number’ can be used as the predicate; this will also allow +;;; negative values to be used, which would ordinarily be regarded as +;;; bad options causing the module, and the application consuming it, to +;;; bail out with an immediate exit to the operating system. +;;; +;;; The value of a long option can appear as the next element in ARGS, +;;; or it can follow the option name, separated by an ‘=’ character. +;;; Thus, using the same grammar as above, the following argument lists +;;; are equivalent: +;;; ("--apples" "Braeburn" "--blimps" "Goodyear") +;;; ("--apples=Braeburn" "--blimps" "Goodyear") +;;; ("--blimps" "Goodyear" "--apples=Braeburn") +;;; +;;; If the option "--" appears in ARGS, argument parsing stops there; +;;; subsequent arguments are returned as ordinary arguments, even if +;;; they resemble options. So, in the argument list: +;;; ("--apples" "Granny Smith" "--" "--blimp" "Goodyear") +;;; ‘getopt-long’ will recognize the ‘apples’ option as having the value +;;; "Granny Smith", but it will not recognize the ‘blimp’ option; it +;;; will return the strings "--blimp" and "Goodyear" as ordinary +;;; argument strings. The first "--" argument itself will *not* appear +;;; in the ordinary arguments list, although the occurrence of +;;; subsequent ones will. +;;; +;;; The ‘getopt-long’ function returns the parsed argument list as an +;;; assocation list, mapping option names --- the symbols from GRAMMAR +;;; --- onto their values, or #t if the option does not accept a value. +;;; Unused options do not appear in the alist. +;;; +;;; All arguments that are not the value of any option are returned as a +;;; list, associated with the empty list in the above returned +;;; association. +;;; +;;; ‘getopt-long’ throws an exception if: +;;; - it finds an unrecognized property in GRAMMAR +;;; - the value of the ‘single-char’ property is not a character +;;; - it finds an unrecognized option in ARGS +;;; - a required option is omitted +;;; - an option that requires an argument doesn't get one +;;; - an option that doesn't accept an argument does get one (this can +;;; only happen using the long option ‘--opt=value’ syntax) +;;; - an option predicate fails +;;; +;;; So, for example: +;;; +;;; (define grammar +;;; `((lockfile-dir (required? #t) +;;; (value #t) +;;; (single-char #\k) +;;; (predicate ,file-is-directory?)) +;;; (verbose (required? #f) +;;; (single-char #\v) +;;; (value #f)) +;;; (x-includes (single-char #\x)) +;;; (rnet-server (single-char #\y) +;;; (predicate ,string?)))) +;;; +;;; (getopt-long '("my-prog" "-vk" "/tmp" "foo1" "--x-includes=/usr/include" +;;; "--rnet-server=lamprod" "--" "-fred" "foo2" "foo3") +;;; grammar) +;;; => ((() "foo1" "-fred" "foo2" "foo3") +;;; (rnet-server . "lamprod") +;;; (x-includes . "/usr/include") +;;; (lockfile-dir . "/tmp") +;;; (verbose . #t)) + +;;; (option-ref OPTIONS KEY DEFAULT) +;;; Return value in alist OPTIONS using KEY, a symbol; or DEFAULT if not +;;; found. The return is either a string or ‘#t’, or whatever DEFAULT +;;; is. +;;; +;;; For example, using the ‘getopt-long’ return value from above: +;;; +;;; (option-ref (getopt-long ...) 'x-includes 42) => "/usr/include" +;;; (option-ref (getopt-long ...) 'not-a-key! 31) => 31 + +;;; Code: + +(define-module (mcron getopt-long) + #:use-module (ice-9 control) + #:use-module (srfi srfi-1) + #:use-module (srfi srfi-9) + #:use-module (ice-9 match) + #:use-module (ice-9 regex) + #:use-module (ice-9 receive) + #:export (getopt-long option-ref)) + +(define program-name (make-parameter "guile")) + +(define (fatal-error fmt . args) + (format (current-error-port) "~a: " (program-name)) + (apply format (current-error-port) fmt args) + (newline (current-error-port)) + (exit 1)) + +;; name: string, required?: bool, single-char: char or #f, predicate: +;; procedure or #f, value-policy: bool or 'optional. +(define-record-type option-spec + (%make-option-spec name required? single-char predicate value-policy) + option-spec? + (name option-spec->name) + (required? option-spec->required? set-option-spec-required?!) + (single-char option-spec->single-char set-option-spec-single-char!) + (predicate option-spec->predicate set-option-spec-predicate!) + (value-policy option-spec->value-policy set-option-spec-value-policy!)) + +(define (make-option-spec name) + (%make-option-spec name #f #f #f #f)) + +(define (parse-option-spec desc) + (let ((spec (make-option-spec (symbol->string (car desc))))) + (for-each (match-lambda + (('required? val) + (set-option-spec-required?! spec val)) + (('value val) + (set-option-spec-value-policy! spec val)) + (('single-char val) + (unless (char? val) + (fatal-error "‘single-char’ value must be a char!")) + (set-option-spec-single-char! spec val)) + (('predicate pred) + (set-option-spec-predicate! spec pred)) + ((prop val) + (fatal-error "invalid getopt-long option property: " prop))) + (cdr desc)) + spec)) + + +;; Extract the name of a long option given that it may or may not be +;; surrounded by '--' and '=...'. +(define isolate-long-name-re (make-regexp "^(--)?([^=]+)")) + +(define (isolate-long-name name) + (and=> (regexp-exec isolate-long-name-re name) + (λ (match) (match:substring match 2)))) + + +;; Whatever the presentation of the long option, make sure it is in a +;; clean, normalized form (but this does NOT account for any value the +;; option might have). +(define (re-present option) + (string-append "--" (isolate-long-name option) "=")) + + +;; The /name/ can take the form of a long option entry on the command +;; line, with whatever decoration that entails. Will return #f if a +;; spec does not exist for this named option. +(define (find-spec-long specs name) + (and=> (isolate-long-name name) + (λ (name) (find (λ (a) (string=? (option-spec->name a) name)) specs)))) + + +;; Return #f if a spec with the short /letter/ name does not exist. +(define (find-spec-short specs letter) + (find (λ (a) (eqv? (option-spec->single-char a) letter)) specs)) + + +;; Take, for example, /short/='-h' to '--help='. +(define (double-up short specs) + (and=> (find-spec-short specs (string-ref short 1)) + (λ (spec) (string-append "--" (option-spec->name spec) "=")))) + + +;; This procedure does whatever is necessary to put the (ostensibly) +;; first item on the command-line into the canonical (normal) form +;; '--item=value'; this may mean consuming the next item of the +;; command-line (the first item of /rest/) to get the value. Note that +;; the value may be missing, but the '=' sign will always be there in +;; the return. The first item (/A/) will always be more than two +;; characters, and the first two characters will be "--", i.e. we are +;; processing a long option. +;; +;; A IN string The first argument on the command-line +;; rest IN list of strings The remaining items of the command-line +;; specs IN list of option-spec Options specification +;; remnant OUT list of strings The unprocessed command line +;; processed OUT string New command-line argument +(define (normalize-long-option A rest specs) + (define (return-empty-arg) (values rest (re-present A))) + (define (return-arg-with-value) + (values (cdr rest) (string-append (re-present A) (car rest)))) + (cond + ((string-index A #\=) + ;; The argument is already in the canonical form. + (values rest A)) + ((find-spec-long specs A) + => (λ (spec) + (if (cond ((null? rest) #f) + ((option-spec->predicate spec) + => (λ (pred) (pred (car rest)))) + (else + (case (option-spec->value-policy spec) + ((#f) #f) + ((optional) + (not (eqv? (string-ref (car rest) 0) #\-))) + ((#t) + (or (string->number (car rest)) + (not (eqv? (string-ref (car rest) 0) #\-))))))) + (return-arg-with-value) + (return-empty-arg)))) + (else + ;; We know nothing about this option, abort operations. + (fatal-error "no such option: --~a" (isolate-long-name A))))) + + + +;; This procedure does whatever is necessary to put the (ostensibly) +;; first item on the command-line into the canonical form +;; '--item=value'; this may mean consuming the next item of the +;; command-line (the first item of /rest/) to get the value. Note that +;; the value may be missing, but the '=' sign will always be there in +;; the return. The first item (/A/) will always be exactly two +;; characters, and the first character will be "-", i.e. we are +;; processing an isolated short option. +;; +;; A IN string The first argument on the command-line +;; rest IN list of strings The remaining items of the command-line +;; specs IN list of option-spec Options specification +;; remnant OUT list of strings The unprocessed command line +;; processed OUT string New command-line argument +(define (normalize-free-short-option A rest specs) + (define (return-empty-arg) (values rest (double-up A specs))) + (define (return-arg-with-next-value) + (values (cdr rest) (string-append (double-up A specs) (car rest)))) + (let* ((name (string-ref A 1)) + (spec (find-spec-short specs name))) + (if (cond ((not spec) (fatal-error "no such option: -~a" name)) + ((null? rest) #f) + ((option-spec->predicate spec) + => (λ (pred) (pred (car rest)))) + (else (case (option-spec->value-policy spec) + ((optional) (not (eq? (string-ref (car rest) 0) #\-))) + (else => identity)))) + (return-arg-with-next-value) + (return-empty-arg)))) + + + +;; The /sequence/ is a string of characters from the command line, and +;; the task is to decide if those characters are a viable clumped option +;; sequence, possibly using some of the trailing characters as option +;; values, or not. +(define (viable-short sequence specs) + (cond ((eq? 0 (string-length sequence)) #t) + ((find-spec-short specs (string-ref sequence 0)) + => (λ (spec) + (cond ((option-spec->predicate spec) + => (λ (pred) (pred (substring sequence 1)))) + (else + ;; If this optionʼs /value-policy/ allows the + ;; option to take a value then this string is + ;; viable as the remainder can be taken as that + ;; value. Otherwise we must assert the viability + ;; of the rest of the line by recursion. + (or (not (eq? #f (option-spec->value-policy spec))) + (viable-short (substring sequence 1) specs)))))) + (else #f))) + + + +;; This procedure does whatever is necessary to put the (ostensibly) +;; first item on the command-line into the canonical form +;; '--item=value'. Note that the value may be missing, but the '=' +;; sign will always be there in the return. The first item (/A/) will +;; always be *more* than two characters, and the first character will +;; be "-", i.e. we are processing a short option which is either +;; clumped with other short options, or is clumped with its value. +;; +;; NOTE that, contrary to the other normalize procedures, the return +;; value of /processed/ can be #f, with the expectation that the +;; modified /remnant/ will be re-processed. +;; +;; A IN string The first argument on the command-line +;; rest IN list of strings The remaining items of the command-line +;; specs IN list of option-spec Options specification +;; remnant OUT list of strings The unprocessed command line +;; processed OUT string New command-line argument +(define (normalize-clumped-short-option A rest specs) + (define (declump-arg) (values (cons* (string-append "-" (substring A 1 2)) + (string-append "-" (substring A 2)) + rest) + #f)) + (define (construct-arg-from-clumped-value) + (values rest (string-append (double-up A specs) (substring A 2)))) + (unless (char-alphabetic? (string-ref A 1)) (values rest A)) + (let ((spec (find-spec-short specs (string-ref A 1)))) + (if (cond ((not spec) (fatal-error "no such option: -~a" (string-ref A 1))) + ((option-spec->predicate spec) + => (λ (pred) (pred (substring A 2)))) + (else (case (option-spec->value-policy spec) + ((optional) (not (viable-short (substring A 2) specs))) + (else => identity)))) + (construct-arg-from-clumped-value) + (declump-arg)))) + + + +;; Return a version of the command-line /args/ in which all options are +;; represented in long form with an equals sign (whether they have a +;; value or not). +(define (normalize args specs stop-at-first-non-option?) + (call/ec + (λ (return) + (let loop ((args args) (processed '())) + (when (null? args) (return (reverse processed))) + (define A (car args)) + (define L (string-length A)) + (define (when-loop cond normalizer) + (when cond + (receive (remainder-args processed-arg) + (normalizer A (cdr args) specs) + (loop + remainder-args + (if processed-arg + (cons processed-arg processed) + processed))))) + (when (string=? "--" A) + (return (append (reverse processed) args))) + (when-loop (and (> L 2) (string=? (substring A 0 2) "--")) + normalize-long-option) + (when-loop (and (eqv? L 2) (eqv? (string-ref A 0) #\-)) + normalize-free-short-option) + (when-loop (and (> L 1) (eqv? (string-ref A 0) #\-)) + normalize-clumped-short-option) + (if stop-at-first-non-option? + (return (append (reverse processed) args)) + (loop (cdr args) (cons A processed))))))) + + + +;; Check that all the rules inherent in the /specs/ are fulfilled by +;; the /options/. +(define (verify-specs-fullfilled specs options) + (for-each + (λ (spec) + (let* ((name (option-spec->name spec)) + (value (assq-ref options (string->symbol name)))) + (when (and (option-spec->required? spec) (not value)) + (fatal-error "option must be specified: --~a" name)) + (let ((policy (option-spec->value-policy spec))) + (when (and (eq? policy #t) (eq? value #t)) + (fatal-error "option must be specified with argument: --~a" name)) + (when (and (eq? policy #f) (string? value)) + (fatal-error "option does not support argument: --~a" name))) + (let ((pred (option-spec->predicate spec))) + (when (and pred (string? value) (not (pred value))) + (fatal-error "option predicate failed: --~a" name))))) + specs)) + + + +;; Check that all the options are matched by a specification. +(define (verify-options options specs) + (for-each + (λ (value) + (unless (or (null? (car value)) + (find-spec-long specs (symbol->string (car value)))) + (fatal-error "no such option: --~a" (car value)))) + options)) + + + +;; This procedure will simply return if the options and the specs +;; conform with each other, or else will bail out with an error +;; message. +(define (check-compliance options specs) + (verify-specs-fullfilled specs options) + (verify-options options specs)) + + + +(define full-option-re (make-regexp "^--([^=]+)=(.+)?$")) + +;; The /normal-args/ are a normalized command line in which all +;; options are expressed long-form, and the task here is to construct an +;; /options/ object: an associative array of option names onto values +;; (or #t if there is no value). +(define (extract-options normal-args stop-at-first-non-option?) + (let loop ((args normal-args) + (options '()) + (non-options '())) + (cond + ((null? args) (acons '() (reverse non-options) options)) + ((string=? (car args) "--") + (acons '() (append (reverse non-options) (cdr args)) options)) + ((regexp-exec full-option-re (car args)) + => (λ (match) + (loop (cdr args) + (acons (string->symbol (match:substring match 1)) + (or (match:substring match 2) #t) + options) + non-options))) + (stop-at-first-non-option? + (acons '() (append (reverse non-options) args) options)) + (else + (loop (cdr args) options (cons (car args) non-options)))))) + + + +(define* (getopt-long program-arguments option-desc-list + #:key stop-at-first-non-option) + "- Scheme Procedure: getopt-long PROGRAM-ARGUMENTS OPTION-DESC-LIST + [#:stop-at-first-non-option] + +Process options, handling both long and short options, similar to +the glibc function 'getopt_long'. PROGRAM-ARGUMENTS should be a value +similar to what (program-arguments) returns. OPTION-DESC-LIST is a +list of option descriptions. Each option description must satisfy the +following grammar: + + <option-spec> :: (<name> . <attribute-ls>) + <attribute-ls> :: (<attribute> . <attribute-ls>) + | () + <attribute> :: <required-attribute> + | <arg-required-attribute> + | <single-char-attribute> + | <predicate-attribute> + | <value-attribute> + <required-attribute> :: (required? <boolean>) + <single-char-attribute> :: (single-char <char>) + <value-attribute> :: (value #t) + (value #f) + (value optional) + <predicate-attribute> :: (predicate <1-ary-function>) + + The procedure returns an alist of option names and values. Each +option name is a symbol. The option value will be '#t' if no value +was specified. There is a special item in the returned alist with a +key of the empty list, (): the list of arguments that are not options +or option values. + By default, options are not required, and option values are not +required. By default, single character equivalents are not supported; +if you want to allow the user to use single character options, you need +to add a ‘single-char’ clause to the option description." + (parameterize ((program-name (car program-arguments))) + (let* ((specs (map parse-option-spec option-desc-list)) + (options (extract-options + (normalize (cdr program-arguments) + specs + stop-at-first-non-option) + stop-at-first-non-option))) + (check-compliance options specs) + options))) + + + +(define (option-ref options key default) + "Return value in OPTIONS (as returned from getopt-long), using KEY-- +a symbol--, or DEFAULT if not found. The value is either a string or +‘#t’, or whatever DEFAULT is." + (or (assq-ref options key) default)) + + +;;; getopt-long.scm ends here |