summaryrefslogtreecommitdiff
path: root/module/ice-9/getopt-long.scm
diff options
context:
space:
mode:
Diffstat (limited to 'module/ice-9/getopt-long.scm')
-rw-r--r--module/ice-9/getopt-long.scm371
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