1 ;;; Copyright (C) 1998, 2001, 2006, 2009 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 3 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 (eval-when (eval load compile)
164 ;; This binding is used both at compile-time and run-time.
165 (define option-spec-fields '(name
172 (define option-spec (make-record-type 'option-spec option-spec-fields))
173 (define make-option-spec (record-constructor option-spec option-spec-fields))
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).
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)))
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))))
187 (defmacro define-all-option-spec-accessors/modifiers ()
189 ,@(map define-one-option-spec-field-accessor option-spec-fields)
190 ,@(map define-one-option-spec-field-modifier option-spec-fields)))
192 (define-all-option-spec-accessors/modifiers)
194 (define make-option-spec
195 (let ((ctor (record-constructor option-spec '(name))))
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)
205 (set-option-spec-required?! spec (given)))
207 (set-option-spec-value-policy! spec (given)))
210 (error "`single-char' value must be a char!"))
211 (set-option-spec-single-char! spec (given)))
213 (set-option-spec-predicate!
218 (error "option predicate failed:" name))))
221 (error "invalid getopt-long option property:"
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))))))
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 "^--([^=]+)=(.*)"))
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))))
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))
250 (let ((singles (reverse
252 (string-append "-" (make-string 1 c)))
254 (match-substring match 1)))))
255 (extra (match-substring match 2)))
257 (append (if (string=? "" extra)
259 (cons extra singles))
261 (else (loop (cdr opt-ls)
262 (cons (car opt-ls) ret-ls))))))
264 (define (looks-like-an-option string)
266 (regexp-exec rx string))
268 ,long-opt-with-value-rx
269 ,long-opt-no-value-rx)))
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))
279 (sc-idx (map (lambda (spec)
280 (cons (make-string 1 (option-spec->single-char 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!
288 ;; handle multiple occurrances
289 (cond ((option-spec->value spec)
291 ((if (list? cur) cons list)
294 (loop n-ls n-found n-etc)))
295 (ERR:no-arg (lambda ()
296 (error (string-append
297 "option must be specified"
299 (option-spec->name spec)))))
301 ((eq? 'optional (option-spec->value-policy spec))
302 (if (or (null? (cdr ls))
303 (looks-like-an-option (cadr ls)))
312 ((eq? #t (option-spec->value-policy spec))
313 (if (or (null? (cdr ls))
314 (looks-like-an-option (cadr ls)))
325 (if (null? argument-ls)
326 (cons found (reverse etc)) ;;; retval
327 (cond ((regexp-exec short-opt-rx (car argument-ls))
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))
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))
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)
347 (match-substring match 2))
349 (error "option does not support argument:"
352 (loop (cdr argument-ls)
354 (cons (car argument-ls) etc)))))))))
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
363 <option-spec> :: (<name> . <attribute-ls>)
364 <attribute-ls> :: (<attribute> . <attribute-ls>)
366 <attribute> :: <required-attribute>
367 | <arg-required-attribute>
368 | <single-char-attribute>
369 | <predicate-attribute>
371 <required-attribute> :: (required? <boolean>)
372 <single-char-attribute> :: (single-char <char>)
373 <value-attribute> :: (value #t)
376 <predicate-attribute> :: (predicate <1-ary-function>)
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
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))
403 (error "option must be specified with argument:"
405 (let ((pred (option-spec->predicate spec)))
406 (and pred (pred name val)))))
408 (cons (cons '() rest-ls)
409 (let ((multi-count (map (lambda (desc)
413 (let ((name (string->symbol (option-spec->name spec))))
415 ;; handle multiple occurrances
416 (let ((maybe-ls (option-spec->value spec)))
418 (let* ((look (assq name multi-count))
420 (val (list-ref maybe-ls idx)))
421 (set-cdr! look (1+ idx)) ; ugh!
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))
431 ;;; getopt-long.scm ends here