merge from 1.8 branch
[bpt/guile.git] / ice-9 / getopt-long.scm
1 ;;; Copyright (C) 1998, 2001, 2006 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 2.1 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 (define option-spec-fields '(name
164 value
165 required?
166 single-char
167 predicate
168 value-policy))
169
170 (define option-spec (make-record-type 'option-spec option-spec-fields))
171 (define make-option-spec (record-constructor option-spec option-spec-fields))
172
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)))
176
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)))
180
181 (defmacro define-all-option-spec-accessors/modifiers ()
182 `(begin
183 ,@(map define-one-option-spec-field-accessor option-spec-fields)
184 ,@(map define-one-option-spec-field-modifier option-spec-fields)))
185
186 (define-all-option-spec-accessors/modifiers)
187
188 (define make-option-spec
189 (let ((ctor (record-constructor option-spec '(name))))
190 (lambda (name)
191 (ctor name))))
192
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)
198 ((required?)
199 (set-option-spec-required?! spec (given)))
200 ((value)
201 (set-option-spec-value-policy! spec (given)))
202 ((single-char)
203 (or (char? (given))
204 (error "`single-char' value must be a char!"))
205 (set-option-spec-single-char! spec (given)))
206 ((predicate)
207 (set-option-spec-predicate!
208 spec ((lambda (pred)
209 (lambda (name val)
210 (or (not val)
211 (pred val)
212 (error "option predicate failed:" name))))
213 (given))))
214 (else
215 (error "invalid getopt-long option property:"
216 (car desc-elem))))))
217 (cdr desc))
218 spec))
219
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))))))
227
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 "^--([^=]+)=(.*)"))
231
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))))
236
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))
243 => (lambda (match)
244 (let ((singles (reverse
245 (map (lambda (c)
246 (string-append "-" (make-string 1 c)))
247 (string->list
248 (match-substring match 1)))))
249 (extra (match-substring match 2)))
250 (loop (cdr opt-ls)
251 (append (if (string=? "" extra)
252 singles
253 (cons extra singles))
254 ret-ls)))))
255 (else (loop (cdr opt-ls)
256 (cons (car opt-ls) ret-ls))))))
257
258 (define (looks-like-an-option string)
259 (some (lambda (rx)
260 (regexp-exec rx string))
261 `(,short-opt-rx
262 ,long-opt-with-value-rx
263 ,long-opt-no-value-rx)))
264
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))
272 specs))
273 (sc-idx (map (lambda (spec)
274 (cons (make-string 1 (option-spec->single-char spec))
275 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!
281 spec
282 ;; handle multiple occurrances
283 (cond ((option-spec->value spec)
284 => (lambda (cur)
285 ((if (list? cur) cons list)
286 val cur)))
287 (else val)))
288 (loop n-ls n-found n-etc)))
289 (ERR:no-arg (lambda ()
290 (error (string-append
291 "option must be specified"
292 " with argument:")
293 (option-spec->name spec)))))
294 (cond
295 ((eq? 'optional (option-spec->value-policy spec))
296 (if (or (null? (cdr ls))
297 (looks-like-an-option (cadr ls)))
298 (val!loop #t
299 (cdr ls)
300 (cons spec found)
301 etc)
302 (val!loop (cadr ls)
303 (cddr ls)
304 (cons spec found)
305 etc)))
306 ((eq? #t (option-spec->value-policy spec))
307 (if (or (null? (cdr ls))
308 (looks-like-an-option (cadr ls)))
309 (ERR:no-arg)
310 (val!loop (cadr ls)
311 (cddr ls)
312 (cons spec found)
313 etc)))
314 (else
315 (val!loop #t
316 (cdr ls)
317 (cons spec found)
318 etc)))))))
319 (if (null? argument-ls)
320 (cons found (reverse etc)) ;;; retval
321 (cond ((regexp-exec short-opt-rx (car argument-ls))
322 => (lambda (match)
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))
328 => (lambda (match)
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))
334 => (lambda (match)
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)
339 (eat! spec (append
340 (list 'ignored
341 (match-substring match 2))
342 (cdr argument-ls)))
343 (error "option does not support argument:"
344 opt)))))
345 (else
346 (loop (cdr argument-ls)
347 found
348 (cons (car argument-ls) etc)))))))))
349
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
355 following grammar:
356
357 <option-spec> :: (<name> . <attribute-ls>)
358 <attribute-ls> :: (<attribute> . <attribute-ls>)
359 | ()
360 <attribute> :: <required-attribute>
361 | <arg-required-attribute>
362 | <single-char-attribute>
363 | <predicate-attribute>
364 | <value-attribute>
365 <required-attribute> :: (required? <boolean>)
366 <single-char-attribute> :: (single-char <char>)
367 <value-attribute> :: (value #t)
368 (value #f)
369 (value optional)
370 <predicate-attribute> :: (predicate <1-ary-function>)
371
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
376 or option values.
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))
396 (or val
397 (error "option must be specified with argument:"
398 name)))
399 (let ((pred (option-spec->predicate spec)))
400 (and pred (pred name val)))))
401 specifications)
402 (cons (cons '() rest-ls)
403 (let ((multi-count (map (lambda (desc)
404 (cons (car desc) 0))
405 option-desc-list)))
406 (map (lambda (spec)
407 (let ((name (string->symbol (option-spec->name spec))))
408 (cons name
409 ;; handle multiple occurrances
410 (let ((maybe-ls (option-spec->value spec)))
411 (if (list? maybe-ls)
412 (let* ((look (assq name multi-count))
413 (idx (cdr look))
414 (val (list-ref maybe-ls idx)))
415 (set-cdr! look (1+ idx)) ; ugh!
416 val)
417 maybe-ls)))))
418 found)))))
419
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))
424
425 ;;; getopt-long.scm ends here