1 ;;; Author: Russ McManus
2 ;;; $Id: getopt-long.scm,v 1.2 1999-02-15 12:53:10 jimb Exp $
4 ;;; Copyright (C) 1998 FSF
6 ;;; This program is free software; you can redistribute it and/or modify
7 ;;; it under the terms of the GNU General Public License as published by
8 ;;; the Free Software Foundation; either version 2 of the License, or
9 ;;; (at your option) any later version.
11 ;;; This program is distributed in the hope that it will be useful,
12 ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
13 ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
14 ;;; GNU General Public License for more details.
16 ;;; You should have received a copy of the GNU General Public License
17 ;;; along with this program; if not, write to the Free Software
18 ;;; Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
20 ;;; This module implements some complex command line option parsing, in
21 ;;; the spirit of the GNU C library function 'getopt_long'. Both long
22 ;;; and short options are supported.
24 ;;; The theory is that people should be able to constrain the set of
25 ;;; options they want to process using a grammar, rather than some arbitrary
26 ;;; structure. The grammar makes the option descriptions easy to read.
29 ;;; getopt-long is a function for parsing command-line arguments in a
30 ;;; manner consistent with other GNU programs.
32 ;;; (getopt-long ARGS GRAMMAR)
33 ;;; Parse the arguments ARGS according to the argument list grammar GRAMMAR.
35 ;;; ARGS should be a list of strings. Its first element should be the
36 ;;; name of the program; subsequent elements should be the arguments
37 ;;; that were passed to the program on the command line. The
38 ;;; `program-arguments' procedure returns a list of this form.
40 ;;; GRAMMAR is a list of the form:
41 ;;; ((OPTION (PROPERTY VALUE) ...) ...)
43 ;;; Each OPTION should be a symbol. `getopt-long' will accept a
44 ;;; command-line option named `--OPTION'.
45 ;;; Each option can have the following (PROPERTY VALUE) pairs:
47 ;;; (single-char CHAR) --- Accept `-CHAR' as a single-character
48 ;;; equivalent to `--OPTION'. This is how to specify traditional
50 ;;; (required? BOOL) --- If BOOL is true, the option is required.
51 ;;; getopt-long will raise an error if it is not found in ARGS.
52 ;;; (value BOOL) --- If BOOL is #t, the option accepts a value; if
53 ;;; it is #f, it does not; and if it is the symbol
54 ;;; `optional', the option may appear in ARGS with or
56 ;;; (predicate FUNC) --- If the option accepts a value (i.e. you
57 ;;; specified `(value #t)' for this option), then getopt
58 ;;; will apply FUNC to the value, and throw an exception
59 ;;; if it returns #f. FUNC should be a procedure which
60 ;;; accepts a string and returns a boolean value; you may
61 ;;; need to use quasiquotes to get it into GRAMMAR.
63 ;;; The (PROPERTY VALUE) pairs may occur in any order, but each
64 ;;; property may occur only once. By default, options do not have
65 ;;; single-character equivalents, are not required, and do not take
68 ;;; In ARGS, single-character options may be combined, in the usual
69 ;;; Unix fashion: ("-x" "-y") is equivalent to ("-xy"). If an option
70 ;;; accepts values, then it must be the last option in the
71 ;;; combination; the value is the next argument. So, for example, using
72 ;;; the following grammar:
73 ;;; ((apples (single-char #\a))
74 ;;; (blimps (single-char #\b) (value #t))
75 ;;; (catalexis (single-char #\c) (value #t)))
76 ;;; the following argument lists would be acceptable:
77 ;;; ("-a" "-b" "bang" "-c" "couth") ("bang" and "couth" are the values
78 ;;; for "blimps" and "catalexis")
79 ;;; ("-ab" "bang" "-c" "couth") (same)
80 ;;; ("-ac" "couth" "-b" "bang") (same)
81 ;;; ("-abc" "couth" "bang") (an error, since `-b' is not the
82 ;;; last option in its combination)
84 ;;; If an option's value is optional, then `getopt-long' decides
85 ;;; whether it has a value by looking at what follows it in ARGS. If
86 ;;; the next element is a string, and it does not appear to be an
87 ;;; option itself, then that string is the option's value.
89 ;;; The value of a long option can appear as the next element in ARGS,
90 ;;; or it can follow the option name, separated by an `=' character.
91 ;;; Thus, using the same grammar as above, the following argument lists
93 ;;; ("--apples" "Braeburn" "--blimps" "Goodyear")
94 ;;; ("--apples=Braeburn" "--blimps" "Goodyear")
95 ;;; ("--blimps" "Goodyear" "--apples=Braeburn")
97 ;;; If the option "--" appears in ARGS, argument parsing stops there;
98 ;;; subsequent arguments are returned as ordinary arguments, even if
99 ;;; they resemble options. So, in the argument list:
100 ;;; ("--apples" "Granny Smith" "--" "--blimp" "Goodyear")
101 ;;; `getopt-long' will recognize the `apples' option as having the
102 ;;; value "Granny Smith", but it will not recognize the `blimp'
103 ;;; option; it will return the strings "--blimp" and "Goodyear" as
104 ;;; ordinary argument strings.
106 ;;; The `getopt-long' function returns the parsed argument list as an
107 ;;; assocation list, mapping option names --- the symbols from GRAMMAR
108 ;;; --- onto their values, or #t if the option does not accept a value.
109 ;;; Unused options do not appear in the alist.
111 ;;; All arguments that are not the value of any option are returned
112 ;;; as a list, associated with the empty list.
114 ;;; `getopt-long' throws an exception if:
115 ;;; - it finds an unrecognized option in ARGS
116 ;;; - a required option is omitted
117 ;;; - an option that requires an argument doesn't get one
118 ;;; - an option that doesn't accept an argument does get one (this can
119 ;;; only happen using the long option `--opt=value' syntax)
120 ;;; - an option predicate fails
125 ;;; `((lockfile-dir (required? #t)
127 ;;; (single-char #\k)
128 ;;; (predicate ,file-is-directory?))
129 ;;; (verbose (required? #f)
130 ;;; (single-char #\v)
132 ;;; (x-includes (single-char #\x))
133 ;;; (rnet-server (single-char #\y)
134 ;;; (predicate ,string?))))
136 ;;; (getopt-long '("my-prog" "-vk" "/tmp" "foo1" "--x-includes=/usr/include"
137 ;;; "--rnet-server=lamprod" "--" "-fred" "foo2" "foo3")
139 ;;; => ((() "foo1" "-fred" "foo2" "foo3")
140 ;;; (rnet-server . "lamprod")
141 ;;; (x-includes . "/usr/include")
142 ;;; (lockfile-dir . "/tmp")
146 (define-module (ice-9 getopt-long)
147 :use-module (ice-9 common-list))
151 ;;; The code on this page was expanded by hand using the following code:
154 ;;; '(define-record option-spec
162 ;;; This avoids the need to load slib for records.
163 (define slib:error error)
168 (if (option-spec? obj)
171 (quote option-spec->name)
178 (if (option-spec? obj)
181 (quote option-spec->value)
185 option-spec->value-required?
188 (if (option-spec? obj)
191 (quote option-spec->value-required?)
195 option-spec->single-char
198 (if (option-spec? obj)
201 (quote option-spec->single-char)
205 option-spec->predicate-ls
208 (if (option-spec? obj)
211 (quote option-spec->predicate-ls)
215 option-spec->parse-ls
218 (if (option-spec? obj)
221 (quote option-spec->parse-ls)
225 set-option-spec-name!
228 (if (option-spec? obj)
229 (vector-set! obj 1 val)
231 (quote set-option-spec-name!)
235 set-option-spec-value!
238 (if (option-spec? obj)
239 (vector-set! obj 2 val)
241 (quote set-option-spec-value!)
245 set-option-spec-value-required?!
248 (if (option-spec? obj)
249 (vector-set! obj 3 val)
251 (quote set-option-spec-value-required?!)
255 set-option-spec-single-char!
258 (if (option-spec? obj)
259 (vector-set! obj 4 val)
261 (quote set-option-spec-single-char!)
265 set-option-spec-predicate-ls!
268 (if (option-spec? obj)
269 (vector-set! obj 5 val)
271 (quote set-option-spec-predicate-ls!)
275 set-option-spec-parse-ls!
278 (if (option-spec? obj)
279 (vector-set! obj 6 val)
281 (quote set-option-spec-parse-ls!)
289 (= (vector-length obj) 7)
290 (eq? (vector-ref obj 0) (quote option-spec)))))
296 option-spec->value-required?
297 option-spec->single-char
298 option-spec->predicate-ls
299 option-spec->parse-ls)
304 option-spec->value-required?
305 option-spec->single-char
306 option-spec->predicate-ls
307 option-spec->parse-ls))))
311 ;;; parse functions go on this page.
313 (define make-user-predicate
316 (let ((val (option-spec->value spec)))
319 (error "option predicate failed:" (option-spec->name spec)))))))
321 (define make-not-allowed-value-fn
324 (let ((val (option-spec->value spec)))
325 (if (not (or (eq? val #t)
327 (let ((name (option-spec->name spec)))
328 (error "option does not support argument:" name)))))))
330 (define make-option-required-predicate
333 (let ((val (option-spec->value spec)))
335 (let ((name (option-spec->name spec)))
336 (error "option must be specified:" name)))))))
338 (define make-option-value-predicate
341 (let ((val (option-spec->value spec)))
342 (if (not (predicate val))
343 (let ((name (option-spec->name spec)))
344 (error "Bad option value:" name val)))))))
346 (define make-required-value-fn
349 (let ((val (option-spec->value spec)))
351 (let ((name (option-spec->name spec)))
352 (error "option must be specified with argument:" name)))))))
354 (define single-char-value?
358 (define (parse-option-spec desc)
361 (let ((parse-ls (option-spec->parse-ls spec)))
364 (let ((ls (car parse-ls)))
365 (if (or (not (list? ls))
366 (not (= (length ls) 2)))
367 (error "Bad option specification:" ls))
370 (cond ((and (eq? key 'required?) val)
371 ;; required values are implemented as a predicate
372 (parse-iter (make-option-spec (option-spec->name spec)
373 (option-spec->value spec)
374 (option-spec->value-required? spec)
375 (option-spec->single-char spec)
376 (cons (make-option-required-predicate)
377 (option-spec->predicate-ls spec))
379 ;; if the value is not required, then don't add a predicate,
380 ((eq? key 'required?)
381 (parse-iter (make-option-spec (option-spec->name spec)
382 (option-spec->value spec)
383 (option-spec->value-required? spec)
384 (option-spec->single-char spec)
385 (option-spec->predicate-ls spec)
387 ;; handle value specification
390 ;; when value is required, add a predicate to that effect
391 ;; and record the fact in value-required? field.
392 (parse-iter (make-option-spec (option-spec->name spec)
393 (option-spec->value spec)
395 (option-spec->single-char spec)
396 (cons (make-required-value-fn)
397 (option-spec->predicate-ls spec))
400 ;; when the value is not allowed, add a predicate to that effect.
401 ;; one can detect that a value is not supplied by checking the option
403 (parse-iter (make-option-spec (option-spec->name spec)
404 (option-spec->value spec)
406 (option-spec->single-char spec)
407 (cons (make-not-allowed-value-fn)
408 (option-spec->predicate-ls spec))
411 ;; for optional values, don't add a predicate. do, however
412 ;; put the value 'optional in the value-required? field. this
413 ;; setting checks whether optional values are 'greedy'. set
414 ;; to #f to make optional value clauses 'non-greedy'.
416 (parse-iter (make-option-spec (option-spec->name spec)
417 (option-spec->value spec)
419 (option-spec->single-char spec)
420 (option-spec->predicate-ls spec)
424 (error "Bad value specification for option:" (cons key val)))))
425 ;; specify which single char is defined for this option.
426 ((eq? key 'single-char)
427 (if (not (single-char-value? val))
428 (error "Not a single-char-value:" val " for option:" key)
429 (parse-iter (make-option-spec (option-spec->name spec)
430 (option-spec->value spec)
431 (option-spec->value-required? spec)
433 (option-spec->predicate-ls spec)
435 ((eq? key 'predicate)
437 (parse-iter (make-option-spec (option-spec->name spec)
438 (option-spec->value spec)
439 (option-spec->value-required? spec)
440 (option-spec->single-char spec)
441 (cons (make-user-predicate val)
442 (option-spec->predicate-ls spec))
444 (error "Bad predicate specified for option:" (cons key val))))))))))))
445 (if (or (not (pair? desc))
446 (string? (car desc)))
447 (error "Bad option specification:" desc))
448 (parse-iter (make-option-spec (car desc)
459 (define (split-arg-list argument-list)
460 "Given an ARGUMENT-LIST, decide which part to process for options.
461 Everything before an arg of \"--\" is fair game, everything after it
462 should not be processed. The \"--\" is discarded. A cons pair is
463 returned whose car is the list to process for options, and whose cdr
464 is the list to not process."
465 (let loop ((process-ls '())
466 (not-process-ls argument-list))
467 (cond ((null? not-process-ls)
468 (cons (reverse process-ls) '()))
469 ((string=? "--" (car not-process-ls))
470 (cons (reverse process-ls) (cdr not-process-ls)))
472 (loop (cons (car not-process-ls) process-ls)
473 (cdr not-process-ls))))))
475 (define short-opt-rx (make-regexp "^-([a-zA-Z]+)"))
476 (define long-opt-no-value-rx (make-regexp "^--([^=]+)$"))
477 (define long-opt-with-value-rx (make-regexp "^--([^=]+)=(.*)"))
479 (define (single-char-expander specifications opt-ls)
480 "Expand single letter options that are mushed together."
482 (define (is-short-opt? str)
483 (set! response (regexp-exec short-opt-rx str))
485 (define (iter opt-ls ret-ls)
486 (cond ((null? opt-ls)
488 ((is-short-opt? (car opt-ls))
489 (let* ((orig-str (car opt-ls))
490 (match-pair (vector-ref response 2))
491 (match-str (substring orig-str (car match-pair) (cdr match-pair))))
492 (if (= (string-length match-str) 1)
494 (cons (string-append "-" match-str) ret-ls))
495 (iter (cons (string-append "-" (substring match-str 1)) (cdr opt-ls))
496 (cons (string-append "-" (substring match-str 0 1)) ret-ls)))))
497 (#t (iter (cdr opt-ls)
498 (cons (car opt-ls) ret-ls)))))
501 (define (process-short-option specifications argument-ls alist)
502 "Process a single short option that appears at the front of the ARGUMENT-LS,
503 according to SPECIFICATIONS. Returns #f is there is no such argument. Otherwise
504 returns a pair whose car is the list of remaining arguments, and whose cdr is a
505 new association list, constructed by adding a pair to the supplied ALIST.
506 The pair on the front of the returned association list describes the option
507 found at the head of ARGUMENT-LS. The way this routine currently works, an
508 option that never takes a value that is followed by a non option will cause
509 an error, which is probably a bug. To fix the bug the option specification
510 needs to record whether the option ever can take a value."
511 (define (short-option->char option)
512 (string-ref option 1))
513 (define (is-short-option? option)
514 (regexp-exec short-opt-rx option))
515 (define (is-long-option? option)
516 (or (regexp-exec long-opt-with-value-rx option)
517 (regexp-exec long-opt-no-value-rx option)))
518 (define (find-matching-spec option)
519 (let ((key (short-option->char option)))
520 (find-if (lambda (spec) (eq? key (option-spec->single-char spec))) specifications)))
521 (let ((option (car argument-ls)))
522 (if (is-short-option? option)
523 (let ((spec (find-matching-spec option)))
525 (let* ((next-value (if (null? (cdr argument-ls)) #f (cadr argument-ls)))
526 (option-value (if (and next-value
527 (not (is-short-option? next-value))
528 (not (is-long-option? next-value))
529 (option-spec->value-required? spec))
532 (new-alist (cons (cons (option-spec->name spec) option-value) alist)))
533 (cons (if (eq? option-value #t)
534 (cdr argument-ls) ; there was one value specified, skip just one
535 (cddr argument-ls)) ; there must have been a value specified, skip two
537 (error "No such option:" option)))
540 (define (process-long-option specifications argument-ls alist)
541 (define (find-matching-spec key)
542 (find-if (lambda (spec) (eq? key (option-spec->name spec))) specifications))
543 (define (split-long-option option)
544 ;; returns a pair whose car is a symbol naming the option, cdr is
545 ;; the option value. as a special case, if the option value is
546 ;; #f, then the caller should use the next item in argument-ls as
548 (let ((resp (regexp-exec long-opt-no-value-rx option)))
550 ;; Aha, we've found a long option without an equal sign.
551 ;; Maybe we need to grab a value from argument-ls. To find
552 ;; out we need to refer to the option-spec.
553 (let* ((key-pair (vector-ref resp 2))
554 (key (string->symbol (substring option (car key-pair) (cdr key-pair))))
555 (spec (find-matching-spec key)))
556 (cons key (if (option-spec->value-required? spec) #f #t)))
557 (let ((resp (regexp-exec long-opt-with-value-rx option)))
558 ;; Aha, we've found a long option with an equal sign. The
559 ;; option value is simply the value to the right of the
562 (let* ((key-pair (vector-ref resp 2))
563 (key (string->symbol (substring option (car key-pair) (cdr key-pair))))
564 (value-pair (vector-ref resp 3))
565 (value (substring option (car value-pair) (cdr value-pair))))
568 (let* ((option (car argument-ls))
569 (pair (split-long-option option)))
570 (cond ((and pair (eq? (cdr pair) #f))
571 (if (null? (cdr argument-ls))
572 (error "Not enough options.")
573 (cons (cddr argument-ls)
574 (cons (cons (car pair) (cadr argument-ls)) alist))))
576 (cons (cdr argument-ls) (cons pair alist)))
579 (define (process-options specifications argument-ls)
580 (define (iter argument-ls alist rest-ls)
581 (if (null? argument-ls)
582 (cons alist (reverse rest-ls))
583 (let ((pair (process-short-option specifications argument-ls alist)))
585 (let ((argument-ls (car pair))
587 (iter argument-ls alist rest-ls))
588 (let ((pair (process-long-option specifications argument-ls alist)))
590 (let ((argument-ls (car pair))
592 (iter argument-ls alist rest-ls))
593 (iter (cdr argument-ls)
595 (cons (car argument-ls) rest-ls))))))))
596 (iter argument-ls '() '()))
598 (define (getopt-long program-arguments option-desc-list)
599 "Process options, handling both long and short options, similar to
600 the glibc function 'getopt_long'. PROGRAM-ARGUMENTS should be a value
601 similar to what (program-arguments) returns. OPTION-DESC-LIST is a
602 list of option descriptions. Each option description must satisfy the
605 <option-spec> :: (<name> . <attribute-ls>)
606 <attribute-ls> :: (<attribute> . <attribute-ls>)
608 <attribute> :: <required-attribute>
609 | <arg-required-attribute>
610 | <single-char-attribute>
611 | <predicate-attribute>
613 <required-attribute> :: (required? <boolean>)
614 <single-char-attribute> :: (single-char <char>)
615 <value-attribute> :: (value #t)
618 <predicate-attribute> :: (predicate <1-ary-function>)
620 The procedure returns an alist of option names and values. Each
621 option name is a symbol. The option value will be '#t' if no value
622 was specified. There is a special item in the returned alist with a
623 key of the empty list, (): the list of arguments that are not options
625 By default, options are not required, and option values are not
626 required. By default, single character equivalents are not supported;
627 if you want to allow the user to use single character options, you need
628 to add a 'single-char' clause to the option description."
629 (let* ((specifications (map parse-option-spec option-desc-list))
630 (pair (split-arg-list (cdr program-arguments)))
631 (split-ls (single-char-expander specifications (car pair)))
632 (non-split-ls (cdr pair)))
633 (let* ((opt-pair (process-options specifications split-ls))
634 (alist (car opt-pair))
635 (rest-ls (append (cdr opt-pair) non-split-ls)))
636 ;; loop through the returned alist, and set the values into the specifications
637 (for-each (lambda (pair)
638 (let* ((key (car pair))
640 (spec (find-if (lambda (spec) (eq? key (option-spec->name spec)))
642 (if spec (set-option-spec-value! spec val))))
644 ;; now fire all the predicates
645 (for-each (lambda (spec)
646 (let ((predicate-ls (option-spec->predicate-ls spec)))
647 (for-each (lambda (predicate)
651 (cons (cons '() rest-ls) alist))))
653 (define (option-ref options key default)
654 "Look for an option value in OPTIONS using KEY. If no such value is
655 found, return DEFAULT."
656 (let ((pair (assq key options)))