| 1 | ;;; Copyright (C) 1998, 2001, 2006, 2009 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 (some remove-if-not)) |
| 161 | :export (getopt-long option-ref)) |
| 162 | |
| 163 | (eval-when (eval load compile) |
| 164 | ;; This binding is used both at compile-time and run-time. |
| 165 | (define option-spec-fields '(name |
| 166 | value |
| 167 | required? |
| 168 | single-char |
| 169 | predicate |
| 170 | value-policy))) |
| 171 | |
| 172 | (define option-spec (make-record-type 'option-spec option-spec-fields)) |
| 173 | (define make-option-spec (record-constructor option-spec option-spec-fields)) |
| 174 | |
| 175 | (eval-when (eval load compile) |
| 176 | ;; The following procedures are used only at compile-time when expanding |
| 177 | ;; `define-all-option-spec-accessors/modifiers' (see below). |
| 178 | |
| 179 | (define (define-one-option-spec-field-accessor field) |
| 180 | `(define ,(symbol-append 'option-spec-> field) ;;; name slib-compat |
| 181 | (record-accessor option-spec ',field))) |
| 182 | |
| 183 | (define (define-one-option-spec-field-modifier field) |
| 184 | `(define ,(symbol-append 'set-option-spec- field '!) ;;; name slib-compat |
| 185 | (record-modifier option-spec ',field)))) |
| 186 | |
| 187 | (defmacro define-all-option-spec-accessors/modifiers () |
| 188 | `(begin |
| 189 | ,@(map define-one-option-spec-field-accessor option-spec-fields) |
| 190 | ,@(map define-one-option-spec-field-modifier option-spec-fields))) |
| 191 | |
| 192 | (define-all-option-spec-accessors/modifiers) |
| 193 | |
| 194 | (define make-option-spec |
| 195 | (let ((ctor (record-constructor option-spec '(name)))) |
| 196 | (lambda (name) |
| 197 | (ctor name)))) |
| 198 | |
| 199 | (define (parse-option-spec desc) |
| 200 | (let ((spec (make-option-spec (symbol->string (car desc))))) |
| 201 | (for-each (lambda (desc-elem) |
| 202 | (let ((given (lambda () (cadr desc-elem)))) |
| 203 | (case (car desc-elem) |
| 204 | ((required?) |
| 205 | (set-option-spec-required?! spec (given))) |
| 206 | ((value) |
| 207 | (set-option-spec-value-policy! spec (given))) |
| 208 | ((single-char) |
| 209 | (or (char? (given)) |
| 210 | (error "`single-char' value must be a char!")) |
| 211 | (set-option-spec-single-char! spec (given))) |
| 212 | ((predicate) |
| 213 | (set-option-spec-predicate! |
| 214 | spec ((lambda (pred) |
| 215 | (lambda (name val) |
| 216 | (or (not val) |
| 217 | (pred val) |
| 218 | (error "option predicate failed:" name)))) |
| 219 | (given)))) |
| 220 | (else |
| 221 | (error "invalid getopt-long option property:" |
| 222 | (car desc-elem)))))) |
| 223 | (cdr desc)) |
| 224 | spec)) |
| 225 | |
| 226 | (define (split-arg-list argument-list) |
| 227 | ;; Scan ARGUMENT-LIST for "--" and return (BEFORE-LS . AFTER-LS). |
| 228 | ;; Discard the "--". If no "--" is found, AFTER-LS is empty. |
| 229 | (let loop ((yes '()) (no argument-list)) |
| 230 | (cond ((null? no) (cons (reverse yes) no)) |
| 231 | ((string=? "--" (car no)) (cons (reverse yes) (cdr no))) |
| 232 | (else (loop (cons (car no) yes) (cdr no)))))) |
| 233 | |
| 234 | (define short-opt-rx (make-regexp "^-([a-zA-Z]+)(.*)")) |
| 235 | (define long-opt-no-value-rx (make-regexp "^--([^=]+)$")) |
| 236 | (define long-opt-with-value-rx (make-regexp "^--([^=]+)=(.*)")) |
| 237 | |
| 238 | (define (match-substring match which) |
| 239 | ;; condensed from (ice-9 regex) `match:{substring,start,end}' |
| 240 | (let ((sel (vector-ref match (1+ which)))) |
| 241 | (substring (vector-ref match 0) (car sel) (cdr sel)))) |
| 242 | |
| 243 | (define (expand-clumped-singles opt-ls) |
| 244 | ;; example: ("--xyz" "-abc5d") => ("--xyz" "-a" "-b" "-c" "5d") |
| 245 | (let loop ((opt-ls opt-ls) (ret-ls '())) |
| 246 | (cond ((null? opt-ls) |
| 247 | (reverse ret-ls)) ;;; retval |
| 248 | ((regexp-exec short-opt-rx (car opt-ls)) |
| 249 | => (lambda (match) |
| 250 | (let ((singles (reverse |
| 251 | (map (lambda (c) |
| 252 | (string-append "-" (make-string 1 c))) |
| 253 | (string->list |
| 254 | (match-substring match 1))))) |
| 255 | (extra (match-substring match 2))) |
| 256 | (loop (cdr opt-ls) |
| 257 | (append (if (string=? "" extra) |
| 258 | singles |
| 259 | (cons extra singles)) |
| 260 | ret-ls))))) |
| 261 | (else (loop (cdr opt-ls) |
| 262 | (cons (car opt-ls) ret-ls)))))) |
| 263 | |
| 264 | (define (looks-like-an-option string) |
| 265 | (some (lambda (rx) |
| 266 | (regexp-exec rx string)) |
| 267 | `(,short-opt-rx |
| 268 | ,long-opt-with-value-rx |
| 269 | ,long-opt-no-value-rx))) |
| 270 | |
| 271 | (define (process-options specs argument-ls) |
| 272 | ;; Use SPECS to scan ARGUMENT-LS; return (FOUND . ETC). |
| 273 | ;; FOUND is an unordered list of option specs for found options, while ETC |
| 274 | ;; is an order-maintained list of elements in ARGUMENT-LS that are neither |
| 275 | ;; options nor their values. |
| 276 | (let ((idx (map (lambda (spec) |
| 277 | (cons (option-spec->name spec) spec)) |
| 278 | specs)) |
| 279 | (sc-idx (map (lambda (spec) |
| 280 | (cons (make-string 1 (option-spec->single-char spec)) |
| 281 | spec)) |
| 282 | (remove-if-not option-spec->single-char specs)))) |
| 283 | (let loop ((argument-ls argument-ls) (found '()) (etc '())) |
| 284 | (let ((eat! (lambda (spec ls) |
| 285 | (let ((val!loop (lambda (val n-ls n-found n-etc) |
| 286 | (set-option-spec-value! |
| 287 | spec |
| 288 | ;; handle multiple occurrances |
| 289 | (cond ((option-spec->value spec) |
| 290 | => (lambda (cur) |
| 291 | ((if (list? cur) cons list) |
| 292 | val cur))) |
| 293 | (else val))) |
| 294 | (loop n-ls n-found n-etc))) |
| 295 | (ERR:no-arg (lambda () |
| 296 | (error (string-append |
| 297 | "option must be specified" |
| 298 | " with argument:") |
| 299 | (option-spec->name spec))))) |
| 300 | (cond |
| 301 | ((eq? 'optional (option-spec->value-policy spec)) |
| 302 | (if (or (null? (cdr ls)) |
| 303 | (looks-like-an-option (cadr ls))) |
| 304 | (val!loop #t |
| 305 | (cdr ls) |
| 306 | (cons spec found) |
| 307 | etc) |
| 308 | (val!loop (cadr ls) |
| 309 | (cddr ls) |
| 310 | (cons spec found) |
| 311 | etc))) |
| 312 | ((eq? #t (option-spec->value-policy spec)) |
| 313 | (if (or (null? (cdr ls)) |
| 314 | (looks-like-an-option (cadr ls))) |
| 315 | (ERR:no-arg) |
| 316 | (val!loop (cadr ls) |
| 317 | (cddr ls) |
| 318 | (cons spec found) |
| 319 | etc))) |
| 320 | (else |
| 321 | (val!loop #t |
| 322 | (cdr ls) |
| 323 | (cons spec found) |
| 324 | etc))))))) |
| 325 | (if (null? argument-ls) |
| 326 | (cons found (reverse etc)) ;;; retval |
| 327 | (cond ((regexp-exec short-opt-rx (car argument-ls)) |
| 328 | => (lambda (match) |
| 329 | (let* ((c (match-substring match 1)) |
| 330 | (spec (or (assoc-ref sc-idx c) |
| 331 | (error "no such option:" c)))) |
| 332 | (eat! spec argument-ls)))) |
| 333 | ((regexp-exec long-opt-no-value-rx (car argument-ls)) |
| 334 | => (lambda (match) |
| 335 | (let* ((opt (match-substring match 1)) |
| 336 | (spec (or (assoc-ref idx opt) |
| 337 | (error "no such option:" opt)))) |
| 338 | (eat! spec argument-ls)))) |
| 339 | ((regexp-exec long-opt-with-value-rx (car argument-ls)) |
| 340 | => (lambda (match) |
| 341 | (let* ((opt (match-substring match 1)) |
| 342 | (spec (or (assoc-ref idx opt) |
| 343 | (error "no such option:" opt)))) |
| 344 | (if (option-spec->value-policy spec) |
| 345 | (eat! spec (append |
| 346 | (list 'ignored |
| 347 | (match-substring match 2)) |
| 348 | (cdr argument-ls))) |
| 349 | (error "option does not support argument:" |
| 350 | opt))))) |
| 351 | (else |
| 352 | (loop (cdr argument-ls) |
| 353 | found |
| 354 | (cons (car argument-ls) etc))))))))) |
| 355 | |
| 356 | (define (getopt-long program-arguments option-desc-list) |
| 357 | "Process options, handling both long and short options, similar to |
| 358 | the glibc function 'getopt_long'. PROGRAM-ARGUMENTS should be a value |
| 359 | similar to what (program-arguments) returns. OPTION-DESC-LIST is a |
| 360 | list of option descriptions. Each option description must satisfy the |
| 361 | following grammar: |
| 362 | |
| 363 | <option-spec> :: (<name> . <attribute-ls>) |
| 364 | <attribute-ls> :: (<attribute> . <attribute-ls>) |
| 365 | | () |
| 366 | <attribute> :: <required-attribute> |
| 367 | | <arg-required-attribute> |
| 368 | | <single-char-attribute> |
| 369 | | <predicate-attribute> |
| 370 | | <value-attribute> |
| 371 | <required-attribute> :: (required? <boolean>) |
| 372 | <single-char-attribute> :: (single-char <char>) |
| 373 | <value-attribute> :: (value #t) |
| 374 | (value #f) |
| 375 | (value optional) |
| 376 | <predicate-attribute> :: (predicate <1-ary-function>) |
| 377 | |
| 378 | The procedure returns an alist of option names and values. Each |
| 379 | option name is a symbol. The option value will be '#t' if no value |
| 380 | was specified. There is a special item in the returned alist with a |
| 381 | key of the empty list, (): the list of arguments that are not options |
| 382 | or option values. |
| 383 | By default, options are not required, and option values are not |
| 384 | required. By default, single character equivalents are not supported; |
| 385 | if you want to allow the user to use single character options, you need |
| 386 | to add a `single-char' clause to the option description." |
| 387 | (let* ((specifications (map parse-option-spec option-desc-list)) |
| 388 | (pair (split-arg-list (cdr program-arguments))) |
| 389 | (split-ls (expand-clumped-singles (car pair))) |
| 390 | (non-split-ls (cdr pair)) |
| 391 | (found/etc (process-options specifications split-ls)) |
| 392 | (found (car found/etc)) |
| 393 | (rest-ls (append (cdr found/etc) non-split-ls))) |
| 394 | (for-each (lambda (spec) |
| 395 | (let ((name (option-spec->name spec)) |
| 396 | (val (option-spec->value spec))) |
| 397 | (and (option-spec->required? spec) |
| 398 | (or (memq spec found) |
| 399 | (error "option must be specified:" name))) |
| 400 | (and (memq spec found) |
| 401 | (eq? #t (option-spec->value-policy spec)) |
| 402 | (or val |
| 403 | (error "option must be specified with argument:" |
| 404 | name))) |
| 405 | (let ((pred (option-spec->predicate spec))) |
| 406 | (and pred (pred name val))))) |
| 407 | specifications) |
| 408 | (cons (cons '() rest-ls) |
| 409 | (let ((multi-count (map (lambda (desc) |
| 410 | (cons (car desc) 0)) |
| 411 | option-desc-list))) |
| 412 | (map (lambda (spec) |
| 413 | (let ((name (string->symbol (option-spec->name spec)))) |
| 414 | (cons name |
| 415 | ;; handle multiple occurrances |
| 416 | (let ((maybe-ls (option-spec->value spec))) |
| 417 | (if (list? maybe-ls) |
| 418 | (let* ((look (assq name multi-count)) |
| 419 | (idx (cdr look)) |
| 420 | (val (list-ref maybe-ls idx))) |
| 421 | (set-cdr! look (1+ idx)) ; ugh! |
| 422 | val) |
| 423 | maybe-ls))))) |
| 424 | found))))) |
| 425 | |
| 426 | (define (option-ref options key default) |
| 427 | "Return value in alist OPTIONS using KEY, a symbol; or DEFAULT if not found. |
| 428 | The value is either a string or `#t'." |
| 429 | (or (assq-ref options key) default)) |
| 430 | |
| 431 | ;;; getopt-long.scm ends here |