ice-9/getopt-long.scm

   1 ;;; Copyright (C) 1998, 2001 Free Software Foundation, Inc.
   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.
   7 ;;;
   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.
  12 ;;;
  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
  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.
  40
  41 ;;; Author: Russ McManus (rewritten by Thien-Thi Nguyen)
  42
  43 ;;; Commentary:
  44
  45 ;;; This module implements some complex command line option parsing, in
  46 ;;; the spirit of the GNU C library function `getopt_long'.  Both long
  47 ;;; and short options are supported.
  48 ;;;
  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.
  52 ;;;
  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.
  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:
  71 ;;;
  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
  80 ;;;             without a value.
  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.
  92 ;;;
  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
 111 ;;; the next element is does not appear to be an option itself, then
 112 ;;; that element is the option's value.
 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:
 140 ;;; - it finds an unrecognized property in GRAMMAR
 141 ;;; - the value of the `single-char' property is not a character
 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))
 160 ;;;     (rnet-server (single-char #\y)
 161 ;;;                  (predicate ,string?))))
 162 ;;;
 163 ;;; (getopt-long '("my-prog" "-vk" "/tmp" "foo1" "--x-includes=/usr/include"
 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
 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
 181 ;;; Code:
 182
 183 (define-module (ice-9 getopt-long)
 184   :use-module ((ice-9 common-list) :select (some remove-if-not))
 185   :export (getopt-long option-ref))
 186
 187 (define option-spec-fields '(name
 188                              value
 189                              required?
 190                              single-char
 191                              predicate
 192                              value-policy))
 193
 194 (define option-spec (make-record-type 'option-spec option-spec-fields))
 195 (define make-option-spec (record-constructor option-spec option-spec-fields))
 196
 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)))
 200
 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)))
 204
 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)))
 209
 210 (define-all-option-spec-accessors/modifiers)
 211
 212 (define make-option-spec
 213   (let ((ctor (record-constructor option-spec '(name))))
 214     (lambda (name)
 215       (ctor name))))
 216
 217 (define (parse-option-spec desc)
 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))
 243
 244 (define (split-arg-list argument-list)
 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))))))
 251
 252 (define short-opt-rx           (make-regexp "^-([a-zA-Z]+)(.*)"))
 253 (define long-opt-no-value-rx   (make-regexp "^--([^=]+)$"))
 254 (define long-opt-with-value-rx (make-regexp "^--([^=]+)=(.*)"))
 255
 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))))
 260
 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))))))
 281
 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)))
 288
 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)
 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)))
 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)))))))))
 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.
 401     By default, options are not required, and option values are not
 402 required.  By default, single character equivalents are not supported;
 403 if you want to allow the user to use single character options, you need
 404 to add a `single-char' clause to the option description."
 405   (let* ((specifications (map parse-option-spec option-desc-list))
 406          (pair (split-arg-list (cdr program-arguments)))
 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)
 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)))))
 443
 444 (define (option-ref options key default)
 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))
 448
 449 ;;; getopt-long.scm ends here