diff --git a/AUTHORS b/AUTHORS index d4ad7994..7a628846 100644 --- a/AUTHORS +++ b/AUTHORS @@ -26,6 +26,9 @@ Portable syntax-case from Chez Scheme; patches from Guile module/mes/psyntax.ss module/mes/psyntax.pp [generated] +Getopt-long from Guile +module/mes/getopt-long.scm + Optargs from Guile module/mes/optargs.scm diff --git a/module/mes/getopt-long.mes b/module/mes/getopt-long.mes new file mode 100644 index 00000000..c5685fa5 --- /dev/null +++ b/module/mes/getopt-long.mes @@ -0,0 +1,29 @@ +;;; -*-scheme-*- + +;;; Mes --- Maxwell Equations of Software +;;; Copyright © 2017 Jan Nieuwenhuizen +;;; +;;; This file is part of Mes. +;;; +;;; Mes is free software; you can redistribute it and/or modify it +;;; under the terms of the GNU General Public License as published by +;;; the Free Software Foundation; either version 3 of the License, or (at +;;; your option) any later version. +;;; +;;; Mes 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 General Public License for more details. +;;; +;;; You should have received a copy of the GNU General Public License +;;; along with Mes. If not, see . + +;;; Commentary: + +;;; portable matcher + +(mes-use-module (mes syntax)) +(mes-use-module (srfi srfi-1)) +(mes-use-module (srfi srfi-9)) +(mes-use-module (mes guile)) +(include-from-path "mes/getopt-long.scm") diff --git a/module/mes/getopt-long.scm b/module/mes/getopt-long.scm new file mode 100644 index 00000000..7e394662 --- /dev/null +++ b/module/mes/getopt-long.scm @@ -0,0 +1,433 @@ +;;; Copyright (C) 1998, 2001, 2006 Free Software Foundation, Inc. +;;; Copyright (C) 2017 Jan Nieuwenhuizen +;;; +;; 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 2.1 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) +;;; (regexps removed by Jan Nieuwenhuizen) +;;; (srfi-9 backport by Jan Nieuwenhuizen) + +;;; 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 arbitrary +;;; structure. 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; 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)' for this option), then getopt +;;; will apply FUNC to the value, and throw an exception +;;; 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) +;;; ("-abc" "couth" "bang") (an error, since `-b' is not the +;;; last option in its combination) +;;; +;;; 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 is does not appear to be an option itself, then +;;; that element is the option's value. +;;; +;;; 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 `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. +;;; +;;; `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 value is either a string or `#t'. +;;; +;;; 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 (mes getopt-long) + #:use-module (srfi srfi-1) + #:use-module (srfi srfi-9) + #:export (getopt-long option-ref)) + +(define (remove-if-not pred l) + (let loop ((l l) (result '())) + (cond ((null? l) (reverse! result)) + ((not (pred (car l))) (loop (cdr l) result)) + (else (loop (cdr l) (cons (car l) result)))))) + +(define-record-type option-spec + (%make-option-spec name required? option-spec->single-char predicate value-policy) + option-spec? + (name + option-spec->name set-option-spec-name!) + (required? + option-spec->required? set-option-spec-required?!) + (option-spec->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 (lambda (desc-elem) + (let ((given (lambda () (cadr desc-elem)))) + (case (car desc-elem) + ((required?) + (set-option-spec-required?! spec (given))) + ((value) + (set-option-spec-value-policy! spec (given))) + ((single-char) + (or (char? (given)) + (error "`single-char' value must be a char!")) + (set-option-spec-single-char! spec (given))) + ((predicate) + (set-option-spec-predicate! + spec ((lambda (pred) + (lambda (name val) + (or (not val) + (pred val) + (error "option predicate failed:" name)))) + (given)))) + (else + (error "invalid getopt-long option property:" + (car desc-elem)))))) + (cdr desc)) + spec)) + +(define (split-arg-list argument-list) + ;; Scan ARGUMENT-LIST for "--" and return (BEFORE-LS . AFTER-LS). + ;; Discard the "--". If no "--" is found, AFTER-LS is empty. + (let loop ((yes '()) (no argument-list)) + (cond ((null? no) (cons (reverse yes) no)) + ((string=? "--" (car no)) (cons (reverse yes) (cdr no))) + (else (loop (cons (car no) yes) (cdr no)))))) + +(define (expand-clumped-singles opt-ls) + ;; example: ("--xyz" "-abc5d") => ("--xyz" "-a" "-b" "-c" "5d") + (let loop ((opt-ls opt-ls) (ret-ls '())) + (cond ((null? opt-ls) + (reverse ret-ls)) ;;; retval + ((let ((opt (car opt-ls))) + (and (eq? (string-ref opt 0) #\-) + (let ((n (char->integer (string-ref opt 1)))) + (or (and (>= n (char->integer #\A)) (<= n (char->integer #\Z))) + (and (>= n (char->integer #\a)) (<= n (char->integer #\z))))))) + (let* ((opt (car opt-ls)) + (n (char->integer (string-ref opt 1))) + (end (or (string-index opt (lambda (c) (not (or (and (>= n (char->integer #\A)) (<= n (char->integer #\Z))) + (and (>= n (char->integer #\a)) (<= n (char->integer #\z))))))) + (string-length opt))) + (singles-string (substring opt 1 end)) + (singles (reverse + (map (lambda (c) + (string-append "-" (make-string 1 c))) + (string->list singles-string)))) + (extra (substring opt end))) + (loop (cdr opt-ls) + (append (if (string=? "" extra) + singles + (cons extra singles)) + ret-ls)))) + (else (loop (cdr opt-ls) + (cons (car opt-ls) ret-ls)))))) + +(define (looks-like-an-option string) + (eq? (string-ref string 0) #\-)) + +(define (process-options specs argument-ls) + ;; Use SPECS to scan ARGUMENT-LS; return (FOUND . ETC). + ;; FOUND is an unordered list of option specs for found options, while ETC + ;; is an order-maintained list of elements in ARGUMENT-LS that are neither + ;; options nor their values. + (let ((idx (map (lambda (spec) + (cons (option-spec->name spec) spec)) + specs)) + (sc-idx (map (lambda (spec) + (cons (make-string 1 (option-spec->single-char spec)) + spec)) + (remove-if-not option-spec->single-char specs)))) + (let loop ((argument-ls argument-ls) (found '()) (etc '())) + (let ((eat! (lambda (spec ls) + (let ((val!loop (lambda (val n-ls n-found n-etc) + (set-option-spec-value-policy! + spec + ;; handle multiple occurrances + (cond ((option-spec->value-policy spec) + => (lambda (cur) + ((if (list? cur) cons list) + val cur))) + (else val))) + (loop n-ls n-found n-etc))) + (ERR:no-arg (lambda () + (error (string-append + "option must be specified" + " with argument:") + (option-spec->name spec))))) + (cond + ((eq? 'optional (option-spec->value-policy spec)) + (if (or (null? (cdr ls)) + (looks-like-an-option (cadr ls))) + (val!loop #t + (cdr ls) + (cons spec found) + etc) + (val!loop (cadr ls) + (cddr ls) + (cons spec found) + etc))) + ((eq? #t (option-spec->value-policy spec)) + (if (or (null? (cdr ls)) + (looks-like-an-option (cadr ls))) + (ERR:no-arg) + (val!loop (cadr ls) + (cddr ls) + (cons spec found) + etc))) + (else + (val!loop #t + (cdr ls) + (cons spec found) + etc))))))) + + (if (null? argument-ls) + (cons found (reverse etc)) ;;; retval + (cond ((let ((opt (car argument-ls))) + (and (eq? (string-ref opt 0) #\-) + (let ((n (char->integer (string-ref opt 1)))) + (or (and (>= n (char->integer #\A)) (<= n (char->integer #\Z))) + (and (>= n (char->integer #\a)) (<= n (char->integer #\z))))))) + (let* ((c (substring (car argument-ls) 1 2)) + (spec (or (assoc-ref sc-idx c) + (error "no such option:" (car argument-ls))))) + (eat! spec argument-ls))) + ((let ((opt (car argument-ls))) + (and (string-prefix? "--" opt) + (let ((n (char->integer (string-ref opt 2)))) + (or (and (>= n (char->integer #\A)) (<= n (char->integer #\Z))) + (and (>= n (char->integer #\a)) (<= n (char->integer #\z))))) + (not (string-index opt #\space)) + (not (string-index opt #\=)))) + (let* ((opt (substring (car argument-ls) 2)) + (spec (or (assoc-ref idx opt) + (error "no such option:" (car argument-ls))))) + (eat! spec argument-ls))) + ((let ((opt (car argument-ls))) + (and (string-prefix? "--" opt) + (let ((n (char->integer (string-ref opt 2)))) + (or (and (>= n (char->integer #\A)) (<= n (char->integer #\Z))) + (and (>= n (char->integer #\a)) (<= n (char->integer #\z))))) + (or (string-index opt #\=) + (string-index opt #\space)))) + (let* ((is (or (string-index (car argument-ls) #\=) + (string-index (car argument-ls) #\space))) + (opt (substring (car argument-ls) 2 is)) + (spec (or (assoc-ref idx opt) + (error "no such option:" (substring opt is))))) + (if (option-spec->value-policy spec) + (eat! spec (append + (list 'ignored + (substring (car argument-ls) (1+ is))) + (cdr argument-ls))) + (error "option does not support argument:" + opt)))) + (else + (loop (cdr argument-ls) + found + (cons (car argument-ls) etc))))))))) + +(define (getopt-long program-arguments option-desc-list) +;; "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: + +;; :: ( . ) +;; :: ( . ) +;; | () +;; :: +;; | +;; | +;; | +;; | +;; :: (required? ) +;; :: (single-char ) +;; :: (value #t) +;; (value #f) +;; (value optional) +;; :: (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." + (let* ((specifications (map parse-option-spec option-desc-list)) + (pair (split-arg-list (cdr program-arguments))) + (split-ls (expand-clumped-singles (car pair))) + (non-split-ls (cdr pair)) + (found/etc (process-options specifications split-ls)) + (found (car found/etc)) + (rest-ls (append (cdr found/etc) non-split-ls))) + (for-each (lambda (spec) + (let ((name (option-spec->name spec)) + (val (option-spec->value-policy spec))) + (and (option-spec->required? spec) + (or (memq spec found) + (error "option must be specified:" name))) + (and (memq spec found) + (eq? #t (option-spec->value-policy spec)) + (or val + (error "option must be specified with argument:" + name))) + (let ((pred (option-spec->predicate spec))) + (and pred (pred name val))))) + specifications) + (cons (cons '() rest-ls) + (let ((multi-count (map (lambda (desc) + (cons (car desc) 0)) + option-desc-list))) + (map (lambda (spec) + (let ((name (string->symbol (option-spec->name spec)))) + (cons name + ;; handle multiple occurrances + (let ((maybe-ls (option-spec->value-policy spec))) + (if (list? maybe-ls) + (let* ((look (assq name multi-count)) + (idx (cdr look)) + (val (list-ref maybe-ls idx))) + (set-cdr! look (1+ idx)) ; ugh! + val) + maybe-ls))))) + found))))) + +(define (option-ref options key default) +;; "Return value in alist OPTIONS using KEY, a symbol; or DEFAULT if not found. +;; The value is either a string or `#t'." + (or (assq-ref options key) default)) + +;;; getopt-long.scm ends here