Commit | Line | Data |
---|---|---|
cd5fea8d | 1 | ;;; Copyright (C) 1998, 2001, 2006 Free Software Foundation, Inc. |
4925695e | 2 | ;;; |
73be1d9e MV |
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 | |
92205699 | 15 | ;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA |
64705682 | 16 | |
3925d0c3 TTN |
17 | ;;; Author: Russ McManus (rewritten by Thien-Thi Nguyen) |
18 | ||
64705682 TTN |
19 | ;;; Commentary: |
20 | ||
4925695e | 21 | ;;; This module implements some complex command line option parsing, in |
3925d0c3 | 22 | ;;; the spirit of the GNU C library function `getopt_long'. Both long |
4925695e | 23 | ;;; and short options are supported. |
64705682 | 24 | ;;; |
4925695e JB |
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. | |
64705682 | 28 | ;;; |
3925d0c3 TTN |
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. | |
4925695e JB |
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: | |
64705682 | 47 | ;;; |
4925695e JB |
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 | |
64705682 | 56 | ;;; without a value. |
4925695e JB |
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. | |
64705682 | 68 | ;;; |
4925695e JB |
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 | |
3925d0c3 TTN |
87 | ;;; the next element is does not appear to be an option itself, then |
88 | ;;; that element is the option's value. | |
4925695e JB |
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: | |
3925d0c3 TTN |
116 | ;;; - it finds an unrecognized property in GRAMMAR |
117 | ;;; - the value of the `single-char' property is not a character | |
4925695e JB |
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)) | |
64705682 | 136 | ;;; (rnet-server (single-char #\y) |
4925695e JB |
137 | ;;; (predicate ,string?)))) |
138 | ;;; | |
64705682 | 139 | ;;; (getopt-long '("my-prog" "-vk" "/tmp" "foo1" "--x-includes=/usr/include" |
4925695e JB |
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 | ||
3925d0c3 TTN |
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 | ||
64705682 | 157 | ;;; Code: |
4925695e JB |
158 | |
159 | (define-module (ice-9 getopt-long) | |
3925d0c3 TTN |
160 | :use-module ((ice-9 common-list) :select (some remove-if-not)) |
161 | :export (getopt-long option-ref)) | |
4925695e | 162 | |
3925d0c3 TTN |
163 | (define option-spec-fields '(name |
164 | value | |
165 | required? | |
166 | single-char | |
167 | predicate | |
168 | value-policy)) | |
4925695e | 169 | |
3925d0c3 TTN |
170 | (define option-spec (make-record-type 'option-spec option-spec-fields)) |
171 | (define make-option-spec (record-constructor option-spec option-spec-fields)) | |
4925695e | 172 | |
3925d0c3 TTN |
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))) | |
4925695e | 176 | |
3925d0c3 TTN |
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))) | |
4925695e | 180 | |
3925d0c3 TTN |
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))) | |
4925695e | 185 | |
3925d0c3 | 186 | (define-all-option-spec-accessors/modifiers) |
4925695e | 187 | |
3925d0c3 TTN |
188 | (define make-option-spec |
189 | (let ((ctor (record-constructor option-spec '(name)))) | |
190 | (lambda (name) | |
191 | (ctor name)))) | |
64705682 | 192 | |
4925695e | 193 | (define (parse-option-spec desc) |
3925d0c3 TTN |
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)) | |
4925695e | 219 | |
4925695e | 220 | (define (split-arg-list argument-list) |
3925d0c3 TTN |
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)))))) | |
4925695e | 227 | |
3925d0c3 TTN |
228 | (define short-opt-rx (make-regexp "^-([a-zA-Z]+)(.*)")) |
229 | (define long-opt-no-value-rx (make-regexp "^--([^=]+)$")) | |
4925695e JB |
230 | (define long-opt-with-value-rx (make-regexp "^--([^=]+)=(.*)")) |
231 | ||
3925d0c3 TTN |
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)))) | |
4925695e | 236 | |
3925d0c3 TTN |
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)))))) | |
4925695e | 257 | |
3925d0c3 TTN |
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))) | |
4925695e | 264 | |
3925d0c3 TTN |
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) | |
05326ffd TTN |
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))) | |
3925d0c3 TTN |
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))))))))) | |
4925695e JB |
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. | |
64705682 | 377 | By default, options are not required, and option values are not |
4925695e JB |
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 | |
3925d0c3 | 380 | to add a `single-char' clause to the option description." |
4925695e JB |
381 | (let* ((specifications (map parse-option-spec option-desc-list)) |
382 | (pair (split-arg-list (cdr program-arguments))) | |
3925d0c3 TTN |
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) | |
05326ffd TTN |
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))))) | |
4925695e JB |
419 | |
420 | (define (option-ref options key default) | |
3925d0c3 TTN |
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)) | |
64705682 TTN |
424 | |
425 | ;;; getopt-long.scm ends here |