[bpt/guile.git] / ice-9 / getopt-long.scm

;;; Copyright (C) 1998, 2001 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 (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 (some remove-if-not))
  :export (getopt-long option-ref))

(define option-spec-fields '(name
                             value
                             required?
                             single-char
                             predicate
                             value-policy))

(define option-spec (make-record-type 'option-spec option-spec-fields))
(define make-option-spec (record-constructor option-spec option-spec-fields))

(define (define-one-option-spec-field-accessor field)
  `(define ,(symbol-append 'option-spec-> field)        ;;; name slib-compat
     (record-accessor option-spec ',field)))

(define (define-one-option-spec-field-modifier field)
  `(define ,(symbol-append 'set-option-spec- field '!)  ;;; name slib-compat
     (record-modifier option-spec ',field)))

(defmacro define-all-option-spec-accessors/modifiers ()
  `(begin
     ,@(map define-one-option-spec-field-accessor option-spec-fields)
     ,@(map define-one-option-spec-field-modifier option-spec-fields)))

(define-all-option-spec-accessors/modifiers)

(define make-option-spec
  (let ((ctor (record-constructor option-spec '(name))))
    (lambda (name)
      (ctor name))))

(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 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 (match-substring 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
                                      (match-substring match 1)))))
                      (extra (match-substring match 2)))
                  (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)
  (some (lambda (rx)
          (regexp-exec rx string))
        `(,short-opt-rx
          ,long-opt-with-value-rx
          ,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 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!
                                       spec
                                       ;; handle multiple occurrances
                                       (cond ((option-spec->value 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 ((regexp-exec short-opt-rx (car argument-ls))
                   => (lambda (match)
                        (let* ((c (match-substring match 1))
                               (spec (or (assoc-ref sc-idx c)
                                         (error "no such option:" c))))
                          (eat! spec argument-ls))))
                  ((regexp-exec long-opt-no-value-rx (car argument-ls))
                   => (lambda (match)
                        (let* ((opt (match-substring match 1))
                               (spec (or (assoc-ref idx opt)
                                         (error "no such option:" opt))))
                          (eat! spec argument-ls))))
                  ((regexp-exec long-opt-with-value-rx (car argument-ls))
                   => (lambda (match)
                        (let* ((opt (match-substring match 1))
                               (spec (or (assoc-ref idx opt)
                                         (error "no such option:" opt))))
                          (if (option-spec->value-policy spec)
                              (eat! spec (append
                                          (list 'ignored
                                                (match-substring match 2))
                                          (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:

    <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."
  (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 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 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
Commit	Line	Data
64705682	1	;;; Copyright (C) 1998, 2001 Free Software Foundation, Inc.
4925695e JB	2	;;;
	3	;;; This program is free software; you can redistribute it and/or modify
	4	;;; it under the terms of the GNU General Public License as published by
	5	;;; the Free Software Foundation; either version 2 of the License, or
	6	;;; (at your option) any later version.
64705682	7	;;;
4925695e JB	8	;;; This program is distributed in the hope that it will be useful,
	9	;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
	10	;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
	11	;;; GNU General Public License for more details.
64705682	12	;;;
4925695e JB	13	;;; You should have received a copy of the GNU General Public License
	14	;;; along with this program; if not, write to the Free Software
	15	;;; Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
a482f2cc MV	16	;;;
	17	;;; As a special exception, the Free Software Foundation gives permission
	18	;;; for additional uses of the text contained in its release of GUILE.
	19	;;;
	20	;;; The exception is that, if you link the GUILE library with other files
	21	;;; to produce an executable, this does not by itself cause the
	22	;;; resulting executable to be covered by the GNU General Public License.
	23	;;; Your use of that executable is in no way restricted on account of
	24	;;; linking the GUILE library code into it.
	25	;;;
	26	;;; This exception does not however invalidate any other reasons why
	27	;;; the executable file might be covered by the GNU General Public License.
	28	;;;
	29	;;; This exception applies only to the code released by the
	30	;;; Free Software Foundation under the name GUILE. If you copy
	31	;;; code from other Free Software Foundation releases into a copy of
	32	;;; GUILE, as the General Public License permits, the exception does
	33	;;; not apply to the code that you add in this way. To avoid misleading
	34	;;; anyone as to the status of such modified files, you must delete
	35	;;; this exception notice from them.
	36	;;;
	37	;;; If you write modifications of your own for GUILE, it is your choice
	38	;;; whether to permit this exception to apply to your modifications.
	39	;;; If you do not wish that, delete this exception notice.
64705682	40
3925d0c3 TTN	41	;;; Author: Russ McManus (rewritten by Thien-Thi Nguyen)
3925d0c3 TTN	42
64705682 TTN	43	;;; Commentary:
64705682 TTN	44
4925695e	45	;;; This module implements some complex command line option parsing, in
3925d0c3	46	;;; the spirit of the GNU C library function `getopt_long'. Both long
4925695e	47	;;; and short options are supported.
64705682	48	;;;
4925695e JB	49	;;; The theory is that people should be able to constrain the set of
	50	;;; options they want to process using a grammar, rather than some arbitrary
	51	;;; structure. The grammar makes the option descriptions easy to read.
64705682	52	;;;
3925d0c3 TTN	53	;;; `getopt-long' is a procedure for parsing command-line arguments in a
	54	;;; manner consistent with other GNU programs. `option-ref' is a procedure
	55	;;; that facilitates processing of the `getopt-long' return value.
4925695e JB	56
	57	;;; (getopt-long ARGS GRAMMAR)
	58	;;; Parse the arguments ARGS according to the argument list grammar GRAMMAR.
	59	;;;
	60	;;; ARGS should be a list of strings. Its first element should be the
	61	;;; name of the program; subsequent elements should be the arguments
	62	;;; that were passed to the program on the command line. The
	63	;;; `program-arguments' procedure returns a list of this form.
	64	;;;
	65	;;; GRAMMAR is a list of the form:
	66	;;; ((OPTION (PROPERTY VALUE) ...) ...)
	67	;;;
	68	;;; Each OPTION should be a symbol. `getopt-long' will accept a
	69	;;; command-line option named `--OPTION'.
	70	;;; Each option can have the following (PROPERTY VALUE) pairs:
64705682	71	;;;
4925695e JB	72	;;; (single-char CHAR) --- Accept `-CHAR' as a single-character
	73	;;; equivalent to `--OPTION'. This is how to specify traditional
	74	;;; Unix-style flags.
	75	;;; (required? BOOL) --- If BOOL is true, the option is required.
	76	;;; getopt-long will raise an error if it is not found in ARGS.
	77	;;; (value BOOL) --- If BOOL is #t, the option accepts a value; if
	78	;;; it is #f, it does not; and if it is the symbol
	79	;;; `optional', the option may appear in ARGS with or
64705682	80	;;; without a value.
4925695e JB	81	;;; (predicate FUNC) --- If the option accepts a value (i.e. you
	82	;;; specified `(value #t)' for this option), then getopt
	83	;;; will apply FUNC to the value, and throw an exception
	84	;;; if it returns #f. FUNC should be a procedure which
	85	;;; accepts a string and returns a boolean value; you may
	86	;;; need to use quasiquotes to get it into GRAMMAR.
	87	;;;
	88	;;; The (PROPERTY VALUE) pairs may occur in any order, but each
	89	;;; property may occur only once. By default, options do not have
	90	;;; single-character equivalents, are not required, and do not take
	91	;;; values.
64705682	92	;;;
4925695e JB	93	;;; In ARGS, single-character options may be combined, in the usual
	94	;;; Unix fashion: ("-x" "-y") is equivalent to ("-xy"). If an option
	95	;;; accepts values, then it must be the last option in the
	96	;;; combination; the value is the next argument. So, for example, using
	97	;;; the following grammar:
	98	;;; ((apples (single-char #\a))
	99	;;; (blimps (single-char #\b) (value #t))
	100	;;; (catalexis (single-char #\c) (value #t)))
	101	;;; the following argument lists would be acceptable:
	102	;;; ("-a" "-b" "bang" "-c" "couth") ("bang" and "couth" are the values
	103	;;; for "blimps" and "catalexis")
	104	;;; ("-ab" "bang" "-c" "couth") (same)
	105	;;; ("-ac" "couth" "-b" "bang") (same)
	106	;;; ("-abc" "couth" "bang") (an error, since `-b' is not the
	107	;;; last option in its combination)
	108	;;;
	109	;;; If an option's value is optional, then `getopt-long' decides
	110	;;; whether it has a value by looking at what follows it in ARGS. If
3925d0c3 TTN	111	;;; the next element is does not appear to be an option itself, then
3925d0c3 TTN	112	;;; that element is the option's value.
4925695e JB	113	;;;
	114	;;; The value of a long option can appear as the next element in ARGS,
	115	;;; or it can follow the option name, separated by an `=' character.
	116	;;; Thus, using the same grammar as above, the following argument lists
	117	;;; are equivalent:
	118	;;; ("--apples" "Braeburn" "--blimps" "Goodyear")
	119	;;; ("--apples=Braeburn" "--blimps" "Goodyear")
	120	;;; ("--blimps" "Goodyear" "--apples=Braeburn")
	121	;;;
	122	;;; If the option "--" appears in ARGS, argument parsing stops there;
	123	;;; subsequent arguments are returned as ordinary arguments, even if
	124	;;; they resemble options. So, in the argument list:
	125	;;; ("--apples" "Granny Smith" "--" "--blimp" "Goodyear")
	126	;;; `getopt-long' will recognize the `apples' option as having the
	127	;;; value "Granny Smith", but it will not recognize the `blimp'
	128	;;; option; it will return the strings "--blimp" and "Goodyear" as
	129	;;; ordinary argument strings.
	130	;;;
	131	;;; The `getopt-long' function returns the parsed argument list as an
	132	;;; assocation list, mapping option names --- the symbols from GRAMMAR
	133	;;; --- onto their values, or #t if the option does not accept a value.
	134	;;; Unused options do not appear in the alist.
	135	;;;
	136	;;; All arguments that are not the value of any option are returned
	137	;;; as a list, associated with the empty list.
	138	;;;
	139	;;; `getopt-long' throws an exception if:
3925d0c3 TTN	140	;;; - it finds an unrecognized property in GRAMMAR
3925d0c3 TTN	141	;;; - the value of the `single-char' property is not a character
4925695e JB	142	;;; - it finds an unrecognized option in ARGS
	143	;;; - a required option is omitted
	144	;;; - an option that requires an argument doesn't get one
	145	;;; - an option that doesn't accept an argument does get one (this can
	146	;;; only happen using the long option `--opt=value' syntax)
	147	;;; - an option predicate fails
	148	;;;
	149	;;; So, for example:
	150	;;;
	151	;;; (define grammar
	152	;;; `((lockfile-dir (required? #t)
	153	;;; (value #t)
	154	;;; (single-char #\k)
	155	;;; (predicate ,file-is-directory?))
	156	;;; (verbose (required? #f)
	157	;;; (single-char #\v)
	158	;;; (value #f))
	159	;;; (x-includes (single-char #\x))
64705682	160	;;; (rnet-server (single-char #\y)
4925695e JB	161	;;; (predicate ,string?))))
4925695e JB	162	;;;
64705682	163	;;; (getopt-long '("my-prog" "-vk" "/tmp" "foo1" "--x-includes=/usr/include"
4925695e JB	164	;;; "--rnet-server=lamprod" "--" "-fred" "foo2" "foo3")
	165	;;; grammar)
	166	;;; => ((() "foo1" "-fred" "foo2" "foo3")
	167	;;; (rnet-server . "lamprod")
	168	;;; (x-includes . "/usr/include")
	169	;;; (lockfile-dir . "/tmp")
	170	;;; (verbose . #t))
	171
3925d0c3 TTN	172	;;; (option-ref OPTIONS KEY DEFAULT)
	173	;;; Return value in alist OPTIONS using KEY, a symbol; or DEFAULT if not
	174	;;; found. The value is either a string or `#t'.
	175	;;;
	176	;;; For example, using the `getopt-long' return value from above:
	177	;;;
	178	;;; (option-ref (getopt-long ...) 'x-includes 42) => "/usr/include"
	179	;;; (option-ref (getopt-long ...) 'not-a-key! 31) => 31
	180
64705682	181	;;; Code:
4925695e JB	182
4925695e JB	183	(define-module (ice-9 getopt-long)
3925d0c3 TTN	184	:use-module ((ice-9 common-list) :select (some remove-if-not))
3925d0c3 TTN	185	:export (getopt-long option-ref))
4925695e	186
3925d0c3 TTN	187	(define option-spec-fields '(name
	188	value
	189	required?
	190	single-char
	191	predicate
	192	value-policy))
4925695e	193
3925d0c3 TTN	194	(define option-spec (make-record-type 'option-spec option-spec-fields))
3925d0c3 TTN	195	(define make-option-spec (record-constructor option-spec option-spec-fields))
4925695e	196
3925d0c3 TTN	197	(define (define-one-option-spec-field-accessor field)
	198	`(define ,(symbol-append 'option-spec-> field) ;;; name slib-compat
	199	(record-accessor option-spec ',field)))
4925695e	200
3925d0c3 TTN	201	(define (define-one-option-spec-field-modifier field)
	202	`(define ,(symbol-append 'set-option-spec- field '!) ;;; name slib-compat
	203	(record-modifier option-spec ',field)))
4925695e	204
3925d0c3 TTN	205	(defmacro define-all-option-spec-accessors/modifiers ()
	206	`(begin
	207	,@(map define-one-option-spec-field-accessor option-spec-fields)
	208	,@(map define-one-option-spec-field-modifier option-spec-fields)))
4925695e	209
3925d0c3	210	(define-all-option-spec-accessors/modifiers)
4925695e	211
3925d0c3 TTN	212	(define make-option-spec
	213	(let ((ctor (record-constructor option-spec '(name))))
	214	(lambda (name)
	215	(ctor name))))
64705682	216
4925695e	217	(define (parse-option-spec desc)
3925d0c3 TTN	218	(let ((spec (make-option-spec (symbol->string (car desc)))))
	219	(for-each (lambda (desc-elem)
	220	(let ((given (lambda () (cadr desc-elem))))
	221	(case (car desc-elem)
	222	((required?)
	223	(set-option-spec-required?! spec (given)))
	224	((value)
	225	(set-option-spec-value-policy! spec (given)))
	226	((single-char)
	227	(or (char? (given))
	228	(error "`single-char' value must be a char!"))
	229	(set-option-spec-single-char! spec (given)))
	230	((predicate)
	231	(set-option-spec-predicate!
	232	spec ((lambda (pred)
	233	(lambda (name val)
	234	(or (not val)
	235	(pred val)
	236	(error "option predicate failed:" name))))
	237	(given))))
	238	(else
	239	(error "invalid getopt-long option property:"
	240	(car desc-elem))))))
	241	(cdr desc))
	242	spec))
4925695e	243
4925695e	244	(define (split-arg-list argument-list)
3925d0c3 TTN	245	;; Scan ARGUMENT-LIST for "--" and return (BEFORE-LS . AFTER-LS).
	246	;; Discard the "--". If no "--" is found, AFTER-LS is empty.
	247	(let loop ((yes '()) (no argument-list))
	248	(cond ((null? no) (cons (reverse yes) no))
	249	((string=? "--" (car no)) (cons (reverse yes) (cdr no)))
	250	(else (loop (cons (car no) yes) (cdr no))))))
4925695e	251
3925d0c3 TTN	252	(define short-opt-rx (make-regexp "^-([a-zA-Z]+)(.*)"))
3925d0c3 TTN	253	(define long-opt-no-value-rx (make-regexp "^--([^=]+)$"))
4925695e JB	254	(define long-opt-with-value-rx (make-regexp "^--([^=]+)=(.*)"))
4925695e JB	255
3925d0c3 TTN	256	(define (match-substring match which)
	257	;; condensed from (ice-9 regex) `match:{substring,start,end}'
	258	(let ((sel (vector-ref match (1+ which))))
	259	(substring (vector-ref match 0) (car sel) (cdr sel))))
4925695e	260
3925d0c3 TTN	261	(define (expand-clumped-singles opt-ls)
	262	;; example: ("--xyz" "-abc5d") => ("--xyz" "-a" "-b" "-c" "5d")
	263	(let loop ((opt-ls opt-ls) (ret-ls '()))
	264	(cond ((null? opt-ls)
	265	(reverse ret-ls)) ;;; retval
	266	((regexp-exec short-opt-rx (car opt-ls))
	267	=> (lambda (match)
	268	(let ((singles (reverse
	269	(map (lambda (c)
	270	(string-append "-" (make-string 1 c)))
	271	(string->list
	272	(match-substring match 1)))))
	273	(extra (match-substring match 2)))
	274	(loop (cdr opt-ls)
	275	(append (if (string=? "" extra)
	276	singles
	277	(cons extra singles))
	278	ret-ls)))))
	279	(else (loop (cdr opt-ls)
	280	(cons (car opt-ls) ret-ls))))))
4925695e	281
3925d0c3 TTN	282	(define (looks-like-an-option string)
	283	(some (lambda (rx)
	284	(regexp-exec rx string))
	285	`(,short-opt-rx
	286	,long-opt-with-value-rx
	287	,long-opt-no-value-rx)))
4925695e	288
3925d0c3 TTN	289	(define (process-options specs argument-ls)
	290	;; Use SPECS to scan ARGUMENT-LS; return (FOUND . ETC).
	291	;; FOUND is an unordered list of option specs for found options, while ETC
	292	;; is an order-maintained list of elements in ARGUMENT-LS that are neither
	293	;; options nor their values.
	294	(let ((idx (map (lambda (spec)
	295	(cons (option-spec->name spec) spec))
	296	specs))
	297	(sc-idx (map (lambda (spec)
	298	(cons (make-string 1 (option-spec->single-char spec))
	299	spec))
	300	(remove-if-not option-spec->single-char specs))))
	301	(let loop ((argument-ls argument-ls) (found '()) (etc '()))
	302	(let ((eat! (lambda (spec ls)
	303	(let ((val!loop (lambda (val n-ls n-found n-etc)
05326ffd TTN	304	(set-option-spec-value!
	305	spec
	306	;; handle multiple occurrances
	307	(cond ((option-spec->value spec)
	308	=> (lambda (cur)
	309	((if (list? cur) cons list)
	310	val cur)))
	311	(else val)))
3925d0c3 TTN	312	(loop n-ls n-found n-etc)))
	313	(ERR:no-arg (lambda ()
	314	(error (string-append
	315	"option must be specified"
	316	" with argument:")
	317	(option-spec->name spec)))))
	318	(cond
	319	((eq? 'optional (option-spec->value-policy spec))
	320	(if (or (null? (cdr ls))
	321	(looks-like-an-option (cadr ls)))
	322	(val!loop #t
	323	(cdr ls)
	324	(cons spec found)
	325	etc)
	326	(val!loop (cadr ls)
	327	(cddr ls)
	328	(cons spec found)
	329	etc)))
	330	((eq? #t (option-spec->value-policy spec))
	331	(if (or (null? (cdr ls))
	332	(looks-like-an-option (cadr ls)))
	333	(ERR:no-arg)
	334	(val!loop (cadr ls)
	335	(cddr ls)
	336	(cons spec found)
	337	etc)))
	338	(else
	339	(val!loop #t
	340	(cdr ls)
	341	(cons spec found)
	342	etc)))))))
	343	(if (null? argument-ls)
	344	(cons found (reverse etc)) ;;; retval
	345	(cond ((regexp-exec short-opt-rx (car argument-ls))
	346	=> (lambda (match)
	347	(let* ((c (match-substring match 1))
	348	(spec (or (assoc-ref sc-idx c)
	349	(error "no such option:" c))))
	350	(eat! spec argument-ls))))
	351	((regexp-exec long-opt-no-value-rx (car argument-ls))
	352	=> (lambda (match)
	353	(let* ((opt (match-substring match 1))
	354	(spec (or (assoc-ref idx opt)
	355	(error "no such option:" opt))))
	356	(eat! spec argument-ls))))
	357	((regexp-exec long-opt-with-value-rx (car argument-ls))
	358	=> (lambda (match)
	359	(let* ((opt (match-substring match 1))
	360	(spec (or (assoc-ref idx opt)
	361	(error "no such option:" opt))))
	362	(if (option-spec->value-policy spec)
	363	(eat! spec (append
	364	(list 'ignored
	365	(match-substring match 2))
	366	(cdr argument-ls)))
	367	(error "option does not support argument:"
	368	opt)))))
	369	(else
	370	(loop (cdr argument-ls)
	371	found
	372	(cons (car argument-ls) etc)))))))))
4925695e JB	373
	374	(define (getopt-long program-arguments option-desc-list)
	375	"Process options, handling both long and short options, similar to
	376	the glibc function 'getopt_long'. PROGRAM-ARGUMENTS should be a value
	377	similar to what (program-arguments) returns. OPTION-DESC-LIST is a
	378	list of option descriptions. Each option description must satisfy the
	379	following grammar:
	380
	381	<option-spec> :: (<name> . <attribute-ls>)
	382	<attribute-ls> :: (<attribute> . <attribute-ls>)
	383	\| ()
	384	<attribute> :: <required-attribute>
	385	\| <arg-required-attribute>
	386	\| <single-char-attribute>
	387	\| <predicate-attribute>
	388	\| <value-attribute>
	389	<required-attribute> :: (required? <boolean>)
	390	<single-char-attribute> :: (single-char <char>)
	391	<value-attribute> :: (value #t)
	392	(value #f)
	393	(value optional)
	394	<predicate-attribute> :: (predicate <1-ary-function>)
	395
	396	The procedure returns an alist of option names and values. Each
	397	option name is a symbol. The option value will be '#t' if no value
	398	was specified. There is a special item in the returned alist with a
	399	key of the empty list, (): the list of arguments that are not options
	400	or option values.
64705682	401	By default, options are not required, and option values are not
4925695e JB	402	required. By default, single character equivalents are not supported;
4925695e JB	403	if you want to allow the user to use single character options, you need
3925d0c3	404	to add a `single-char' clause to the option description."
4925695e JB	405	(let* ((specifications (map parse-option-spec option-desc-list))
4925695e JB	406	(pair (split-arg-list (cdr program-arguments)))
3925d0c3 TTN	407	(split-ls (expand-clumped-singles (car pair)))
	408	(non-split-ls (cdr pair))
	409	(found/etc (process-options specifications split-ls))
	410	(found (car found/etc))
	411	(rest-ls (append (cdr found/etc) non-split-ls)))
	412	(for-each (lambda (spec)
	413	(let ((name (option-spec->name spec))
	414	(val (option-spec->value spec)))
	415	(and (option-spec->required? spec)
	416	(or (memq spec found)
	417	(error "option must be specified:" name)))
	418	(and (memq spec found)
	419	(eq? #t (option-spec->value-policy spec))
	420	(or val
	421	(error "option must be specified with argument:"
	422	name)))
	423	(let ((pred (option-spec->predicate spec)))
	424	(and pred (pred name val)))))
	425	specifications)
	426	(cons (cons '() rest-ls)
05326ffd TTN	427	(let ((multi-count (map (lambda (desc)
	428	(cons (car desc) 0))
	429	option-desc-list)))
	430	(map (lambda (spec)
	431	(let ((name (string->symbol (option-spec->name spec))))
	432	(cons name
	433	;; handle multiple occurrances
	434	(let ((maybe-ls (option-spec->value spec)))
	435	(if (list? maybe-ls)
	436	(let* ((look (assq name multi-count))
	437	(idx (cdr look))
	438	(val (list-ref maybe-ls idx)))
	439	(set-cdr! look (1+ idx)) ; ugh!
	440	val)
	441	maybe-ls)))))
	442	found)))))
4925695e JB	443
4925695e JB	444	(define (option-ref options key default)
3925d0c3 TTN	445	"Return value in alist OPTIONS using KEY, a symbol; or DEFAULT if not found.
	446	The value is either a string or `#t'."
	447	(or (assq-ref options key) default))
64705682 TTN	448
64705682 TTN	449	;;; getopt-long.scm ends here