module/ice-9/getopt-long.scm

   1 ;;; Copyright (C) 1998, 2001, 2006, 2009, 2011 Free Software Foundation, Inc.
   2 ;;;
   3 ;;;; This library is free software; you can redistribute it and/or
   4 ;;;; modify it under the terms of the GNU Lesser General Public
   5 ;;;; License as published by the Free Software Foundation; either
   6 ;;;; version 3 of the License, or (at your option) any later version.
   7 ;;;;
   8 ;;;; This library 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 GNU
  11 ;;;; Lesser General Public License for more details.
  12 ;;;;
  13 ;;;; You should have received a copy of the GNU Lesser General Public
  14 ;;;; License along with this library; if not, write to the Free Software
  15 ;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
  16
  17 ;;; Author: Russ McManus (rewritten by Thien-Thi Nguyen)
  18
  19 ;;; Commentary:
  20
  21 ;;; This module implements some complex command line option parsing, in
  22 ;;; the spirit of the GNU C library function `getopt_long'.  Both long
  23 ;;; and short options are supported.
  24 ;;;
  25 ;;; The theory is that people should be able to constrain the set of
  26 ;;; options they want to process using a grammar, rather than some arbitrary
  27 ;;; structure.  The grammar makes the option descriptions easy to read.
  28 ;;;
  29 ;;; `getopt-long' is a procedure for parsing command-line arguments in a
  30 ;;; manner consistent with other GNU programs.  `option-ref' is a procedure
  31 ;;; that facilitates processing of the `getopt-long' return value.
  32
  33 ;;; (getopt-long ARGS GRAMMAR)
  34 ;;; Parse the arguments ARGS according to the argument list grammar GRAMMAR.
  35 ;;;
  36 ;;; ARGS should be a list of strings.  Its first element should be the
  37 ;;; name of the program; subsequent elements should be the arguments
  38 ;;; that were passed to the program on the command line.  The
  39 ;;; `program-arguments' procedure returns a list of this form.
  40 ;;;
  41 ;;; GRAMMAR is a list of the form:
  42 ;;; ((OPTION (PROPERTY VALUE) ...) ...)
  43 ;;;
  44 ;;; Each OPTION should be a symbol.  `getopt-long' will accept a
  45 ;;; command-line option named `--OPTION'.
  46 ;;; Each option can have the following (PROPERTY VALUE) pairs:
  47 ;;;
  48 ;;;   (single-char CHAR) --- Accept `-CHAR' as a single-character
  49 ;;;             equivalent to `--OPTION'.  This is how to specify traditional
  50 ;;;             Unix-style flags.
  51 ;;;   (required? BOOL) --- If BOOL is true, the option is required.
  52 ;;;             getopt-long will raise an error if it is not found in ARGS.
  53 ;;;   (value BOOL) --- If BOOL is #t, the option accepts a value; if
  54 ;;;             it is #f, it does not; and if it is the symbol
  55 ;;;             `optional', the option may appear in ARGS with or
  56 ;;;             without a value.
  57 ;;;   (predicate FUNC) --- If the option accepts a value (i.e. you
  58 ;;;             specified `(value #t)' for this option), then getopt
  59 ;;;             will apply FUNC to the value, and throw an exception
  60 ;;;             if it returns #f.  FUNC should be a procedure which
  61 ;;;             accepts a string and returns a boolean value; you may
  62 ;;;             need to use quasiquotes to get it into GRAMMAR.
  63 ;;;
  64 ;;; The (PROPERTY VALUE) pairs may occur in any order, but each
  65 ;;; property may occur only once.  By default, options do not have
  66 ;;; single-character equivalents, are not required, and do not take
  67 ;;; values.
  68 ;;;
  69 ;;; In ARGS, single-character options may be combined, in the usual
  70 ;;; Unix fashion: ("-x" "-y") is equivalent to ("-xy").  If an option
  71 ;;; accepts values, then it must be the last option in the
  72 ;;; combination; the value is the next argument.  So, for example, using
  73 ;;; the following grammar:
  74 ;;;      ((apples    (single-char #\a))
  75 ;;;       (blimps    (single-char #\b) (value #t))
  76 ;;;       (catalexis (single-char #\c) (value #t)))
  77 ;;; the following argument lists would be acceptable:
  78 ;;;    ("-a" "-b" "bang" "-c" "couth")     ("bang" and "couth" are the values
  79 ;;;                                         for "blimps" and "catalexis")
  80 ;;;    ("-ab" "bang" "-c" "couth")         (same)
  81 ;;;    ("-ac" "couth" "-b" "bang")         (same)
  82 ;;;    ("-abc" "couth" "bang")             (an error, since `-b' is not the
  83 ;;;                                         last option in its combination)
  84 ;;;
  85 ;;; If an option's value is optional, then `getopt-long' decides
  86 ;;; whether it has a value by looking at what follows it in ARGS.  If
  87 ;;; the next element is does not appear to be an option itself, then
  88 ;;; that element is the option's value.
  89 ;;;
  90 ;;; The value of a long option can appear as the next element in ARGS,
  91 ;;; or it can follow the option name, separated by an `=' character.
  92 ;;; Thus, using the same grammar as above, the following argument lists
  93 ;;; are equivalent:
  94 ;;;   ("--apples" "Braeburn" "--blimps" "Goodyear")
  95 ;;;   ("--apples=Braeburn" "--blimps" "Goodyear")
  96 ;;;   ("--blimps" "Goodyear" "--apples=Braeburn")
  97 ;;;
  98 ;;; If the option "--" appears in ARGS, argument parsing stops there;
  99 ;;; subsequent arguments are returned as ordinary arguments, even if
 100 ;;; they resemble options.  So, in the argument list:
 101 ;;;         ("--apples" "Granny Smith" "--" "--blimp" "Goodyear")
 102 ;;; `getopt-long' will recognize the `apples' option as having the
 103 ;;; value "Granny Smith", but it will not recognize the `blimp'
 104 ;;; option; it will return the strings "--blimp" and "Goodyear" as
 105 ;;; ordinary argument strings.
 106 ;;;
 107 ;;; The `getopt-long' function returns the parsed argument list as an
 108 ;;; assocation list, mapping option names --- the symbols from GRAMMAR
 109 ;;; --- onto their values, or #t if the option does not accept a value.
 110 ;;; Unused options do not appear in the alist.
 111 ;;;
 112 ;;; All arguments that are not the value of any option are returned
 113 ;;; as a list, associated with the empty list.
 114 ;;;
 115 ;;; `getopt-long' throws an exception if:
 116 ;;; - it finds an unrecognized property in GRAMMAR
 117 ;;; - the value of the `single-char' property is not a character
 118 ;;; - it finds an unrecognized option in ARGS
 119 ;;; - a required option is omitted
 120 ;;; - an option that requires an argument doesn't get one
 121 ;;; - an option that doesn't accept an argument does get one (this can
 122 ;;;   only happen using the long option `--opt=value' syntax)
 123 ;;; - an option predicate fails
 124 ;;;
 125 ;;; So, for example:
 126 ;;;
 127 ;;; (define grammar
 128 ;;;   `((lockfile-dir (required? #t)
 129 ;;;                   (value #t)
 130 ;;;                   (single-char #\k)
 131 ;;;                   (predicate ,file-is-directory?))
 132 ;;;     (verbose (required? #f)
 133 ;;;              (single-char #\v)
 134 ;;;              (value #f))
 135 ;;;     (x-includes (single-char #\x))
 136 ;;;     (rnet-server (single-char #\y)
 137 ;;;                  (predicate ,string?))))
 138 ;;;
 139 ;;; (getopt-long '("my-prog" "-vk" "/tmp" "foo1" "--x-includes=/usr/include"
 140 ;;;                "--rnet-server=lamprod" "--" "-fred" "foo2" "foo3")
 141 ;;;                grammar)
 142 ;;; => ((() "foo1" "-fred" "foo2" "foo3")
 143 ;;;     (rnet-server . "lamprod")
 144 ;;;     (x-includes . "/usr/include")
 145 ;;;     (lockfile-dir . "/tmp")
 146 ;;;     (verbose . #t))
 147
 148 ;;; (option-ref OPTIONS KEY DEFAULT)
 149 ;;; Return value in alist OPTIONS using KEY, a symbol; or DEFAULT if not
 150 ;;; found.  The value is either a string or `#t'.
 151 ;;;
 152 ;;; For example, using the `getopt-long' return value from above:
 153 ;;;
 154 ;;; (option-ref (getopt-long ...) 'x-includes 42) => "/usr/include"
 155 ;;; (option-ref (getopt-long ...) 'not-a-key! 31) => 31
 156
 157 ;;; Code:
 158
 159 (define-module (ice-9 getopt-long)
 160   #:use-module ((ice-9 common-list) #:select (remove-if-not))
 161   #:use-module (srfi srfi-9)
 162   #:use-module (ice-9 match)
 163   #:use-module (ice-9 regex)
 164   #:use-module (ice-9 optargs)
 165   #:export (getopt-long option-ref))
 166
 167 (define %program-name (make-fluid "guile"))
 168 (define (program-name)
 169   (fluid-ref %program-name))
 170
 171 (define (fatal-error fmt . args)
 172   (format (current-error-port) "~a: " (program-name))
 173   (apply format (current-error-port) fmt args)
 174   (newline (current-error-port))
 175   (exit 1))
 176
 177 (define-record-type option-spec
 178   (%make-option-spec name required? option-spec->single-char predicate value-policy)
 179   option-spec?
 180   (name
 181    option-spec->name set-option-spec-name!)
 182   (required?
 183    option-spec->required? set-option-spec-required?!)
 184   (option-spec->single-char
 185    option-spec->single-char set-option-spec-single-char!)
 186   (predicate
 187    option-spec->predicate set-option-spec-predicate!)
 188   (value-policy
 189    option-spec->value-policy set-option-spec-value-policy!))
 190
 191 (define (make-option-spec name)
 192   (%make-option-spec name #f #f #f #f))
 193
 194 (define (parse-option-spec desc)
 195   (let ((spec (make-option-spec (symbol->string (car desc)))))
 196     (for-each (match-lambda
 197                (('required? val)
 198                 (set-option-spec-required?! spec val))
 199                (('value val)
 200                 (set-option-spec-value-policy! spec val))
 201                (('single-char val)
 202                 (or (char? val)
 203                     (error "`single-char' value must be a char!"))
 204                 (set-option-spec-single-char! spec val))
 205                (('predicate pred)
 206                 (set-option-spec-predicate!
 207                  spec (lambda (name val)
 208                         (or (not val)
 209                             (pred val)
 210                             (fatal-error "option predicate failed: --~a"
 211                                          name)))))
 212                ((prop val)
 213                 (error "invalid getopt-long option property:" prop)))
 214               (cdr desc))
 215     spec))
 216
 217 (define (split-arg-list argument-list)
 218   ;; Scan ARGUMENT-LIST for "--" and return (BEFORE-LS . AFTER-LS).
 219   ;; Discard the "--".  If no "--" is found, AFTER-LS is empty.
 220   (let loop ((yes '()) (no argument-list))
 221     (cond ((null? no)               (cons (reverse yes) no))
 222           ((string=? "--" (car no)) (cons (reverse yes) (cdr no)))
 223           (else (loop (cons (car no) yes) (cdr no))))))
 224
 225 (define short-opt-rx           (make-regexp "^-([a-zA-Z]+)(.*)"))
 226 (define long-opt-no-value-rx   (make-regexp "^--([^=]+)$"))
 227 (define long-opt-with-value-rx (make-regexp "^--([^=]+)=(.*)"))
 228
 229 (define (looks-like-an-option string)
 230   (or (regexp-exec short-opt-rx string)
 231       (regexp-exec long-opt-with-value-rx string)
 232       (regexp-exec long-opt-no-value-rx string)))
 233
 234 (define (process-options specs argument-ls stop-at-first-non-option)
 235   ;; Use SPECS to scan ARGUMENT-LS; return (FOUND . ETC).
 236   ;; FOUND is an unordered list of option specs for found options, while ETC
 237   ;; is an order-maintained list of elements in ARGUMENT-LS that are neither
 238   ;; options nor their values.
 239   (let ((idx (map (lambda (spec)
 240                     (cons (option-spec->name spec) spec))
 241                   specs))
 242         (sc-idx (map (lambda (spec)
 243                        (cons (make-string 1 (option-spec->single-char spec))
 244                              spec))
 245                      (remove-if-not option-spec->single-char specs))))
 246     (let loop ((unclumped 0) (argument-ls argument-ls) (found '()) (etc '()))
 247       (define (eat! spec ls)
 248         (cond
 249          ((eq? 'optional (option-spec->value-policy spec))
 250           (if (or (null? ls)
 251                   (looks-like-an-option (car ls)))
 252               (loop (- unclumped 1) ls (acons spec #t found) etc)
 253               (loop (- unclumped 2) (cdr ls) (acons spec (car ls) found) etc)))
 254          ((eq? #t (option-spec->value-policy spec))
 255           (if (or (null? ls)
 256                   (looks-like-an-option (car ls)))
 257               (fatal-error "option must be specified with argument: --~a"
 258                            (option-spec->name spec))
 259               (loop (- unclumped 2) (cdr ls) (acons spec (car ls) found) etc)))
 260          (else
 261           (loop (- unclumped 1) ls (acons spec #t found) etc))))
 262
 263       (match argument-ls
 264         (()
 265          (cons found (reverse etc)))
 266         ((opt . rest)
 267          (cond
 268           ((regexp-exec short-opt-rx opt)
 269            => (lambda (match)
 270                 (if (> unclumped 0)
 271                     ;; Next option is known not to be clumped.
 272                     (let* ((c (match:substring match 1))
 273                            (spec (or (assoc-ref sc-idx c)
 274                                      (fatal-error "no such option: -~a" c))))
 275                       (eat! spec rest))
 276                     ;; Expand a clumped group of short options.
 277                     (let* ((extra (match:substring match 2))
 278                            (unclumped-opts
 279                             (append (map (lambda (c)
 280                                            (string-append "-" (make-string 1 c)))
 281                                          (string->list
 282                                           (match:substring match 1)))
 283                                     (if (string=? "" extra) '() (list extra)))))
 284                       (loop (length unclumped-opts)
 285                             (append unclumped-opts rest)
 286                             found
 287                             etc)))))
 288           ((regexp-exec long-opt-no-value-rx opt)
 289            => (lambda (match)
 290                 (let* ((opt (match:substring match 1))
 291                        (spec (or (assoc-ref idx opt)
 292                                  (fatal-error "no such option: --~a" opt))))
 293                   (eat! spec rest))))
 294           ((regexp-exec long-opt-with-value-rx opt)
 295            => (lambda (match)
 296                 (let* ((opt (match:substring match 1))
 297                        (spec (or (assoc-ref idx opt)
 298                                  (fatal-error "no such option: --~a" opt))))
 299                   (if (option-spec->value-policy spec)
 300                       (eat! spec (cons (match:substring match 2) rest))
 301                       (fatal-error "option does not support argument: --~a"
 302                                    opt)))))
 303           ((and stop-at-first-non-option
 304                 (<= unclumped 0))
 305            (cons found (append (reverse etc) argument-ls)))
 306           (else
 307            (loop (- unclumped 1) rest found (cons opt etc)))))))))
 308
 309 (define* (getopt-long program-arguments option-desc-list
 310                       #:key stop-at-first-non-option)
 311   "Process options, handling both long and short options, similar to
 312 the glibc function 'getopt_long'.  PROGRAM-ARGUMENTS should be a value
 313 similar to what (program-arguments) returns.  OPTION-DESC-LIST is a
 314 list of option descriptions.  Each option description must satisfy the
 315 following grammar:
 316
 317     <option-spec>           :: (<name> . <attribute-ls>)
 318     <attribute-ls>          :: (<attribute> . <attribute-ls>)
 319                                | ()
 320     <attribute>             :: <required-attribute>
 321                                | <arg-required-attribute>
 322                                | <single-char-attribute>
 323                                | <predicate-attribute>
 324                                | <value-attribute>
 325     <required-attribute>    :: (required? <boolean>)
 326     <single-char-attribute> :: (single-char <char>)
 327     <value-attribute>       :: (value #t)
 328                                (value #f)
 329                                (value optional)
 330     <predicate-attribute>   :: (predicate <1-ary-function>)
 331
 332     The procedure returns an alist of option names and values.  Each
 333 option name is a symbol.  The option value will be '#t' if no value
 334 was specified.  There is a special item in the returned alist with a
 335 key of the empty list, (): the list of arguments that are not options
 336 or option values.
 337     By default, options are not required, and option values are not
 338 required.  By default, single character equivalents are not supported;
 339 if you want to allow the user to use single character options, you need
 340 to add a `single-char' clause to the option description."
 341   (with-fluids ((%program-name (car program-arguments)))
 342     (let* ((specifications (map parse-option-spec option-desc-list))
 343            (pair (split-arg-list (cdr program-arguments)))
 344            (split-ls (car pair))
 345            (non-split-ls (cdr pair))
 346            (found/etc (process-options specifications split-ls
 347                                        stop-at-first-non-option))
 348            (found (car found/etc))
 349            (rest-ls (append (cdr found/etc) non-split-ls)))
 350       (for-each (lambda (spec)
 351                   (let ((name (option-spec->name spec))
 352                         (val (assq-ref found spec)))
 353                     (and (option-spec->required? spec)
 354                          (or val
 355                              (fatal-error "option must be specified: --~a"
 356                                           name)))
 357                     (let ((pred (option-spec->predicate spec)))
 358                       (and pred (pred name val)))))
 359                 specifications)
 360       (for-each (lambda (spec+val)
 361                   (set-car! spec+val
 362                             (string->symbol (option-spec->name (car spec+val)))))
 363                 found)
 364       (cons (cons '() rest-ls) found))))
 365
 366 (define (option-ref options key default)
 367   "Return value in alist OPTIONS using KEY, a symbol; or DEFAULT if not found.
 368 The value is either a string or `#t'."
 369   (or (assq-ref options key) default))
 370
 371 ;;; getopt-long.scm ends here