1 ;;; Copyright (C) 1998, 2001, 2006 Free Software Foundation, Inc.
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 2.1 of the License, or (at your option) any later version.
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.
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
17 ;;; Author: Russ McManus (rewritten by Thien-Thi Nguyen)
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.
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.
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.
33 ;;; (getopt-long ARGS GRAMMAR)
34 ;;; Parse the arguments ARGS according to the argument list grammar GRAMMAR.
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.
41 ;;; GRAMMAR is a list of the form:
42 ;;; ((OPTION (PROPERTY VALUE) ...) ...)
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:
48 ;;; (single-char CHAR) --- Accept `-CHAR' as a single-character
49 ;;; equivalent to `--OPTION'. This is how to specify traditional
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
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.
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
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)
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.
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
94 ;;; ("--apples" "Braeburn" "--blimps" "Goodyear")
95 ;;; ("--apples=Braeburn" "--blimps" "Goodyear")
96 ;;; ("--blimps" "Goodyear" "--apples=Braeburn")
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.
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.
112 ;;; All arguments that are not the value of any option are returned
113 ;;; as a list, associated with the empty list.
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
128 ;;; `((lockfile-dir (required? #t)
130 ;;; (single-char #\k)
131 ;;; (predicate ,file-is-directory?))
132 ;;; (verbose (required? #f)
133 ;;; (single-char #\v)
135 ;;; (x-includes (single-char #\x))
136 ;;; (rnet-server (single-char #\y)
137 ;;; (predicate ,string?))))
139 ;;; (getopt-long '("my-prog" "-vk" "/tmp" "foo1" "--x-includes=/usr/include"
140 ;;; "--rnet-server=lamprod" "--" "-fred" "foo2" "foo3")
142 ;;; => ((() "foo1" "-fred" "foo2" "foo3")
143 ;;; (rnet-server . "lamprod")
144 ;;; (x-includes . "/usr/include")
145 ;;; (lockfile-dir . "/tmp")
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'.
152 ;;; For example, using the `getopt-long' return value from above:
154 ;;; (option-ref (getopt-long ...) 'x-includes 42) => "/usr/include"
155 ;;; (option-ref (getopt-long ...) 'not-a-key! 31) => 31
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))
163 (define option-spec-fields '(name
170 (define option-spec (make-record-type 'option-spec option-spec-fields))
171 (define make-option-spec (record-constructor option-spec option-spec-fields))
173 (define (define-one-option-spec-field-accessor field)
174 `(define ,(symbol-append 'option-spec-> field) ;;; name slib-compat
175 (record-accessor option-spec ',field)))
177 (define (define-one-option-spec-field-modifier field)
178 `(define ,(symbol-append 'set-option-spec- field '!) ;;; name slib-compat
179 (record-modifier option-spec ',field)))
181 (defmacro define-all-option-spec-accessors/modifiers ()
183 ,@(map define-one-option-spec-field-accessor option-spec-fields)
184 ,@(map define-one-option-spec-field-modifier option-spec-fields)))
186 (define-all-option-spec-accessors/modifiers)
188 (define make-option-spec
189 (let ((ctor (record-constructor option-spec '(name))))
193 (define (parse-option-spec desc)
194 (let ((spec (make-option-spec (symbol->string (car desc)))))
195 (for-each (lambda (desc-elem)
196 (let ((given (lambda () (cadr desc-elem))))
197 (case (car desc-elem)
199 (set-option-spec-required?! spec (given)))
201 (set-option-spec-value-policy! spec (given)))
204 (error "`single-char' value must be a char!"))
205 (set-option-spec-single-char! spec (given)))
207 (set-option-spec-predicate!
212 (error "option predicate failed:" name))))
215 (error "invalid getopt-long option property:"
220 (define (split-arg-list argument-list)
221 ;; Scan ARGUMENT-LIST for "--" and return (BEFORE-LS . AFTER-LS).
222 ;; Discard the "--". If no "--" is found, AFTER-LS is empty.
223 (let loop ((yes '()) (no argument-list))
224 (cond ((null? no) (cons (reverse yes) no))
225 ((string=? "--" (car no)) (cons (reverse yes) (cdr no)))
226 (else (loop (cons (car no) yes) (cdr no))))))
228 (define short-opt-rx (make-regexp "^-([a-zA-Z]+)(.*)"))
229 (define long-opt-no-value-rx (make-regexp "^--([^=]+)$"))
230 (define long-opt-with-value-rx (make-regexp "^--([^=]+)=(.*)"))
232 (define (match-substring match which)
233 ;; condensed from (ice-9 regex) `match:{substring,start,end}'
234 (let ((sel (vector-ref match (1+ which))))
235 (substring (vector-ref match 0) (car sel) (cdr sel))))
237 (define (expand-clumped-singles opt-ls)
238 ;; example: ("--xyz" "-abc5d") => ("--xyz" "-a" "-b" "-c" "5d")
239 (let loop ((opt-ls opt-ls) (ret-ls '()))
240 (cond ((null? opt-ls)
241 (reverse ret-ls)) ;;; retval
242 ((regexp-exec short-opt-rx (car opt-ls))
244 (let ((singles (reverse
246 (string-append "-" (make-string 1 c)))
248 (match-substring match 1)))))
249 (extra (match-substring match 2)))
251 (append (if (string=? "" extra)
253 (cons extra singles))
255 (else (loop (cdr opt-ls)
256 (cons (car opt-ls) ret-ls))))))
258 (define (looks-like-an-option string)
260 (regexp-exec rx string))
262 ,long-opt-with-value-rx
263 ,long-opt-no-value-rx)))
265 (define (process-options specs argument-ls)
266 ;; Use SPECS to scan ARGUMENT-LS; return (FOUND . ETC).
267 ;; FOUND is an unordered list of option specs for found options, while ETC
268 ;; is an order-maintained list of elements in ARGUMENT-LS that are neither
269 ;; options nor their values.
270 (let ((idx (map (lambda (spec)
271 (cons (option-spec->name spec) spec))
273 (sc-idx (map (lambda (spec)
274 (cons (make-string 1 (option-spec->single-char spec))
276 (remove-if-not option-spec->single-char specs))))
277 (let loop ((argument-ls argument-ls) (found '()) (etc '()))
278 (let ((eat! (lambda (spec ls)
279 (let ((val!loop (lambda (val n-ls n-found n-etc)
280 (set-option-spec-value!
282 ;; handle multiple occurrances
283 (cond ((option-spec->value spec)
285 ((if (list? cur) cons list)
288 (loop n-ls n-found n-etc)))
289 (ERR:no-arg (lambda ()
290 (error (string-append
291 "option must be specified"
293 (option-spec->name spec)))))
295 ((eq? 'optional (option-spec->value-policy spec))
296 (if (or (null? (cdr ls))
297 (looks-like-an-option (cadr ls)))
306 ((eq? #t (option-spec->value-policy spec))
307 (if (or (null? (cdr ls))
308 (looks-like-an-option (cadr ls)))
319 (if (null? argument-ls)
320 (cons found (reverse etc)) ;;; retval
321 (cond ((regexp-exec short-opt-rx (car argument-ls))
323 (let* ((c (match-substring match 1))
324 (spec (or (assoc-ref sc-idx c)
325 (error "no such option:" c))))
326 (eat! spec argument-ls))))
327 ((regexp-exec long-opt-no-value-rx (car argument-ls))
329 (let* ((opt (match-substring match 1))
330 (spec (or (assoc-ref idx opt)
331 (error "no such option:" opt))))
332 (eat! spec argument-ls))))
333 ((regexp-exec long-opt-with-value-rx (car argument-ls))
335 (let* ((opt (match-substring match 1))
336 (spec (or (assoc-ref idx opt)
337 (error "no such option:" opt))))
338 (if (option-spec->value-policy spec)
341 (match-substring match 2))
343 (error "option does not support argument:"
346 (loop (cdr argument-ls)
348 (cons (car argument-ls) etc)))))))))
350 (define (getopt-long program-arguments option-desc-list)
351 "Process options, handling both long and short options, similar to
352 the glibc function 'getopt_long'. PROGRAM-ARGUMENTS should be a value
353 similar to what (program-arguments) returns. OPTION-DESC-LIST is a
354 list of option descriptions. Each option description must satisfy the
357 <option-spec> :: (<name> . <attribute-ls>)
358 <attribute-ls> :: (<attribute> . <attribute-ls>)
360 <attribute> :: <required-attribute>
361 | <arg-required-attribute>
362 | <single-char-attribute>
363 | <predicate-attribute>
365 <required-attribute> :: (required? <boolean>)
366 <single-char-attribute> :: (single-char <char>)
367 <value-attribute> :: (value #t)
370 <predicate-attribute> :: (predicate <1-ary-function>)
372 The procedure returns an alist of option names and values. Each
373 option name is a symbol. The option value will be '#t' if no value
374 was specified. There is a special item in the returned alist with a
375 key of the empty list, (): the list of arguments that are not options
377 By default, options are not required, and option values are not
378 required. By default, single character equivalents are not supported;
379 if you want to allow the user to use single character options, you need
380 to add a `single-char' clause to the option description."
381 (let* ((specifications (map parse-option-spec option-desc-list))
382 (pair (split-arg-list (cdr program-arguments)))
383 (split-ls (expand-clumped-singles (car pair)))
384 (non-split-ls (cdr pair))
385 (found/etc (process-options specifications split-ls))
386 (found (car found/etc))
387 (rest-ls (append (cdr found/etc) non-split-ls)))
388 (for-each (lambda (spec)
389 (let ((name (option-spec->name spec))
390 (val (option-spec->value spec)))
391 (and (option-spec->required? spec)
392 (or (memq spec found)
393 (error "option must be specified:" name)))
394 (and (memq spec found)
395 (eq? #t (option-spec->value-policy spec))
397 (error "option must be specified with argument:"
399 (let ((pred (option-spec->predicate spec)))
400 (and pred (pred name val)))))
402 (cons (cons '() rest-ls)
403 (let ((multi-count (map (lambda (desc)
407 (let ((name (string->symbol (option-spec->name spec))))
409 ;; handle multiple occurrances
410 (let ((maybe-ls (option-spec->value spec)))
412 (let* ((look (assq name multi-count))
414 (val (list-ref maybe-ls idx)))
415 (set-cdr! look (1+ idx)) ; ugh!
420 (define (option-ref options key default)
421 "Return value in alist OPTIONS using KEY, a symbol; or DEFAULT if not found.
422 The value is either a string or `#t'."
423 (or (assq-ref options key) default))
425 ;;; getopt-long.scm ends here