(ice-9 getopt-long) w/ restricted `merge-multiple?' range
Thien-Thi Nguyen <[email protected]>
| Newsgroups | gmane.lisp.guile.user,gmane.lisp.guile.sources |
|---|---|
| Message-ID | <[email protected]> |
folks,
please find below an improved version of module (ice-9 getopt-long).
`merge-multiple?' used to result in non-list values when there was only
one usage of a given option. now the range is restricted: it always
returns either #f or a list (possibly w/ only one element).
from an implementation pov, this version is notable for using simple
vectors instead of records, using less passes, and relief of dependency
on (ice-9 common-list).
from a design pov, (ice-9 getopt-long) is still lacking some kind of
sequence/threading markup, to support things like sed's combination of
-e and -f flags. probably a simple counter in `eat!' is sufficient for
generating sequence numbers -- the question is, where to put them?
thi
_________________________________
;;; getopt-long.scm
;; Copyright (C) 1998,2001,02,03,2004 Free Software Foundation, Inc.
;;
;; This program 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 2 of the License, or
;; (at your option) any later version.
;;
;; This program 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 this program; if not, write to the Free Software
;; Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
;;
;; As a special exception, the Free Software Foundation gives permission
;; for additional uses of the text contained in its release of GUILE.
;;
;; The exception is that, if you link the GUILE library with other files
;; to produce an executable, this does not by itself cause the
;; resulting executable to be covered by the GNU General Public License.
;; Your use of that executable is in no way restricted on account of
;; linking the GUILE library code into it.
;;
;; This exception does not however invalidate any other reasons why
;; the executable file might be covered by the GNU General Public License.
;;
;; This exception applies only to the code released by the
;; Free Software Foundation under the name GUILE. If you copy
;; code from other Free Software Foundation releases into a copy of
;; GUILE, as the General Public License permits, the exception does
;; not apply to the code that you add in this way. To avoid misleading
;; anyone as to the status of such modified files, you must delete
;; this exception notice from them.
;;
;; If you write modifications of your own for GUILE, it is your choice
;; whether to permit this exception to apply to your modifications.
;; If you do not wish that, delete this exception notice.
;;; Author: Russ McManus (modified 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 POLICY) --- If POLICY 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.
;;; (merge-multiple? BOOL) --- If BOOL is #t and the `value' option is not
;;; #f, all (one or multiple) occurrances are merged into a list
;;; with order retained. If #f, each instance of the option
;;; results in a separate entry in the resulting alist.
;;; (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)
#:export (getopt-long option-ref))
(define option-spec-fields '(name
required?
single-char
predicate
value-policy
merge-multiple?))
(define field-count (length option-spec-fields))
(define (make-option-spec name)
(apply vector name (make-list (1- field-count) #f)))
(define (define-one-accessor field position)
`(define (,(symbol-append 's: field) option-spec-object)
(vector-ref option-spec-object ,position)))
(define (define-one-modifier field position)
`(define (,(symbol-append 's: field '!) option-spec-object new-value)
(vector-set! option-spec-object ,position new-value)))
(defmacro define-all-accessors/modifiers ()
`(begin
,@(map define-one-accessor option-spec-fields (iota field-count))
,@(map define-one-modifier option-spec-fields (iota field-count))))
(define-all-accessors/modifiers)
(define (parse-option-spec desc)
(let* ((name (car desc))
(spec (make-option-spec name)))
(for-each (lambda (desc-elem)
(let ((given (lambda () (cadr desc-elem))))
(case (car desc-elem)
((required?)
(s:required?! spec (given)))
((value)
(s:value-policy! spec (given)))
((single-char)
(or (char? (given))
(error "`single-char' value must be a char!"))
(s:single-char! spec (given)))
((predicate)
(s:predicate! spec (given)))
((merge-multiple?)
(s:merge-multiple?! spec (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 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 (msub match which)
;; condensed from (ice-9 regex) `match:{substring,start,end}'
(let ((sel (vector-ref match (1+ which))))
(substring (vector-ref match 0) (car sel) (cdr sel))))
(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
((regexp-exec short-opt-rx (car opt-ls))
=> (lambda (match)
(let ((singles (reverse
(map (lambda (c)
(string-append "-" (make-string 1 c)))
(string->list
(msub match 1)))))
(extra (msub match 2)))
(loop (cdr opt-ls)
(append (if (string-null? extra)
singles
(cons extra singles))
ret-ls)))))
(else (loop (cdr opt-ls)
(cons (car opt-ls) ret-ls))))))
(define (looks-like-an-option string)
(define (m? rx)
(regexp-exec rx string))
(or (m? short-opt-rx)
(m? long-opt-with-value-rx)
(m? long-opt-no-value-rx)))
(define (process-options specs argument-ls)
;; Use SPECS to scan ARGUMENT-LS; return (FOUND . ETC).
;; FOUND is an unordered list of pairs (NAME . VALUE) 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 (s:name spec) spec))
specs))
(sc-idx (let loop ((ls specs) (acc '()))
(if (null? ls) acc
(loop (cdr ls) (let* ((spec (car ls))
(sc (s:single-char spec)))
(if sc
(acons sc spec acc)
acc)))))))
(let loop ((arg-ls argument-ls) (found '()) (etc '()))
(let ((eat! (lambda (spec ls)
(let ((val!loop (lambda (val rest)
(let* ((mm? (s:merge-multiple? spec))
(who (s:name spec))
(old (and mm? (assq-ref found who)))
(new (and (not old)
(cons who
(if mm?
(list val)
val)))))
(and old (set-cdr! (last-pair old)
(list val)))
(loop (rest ls)
(if new (cons new found) found)
etc))))
(no-following? (lambda ()
(or (null? (cdr ls))
(looks-like-an-option
(cadr ls))))))
(case (s:value-policy spec)
((optional)
(if (no-following?)
(val!loop #t cdr)
(val!loop (cadr ls) cddr)))
((#t)
(if (no-following?)
(error "option must be specified with argument:"
(s:name spec))
(val!loop (cadr ls) cddr)))
(else
(val!loop #t cdr)))))))
(if (null? arg-ls)
(cons found (reverse etc)) ;;; retval
(let ((ERR:no-such (lambda (x)
(error "no such option:" x)))
(check (lambda (two? rx)
(and=> (regexp-exec rx (car arg-ls))
(lambda (m)
(let ((one (msub m 1)))
(if two?
(cons one (msub m 2))
one)))))))
(cond ((check #f short-opt-rx)
=> (lambda (c)
(eat! (or (assq-ref sc-idx (string-ref c 0))
(ERR:no-such c))
arg-ls)))
((check #f long-opt-no-value-rx)
=> (lambda (opt)
(eat! (or (assq-ref idx (string->symbol opt))
(ERR:no-such opt))
arg-ls)))
((check #t long-opt-with-value-rx)
=> (lambda (pair)
(let* ((opt (car pair))
(spec (or (assq-ref idx (string->symbol opt))
(ERR:no-such opt))))
(if (s:value-policy spec)
(eat! spec (append
(list 'ignored (cdr pair))
(cdr arg-ls)))
(error "option does not support argument:"
opt)))))
(else
(loop (cdr arg-ls)
found
(cons (car arg-ls) etc))))))))))
;; Parse the command line given in @var{args} (which must be a list of
;; strings) according to the option specification @var{grammar}.
;;
;; The @var{grammar} argument is expected to be a list of this form:
;;
;; @code{((@var{option} (@var{property} @var{value}) @dots{}) @dots{})}
;;
;; where each @var{option} is a symbol denoting the long option, but
;; without the two leading dashes (e.g. @code{version} if the option is
;; called @code{--version}).
;;
;; For each option, there may be list of arbitrarily many property/value
;; pairs. The order of the pairs is not important, but every property may
;; only appear once in the property list. The following table lists the
;; possible properties:
;;
;; @table @asis
;; @item @code{(single-char @var{char})}
;; Accept @code{-@var{char}} as a single-character equivalent to
;; @code{--@var{option}}. This is how to specify traditional Unix-style
;; flags.
;;
;; @item @code{(required? @var{bool})}
;; If @var{bool} is true, the option is required. @code{getopt-long} will
;; raise an error if it is not found in @var{args}.
;;
;; @item @code{(value @var{bool})}
;; If @var{bool} is @code{#t}, the option accepts a value; if it is
;; @code{#f}, it does not; and if it is the symbol @code{optional}, the
;; option may appear in @var{args} with or without a value.
;;
;; @item @code{(merge-multiple? @var{bool})}
;; If @var{bool} is @code{#t} and the @code{value} property is not
;; @code{#f}, all (one or multiple) occurrances are merged into a list
;; with order retained. If @code{#f}, each instance of the option results
;; in a separate entry in the resulting alist.
;;
;; @item @code{(predicate @var{func})}
;; If the option accepts a value (i.e. you specified @code{(value #t)} for
;; this option), then @code{getopt-long} will apply @var{func} to the
;; value, and throw an exception if it returns @code{#f}. @var{func}
;; should be a procedure which accepts a string and returns a boolean
;; value; you may need to use quasiquotes to get it into @var{grammar}.
;; @end table
;;
(define (getopt-long args grammar)
(let* ((program-arguments args)
(option-desc-list grammar)
(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 (s:name spec)))
(and (s:required? spec)
(or (assq name found)
(error "option must be specified:" name)))
(and=> (and (assq name found) (s:predicate spec))
(lambda (pred)
(for-each (lambda (val)
(or (pred val)
(error "option predicate failed:"
name)))
;; consider all occurances
(if (s:merge-multiple? spec)
(assq-ref found name)
(let loop ((ls found) (acc '()))
(if (null? ls)
acc
(loop (cdr ls)
(if (eq? (caar ls) name)
(cons (cdar ls) acc)
acc))))))))))
specifications)
(acons '() rest-ls found)))
;; Search @var{options} for a command line option named @var{key} and
;; return its value, if found. If the option has no value, but was given,
;; return @code{#t}. If the option was not given, return @var{default}.
;; @var{options} must be the result of a call to @code{getopt-long}.
;;
(define (option-ref options key default)
(or (assq-ref options key) default))
;;; getopt-long.scm ends here
_______________________________________________
Guile-user mailing list
[email protected]
http://lists.gnu.org/mailman/listinfo/guile-user