diff options
Diffstat (limited to 'module/ice-9/getopt-long.scm')
-rw-r--r-- | module/ice-9/getopt-long.scm | 371 |
1 files changed, 371 insertions, 0 deletions
diff --git a/module/ice-9/getopt-long.scm b/module/ice-9/getopt-long.scm new file mode 100644 index 000000000..14eaf8e23 --- /dev/null +++ b/module/ice-9/getopt-long.scm @@ -0,0 +1,371 @@ +;;; Copyright (C) 1998, 2001, 2006, 2009, 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: Russ McManus (rewritten by Thien-Thi Nguyen) + +;;; 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 (ice-9 getopt-long) + #:use-module ((ice-9 common-list) #:select (remove-if-not)) + #:use-module (srfi srfi-9) + #:use-module (ice-9 match) + #:use-module (ice-9 regex) + #:use-module (ice-9 optargs) + #:export (getopt-long option-ref)) + +(define %program-name (make-fluid "guile")) +(define (program-name) + (fluid-ref %program-name)) + +(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)) + +(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 (match-lambda + (('required? val) + (set-option-spec-required?! spec val)) + (('value val) + (set-option-spec-value-policy! spec val)) + (('single-char val) + (or (char? val) + (error "`single-char' value must be a char!")) + (set-option-spec-single-char! spec val)) + (('predicate pred) + (set-option-spec-predicate! + spec (lambda (name val) + (or (not val) + (pred val) + (fatal-error "option predicate failed: --~a" + name))))) + ((prop val) + (error "invalid getopt-long option property:" prop))) + (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 short-opt-rx (make-regexp "^-([a-zA-Z]+)(.*)")) +(define long-opt-no-value-rx (make-regexp "^--([^=]+)$")) +(define long-opt-with-value-rx (make-regexp "^--([^=]+)=(.*)")) + +(define (looks-like-an-option string) + (or (regexp-exec short-opt-rx string) + (regexp-exec long-opt-with-value-rx string) + (regexp-exec long-opt-no-value-rx string))) + +(define (process-options specs argument-ls stop-at-first-non-option) + ;; 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 ((unclumped 0) (argument-ls argument-ls) (found '()) (etc '())) + (define (eat! spec ls) + (cond + ((eq? 'optional (option-spec->value-policy spec)) + (if (or (null? ls) + (looks-like-an-option (car ls))) + (loop (- unclumped 1) ls (acons spec #t found) etc) + (loop (- unclumped 2) (cdr ls) (acons spec (car ls) found) etc))) + ((eq? #t (option-spec->value-policy spec)) + (if (or (null? ls) + (looks-like-an-option (car ls))) + (fatal-error "option must be specified with argument: --~a" + (option-spec->name spec)) + (loop (- unclumped 2) (cdr ls) (acons spec (car ls) found) etc))) + (else + (loop (- unclumped 1) ls (acons spec #t found) etc)))) + + (match argument-ls + (() + (cons found (reverse etc))) + ((opt . rest) + (cond + ((regexp-exec short-opt-rx opt) + => (lambda (match) + (if (> unclumped 0) + ;; Next option is known not to be clumped. + (let* ((c (match:substring match 1)) + (spec (or (assoc-ref sc-idx c) + (fatal-error "no such option: -~a" c)))) + (eat! spec rest)) + ;; Expand a clumped group of short options. + (let* ((extra (match:substring match 2)) + (unclumped-opts + (append (map (lambda (c) + (string-append "-" (make-string 1 c))) + (string->list + (match:substring match 1))) + (if (string=? "" extra) '() (list extra))))) + (loop (length unclumped-opts) + (append unclumped-opts rest) + found + etc))))) + ((regexp-exec long-opt-no-value-rx opt) + => (lambda (match) + (let* ((opt (match:substring match 1)) + (spec (or (assoc-ref idx opt) + (fatal-error "no such option: --~a" opt)))) + (eat! spec rest)))) + ((regexp-exec long-opt-with-value-rx opt) + => (lambda (match) + (let* ((opt (match:substring match 1)) + (spec (or (assoc-ref idx opt) + (fatal-error "no such option: --~a" opt)))) + (if (option-spec->value-policy spec) + (eat! spec (cons (match:substring match 2) rest)) + (fatal-error "option does not support argument: --~a" + opt))))) + ((and stop-at-first-non-option + (<= unclumped 0)) + (cons found (append (reverse etc) argument-ls))) + (else + (loop (- unclumped 1) rest found (cons opt etc))))))))) + +(define* (getopt-long program-arguments option-desc-list + #:key 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." + (with-fluids ((%program-name (car program-arguments))) + (let* ((specifications (map parse-option-spec option-desc-list)) + (pair (split-arg-list (cdr program-arguments))) + (split-ls (car pair)) + (non-split-ls (cdr pair)) + (found/etc (process-options specifications split-ls + stop-at-first-non-option)) + (found (car found/etc)) + (rest-ls (append (cdr found/etc) non-split-ls))) + (for-each (lambda (spec) + (let ((name (option-spec->name spec)) + (val (assq-ref found spec))) + (and (option-spec->required? spec) + (or val + (fatal-error "option must be specified: --~a" + name))) + (let ((pred (option-spec->predicate spec))) + (and pred (pred name val))))) + specifications) + (for-each (lambda (spec+val) + (set-car! spec+val + (string->symbol (option-spec->name (car spec+val))))) + found) + (cons (cons '() rest-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 |