Commit | Line | Data |
---|---|---|
4925695e | 1 | ;;; Author: Russ McManus |
cb5d1fb7 | 2 | ;;; $Id: getopt-long.scm,v 1.2 1999-02-15 12:53:10 jimb Exp $ |
4925695e JB |
3 | ;;; |
4 | ;;; Copyright (C) 1998 FSF | |
5 | ;;; | |
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. | |
10 | ;;; | |
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. | |
15 | ;;; | |
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 | |
19 | ;;; | |
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. | |
23 | ;;; | |
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. | |
27 | ;;; | |
28 | ||
29 | ;;; getopt-long is a function for parsing command-line arguments in a | |
30 | ;;; manner consistent with other GNU programs. | |
31 | ||
32 | ;;; (getopt-long ARGS GRAMMAR) | |
33 | ;;; Parse the arguments ARGS according to the argument list grammar GRAMMAR. | |
34 | ;;; | |
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. | |
39 | ;;; | |
40 | ;;; GRAMMAR is a list of the form: | |
41 | ;;; ((OPTION (PROPERTY VALUE) ...) ...) | |
42 | ;;; | |
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: | |
46 | ;;; | |
47 | ;;; (single-char CHAR) --- Accept `-CHAR' as a single-character | |
48 | ;;; equivalent to `--OPTION'. This is how to specify traditional | |
49 | ;;; Unix-style flags. | |
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 | |
55 | ;;; without a value. | |
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. | |
62 | ;;; | |
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 | |
66 | ;;; values. | |
67 | ;;; | |
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) | |
83 | ;;; | |
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. | |
88 | ;;; | |
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 | |
92 | ;;; are equivalent: | |
93 | ;;; ("--apples" "Braeburn" "--blimps" "Goodyear") | |
94 | ;;; ("--apples=Braeburn" "--blimps" "Goodyear") | |
95 | ;;; ("--blimps" "Goodyear" "--apples=Braeburn") | |
96 | ;;; | |
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. | |
105 | ;;; | |
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. | |
110 | ;;; | |
111 | ;;; All arguments that are not the value of any option are returned | |
112 | ;;; as a list, associated with the empty list. | |
113 | ;;; | |
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 | |
121 | ;;; | |
122 | ;;; So, for example: | |
123 | ;;; | |
124 | ;;; (define grammar | |
125 | ;;; `((lockfile-dir (required? #t) | |
126 | ;;; (value #t) | |
127 | ;;; (single-char #\k) | |
128 | ;;; (predicate ,file-is-directory?)) | |
129 | ;;; (verbose (required? #f) | |
130 | ;;; (single-char #\v) | |
131 | ;;; (value #f)) | |
132 | ;;; (x-includes (single-char #\x)) | |
133 | ;;; (rnet-server (single-char #\y) | |
134 | ;;; (predicate ,string?)))) | |
135 | ;;; | |
136 | ;;; (getopt-long '("my-prog" "-vk" "/tmp" "foo1" "--x-includes=/usr/include" | |
137 | ;;; "--rnet-server=lamprod" "--" "-fred" "foo2" "foo3") | |
138 | ;;; grammar) | |
139 | ;;; => ((() "foo1" "-fred" "foo2" "foo3") | |
140 | ;;; (rnet-server . "lamprod") | |
141 | ;;; (x-includes . "/usr/include") | |
142 | ;;; (lockfile-dir . "/tmp") | |
143 | ;;; (verbose . #t)) | |
144 | ||
145 | ||
146 | (define-module (ice-9 getopt-long) | |
147 | :use-module (ice-9 common-list)) | |
148 | ;;; end-header | |
149 | ||
150 | \f | |
151 | ;;; The code on this page was expanded by hand using the following code: | |
152 | ;;; (pretty-print | |
153 | ;;; (macroexpand | |
154 | ;;; '(define-record option-spec | |
155 | ;;; (name | |
156 | ;;; value | |
157 | ;;; value-required? | |
158 | ;;; single-char | |
159 | ;;; predicate-ls | |
160 | ;;; parse-ls)))) | |
161 | ;;; | |
162 | ;;; This avoids the need to load slib for records. | |
163 | (define slib:error error) | |
164 | (begin (define | |
165 | option-spec->name | |
166 | (lambda | |
167 | (obj) | |
168 | (if (option-spec? obj) | |
169 | (vector-ref obj 1) | |
170 | (slib:error | |
171 | (quote option-spec->name) | |
172 | ": bad record" | |
173 | obj)))) | |
174 | (define | |
175 | option-spec->value | |
176 | (lambda | |
177 | (obj) | |
178 | (if (option-spec? obj) | |
179 | (vector-ref obj 2) | |
180 | (slib:error | |
181 | (quote option-spec->value) | |
182 | ": bad record" | |
183 | obj)))) | |
184 | (define | |
185 | option-spec->value-required? | |
186 | (lambda | |
187 | (obj) | |
188 | (if (option-spec? obj) | |
189 | (vector-ref obj 3) | |
190 | (slib:error | |
191 | (quote option-spec->value-required?) | |
192 | ": bad record" | |
193 | obj)))) | |
194 | (define | |
195 | option-spec->single-char | |
196 | (lambda | |
197 | (obj) | |
198 | (if (option-spec? obj) | |
199 | (vector-ref obj 4) | |
200 | (slib:error | |
201 | (quote option-spec->single-char) | |
202 | ": bad record" | |
203 | obj)))) | |
204 | (define | |
205 | option-spec->predicate-ls | |
206 | (lambda | |
207 | (obj) | |
208 | (if (option-spec? obj) | |
209 | (vector-ref obj 5) | |
210 | (slib:error | |
211 | (quote option-spec->predicate-ls) | |
212 | ": bad record" | |
213 | obj)))) | |
214 | (define | |
215 | option-spec->parse-ls | |
216 | (lambda | |
217 | (obj) | |
218 | (if (option-spec? obj) | |
219 | (vector-ref obj 6) | |
220 | (slib:error | |
221 | (quote option-spec->parse-ls) | |
222 | ": bad record" | |
223 | obj)))) | |
224 | (define | |
225 | set-option-spec-name! | |
226 | (lambda | |
227 | (obj val) | |
228 | (if (option-spec? obj) | |
229 | (vector-set! obj 1 val) | |
230 | (slib:error | |
231 | (quote set-option-spec-name!) | |
232 | ": bad record" | |
233 | obj)))) | |
234 | (define | |
235 | set-option-spec-value! | |
236 | (lambda | |
237 | (obj val) | |
238 | (if (option-spec? obj) | |
239 | (vector-set! obj 2 val) | |
240 | (slib:error | |
241 | (quote set-option-spec-value!) | |
242 | ": bad record" | |
243 | obj)))) | |
244 | (define | |
245 | set-option-spec-value-required?! | |
246 | (lambda | |
247 | (obj val) | |
248 | (if (option-spec? obj) | |
249 | (vector-set! obj 3 val) | |
250 | (slib:error | |
251 | (quote set-option-spec-value-required?!) | |
252 | ": bad record" | |
253 | obj)))) | |
254 | (define | |
255 | set-option-spec-single-char! | |
256 | (lambda | |
257 | (obj val) | |
258 | (if (option-spec? obj) | |
259 | (vector-set! obj 4 val) | |
260 | (slib:error | |
261 | (quote set-option-spec-single-char!) | |
262 | ": bad record" | |
263 | obj)))) | |
264 | (define | |
265 | set-option-spec-predicate-ls! | |
266 | (lambda | |
267 | (obj val) | |
268 | (if (option-spec? obj) | |
269 | (vector-set! obj 5 val) | |
270 | (slib:error | |
271 | (quote set-option-spec-predicate-ls!) | |
272 | ": bad record" | |
273 | obj)))) | |
274 | (define | |
275 | set-option-spec-parse-ls! | |
276 | (lambda | |
277 | (obj val) | |
278 | (if (option-spec? obj) | |
279 | (vector-set! obj 6 val) | |
280 | (slib:error | |
281 | (quote set-option-spec-parse-ls!) | |
282 | ": bad record" | |
283 | obj)))) | |
284 | (define | |
285 | option-spec? | |
286 | (lambda | |
287 | (obj) | |
288 | (and (vector? obj) | |
289 | (= (vector-length obj) 7) | |
290 | (eq? (vector-ref obj 0) (quote option-spec))))) | |
291 | (define | |
292 | make-option-spec | |
293 | (lambda | |
294 | (option-spec->name | |
295 | option-spec->value | |
296 | option-spec->value-required? | |
297 | option-spec->single-char | |
298 | option-spec->predicate-ls | |
299 | option-spec->parse-ls) | |
300 | (vector | |
301 | (quote option-spec) | |
302 | option-spec->name | |
303 | option-spec->value | |
304 | option-spec->value-required? | |
305 | option-spec->single-char | |
306 | option-spec->predicate-ls | |
307 | option-spec->parse-ls)))) | |
308 | ||
309 | \f | |
310 | ;;; | |
311 | ;;; parse functions go on this page. | |
312 | ;;; | |
313 | (define make-user-predicate | |
314 | (lambda (pred) | |
315 | (lambda (spec) | |
316 | (let ((val (option-spec->value spec))) | |
317 | (if (and val | |
318 | (pred val)) #t | |
319 | (error "option predicate failed:" (option-spec->name spec))))))) | |
320 | ||
321 | (define make-not-allowed-value-fn | |
322 | (lambda () | |
323 | (lambda (spec) | |
324 | (let ((val (option-spec->value spec))) | |
325 | (if (not (or (eq? val #t) | |
326 | (eq? val #f))) | |
327 | (let ((name (option-spec->name spec))) | |
328 | (error "option does not support argument:" name))))))) | |
329 | ||
330 | (define make-option-required-predicate | |
331 | (lambda () | |
332 | (lambda (spec) | |
333 | (let ((val (option-spec->value spec))) | |
334 | (if (not val) | |
335 | (let ((name (option-spec->name spec))) | |
336 | (error "option must be specified:" name))))))) | |
337 | ||
338 | (define make-option-value-predicate | |
339 | (lambda (predicate) | |
340 | (lambda (spec) | |
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))))))) | |
345 | ||
346 | (define make-required-value-fn | |
347 | (lambda () | |
348 | (lambda (spec) | |
349 | (let ((val (option-spec->value spec))) | |
350 | (if (eq? val #t) | |
351 | (let ((name (option-spec->name spec))) | |
352 | (error "option must be specified with argument:" name))))))) | |
353 | ||
354 | (define single-char-value? | |
355 | (lambda (val) | |
356 | (char? val))) | |
357 | ||
358 | (define (parse-option-spec desc) | |
359 | (letrec ((parse-iter | |
360 | (lambda (spec) | |
361 | (let ((parse-ls (option-spec->parse-ls spec))) | |
362 | (if (null? parse-ls) | |
363 | spec | |
364 | (let ((ls (car parse-ls))) | |
365 | (if (or (not (list? ls)) | |
366 | (not (= (length ls) 2))) | |
367 | (error "Bad option specification:" ls)) | |
368 | (let ((key (car ls)) | |
369 | (val (cadr 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)) | |
378 | (cdr parse-ls)))) | |
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) | |
386 | (cdr parse-ls)))) | |
387 | ;; handle value specification | |
388 | ((eq? key 'value) | |
389 | (cond ((eq? val #t) | |
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) | |
394 | #t | |
395 | (option-spec->single-char spec) | |
396 | (cons (make-required-value-fn) | |
397 | (option-spec->predicate-ls spec)) | |
398 | (cdr parse-ls)))) | |
399 | ((eq? val #f) | |
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 | |
402 | ;; value against #f. | |
403 | (parse-iter (make-option-spec (option-spec->name spec) | |
404 | (option-spec->value spec) | |
405 | #f | |
406 | (option-spec->single-char spec) | |
407 | (cons (make-not-allowed-value-fn) | |
408 | (option-spec->predicate-ls spec)) | |
409 | (cdr parse-ls)))) | |
410 | ((eq? val 'optional) | |
cb5d1fb7 JB |
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'. | |
415 | ||
4925695e JB |
416 | (parse-iter (make-option-spec (option-spec->name spec) |
417 | (option-spec->value spec) | |
cb5d1fb7 | 418 | 'optional |
4925695e JB |
419 | (option-spec->single-char spec) |
420 | (option-spec->predicate-ls spec) | |
421 | (cdr parse-ls)))) | |
422 | (#t | |
423 | ;; error case | |
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) | |
432 | val | |
433 | (option-spec->predicate-ls spec) | |
434 | (cdr parse-ls))))) | |
435 | ((eq? key 'predicate) | |
436 | (if (procedure? val) | |
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)) | |
443 | (cdr parse-ls))) | |
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) | |
449 | #f | |
450 | #f | |
451 | #f | |
452 | '() | |
453 | (cdr desc))))) | |
454 | ||
455 | \f | |
456 | ;;; | |
457 | ;;; | |
458 | ;;; | |
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))) | |
471 | (#t | |
472 | (loop (cons (car not-process-ls) process-ls) | |
473 | (cdr not-process-ls)))))) | |
474 | ||
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 "^--([^=]+)=(.*)")) | |
478 | ||
479 | (define (single-char-expander specifications opt-ls) | |
480 | "Expand single letter options that are mushed together." | |
481 | (let ((response #f)) | |
482 | (define (is-short-opt? str) | |
483 | (set! response (regexp-exec short-opt-rx str)) | |
484 | response) | |
485 | (define (iter opt-ls ret-ls) | |
486 | (cond ((null? opt-ls) | |
487 | (reverse ret-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) | |
493 | (iter (cdr opt-ls) | |
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))))) | |
499 | (iter opt-ls '()))) | |
500 | ||
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))) | |
524 | (if spec | |
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)) | |
cb5d1fb7 JB |
528 | (not (is-long-option? next-value)) |
529 | (option-spec->value-required? spec)) | |
4925695e JB |
530 | next-value |
531 | #t)) | |
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 | |
536 | new-alist)) | |
537 | (error "No such option:" option))) | |
538 | #f))) | |
539 | ||
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 | |
547 | ;; the option value. | |
548 | (let ((resp (regexp-exec long-opt-no-value-rx option))) | |
549 | (if resp | |
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 | |
560 | ;; equal sign. | |
561 | (if resp | |
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)))) | |
566 | (cons key value)) | |
567 | #f))))) | |
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)))) | |
575 | (pair | |
576 | (cons (cdr argument-ls) (cons pair alist))) | |
577 | (else #f)))) | |
578 | ||
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))) | |
584 | (if pair | |
585 | (let ((argument-ls (car pair)) | |
586 | (alist (cdr pair))) | |
587 | (iter argument-ls alist rest-ls)) | |
588 | (let ((pair (process-long-option specifications argument-ls alist))) | |
589 | (if pair | |
590 | (let ((argument-ls (car pair)) | |
591 | (alist (cdr pair))) | |
592 | (iter argument-ls alist rest-ls)) | |
593 | (iter (cdr argument-ls) | |
594 | alist | |
595 | (cons (car argument-ls) rest-ls)))))))) | |
596 | (iter argument-ls '() '())) | |
597 | ||
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 | |
603 | following grammar: | |
604 | ||
605 | <option-spec> :: (<name> . <attribute-ls>) | |
606 | <attribute-ls> :: (<attribute> . <attribute-ls>) | |
607 | | () | |
608 | <attribute> :: <required-attribute> | |
609 | | <arg-required-attribute> | |
610 | | <single-char-attribute> | |
611 | | <predicate-attribute> | |
612 | | <value-attribute> | |
613 | <required-attribute> :: (required? <boolean>) | |
614 | <single-char-attribute> :: (single-char <char>) | |
615 | <value-attribute> :: (value #t) | |
616 | (value #f) | |
617 | (value optional) | |
618 | <predicate-attribute> :: (predicate <1-ary-function>) | |
619 | ||
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 | |
624 | or option values. | |
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)) | |
639 | (val (cdr pair)) | |
640 | (spec (find-if (lambda (spec) (eq? key (option-spec->name spec))) | |
641 | specifications))) | |
642 | (if spec (set-option-spec-value! spec val)))) | |
643 | alist) | |
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) | |
648 | (predicate spec)) | |
649 | predicate-ls))) | |
650 | specifications) | |
651 | (cons (cons '() rest-ls) alist)))) | |
652 | ||
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))) | |
657 | (if pair | |
658 | (cdr pair) | |
659 | default))) | |
660 | ||
661 | (export option-ref) | |
662 | (export getopt-long) |