Commit | Line | Data |
---|---|---|
d39b9676 | 1 | ;;; Copyright (C) 1998, 2001, 2006, 2009 Free Software Foundation, Inc. |
4925695e | 2 | ;;; |
53befeb7 NJ |
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. | |
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 | |
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 | |
b15dea68 | 163 | (eval-when (eval load compile) |
d39b9676 | 164 | ;; This binding is used both at compile-time and run-time. |
d39b9676 | 165 | (define option-spec-fields '(name |
b15dea68 AW |
166 | value |
167 | required? | |
168 | single-char | |
169 | predicate | |
170 | value-policy))) | |
4925695e | 171 | |
3925d0c3 TTN |
172 | (define option-spec (make-record-type 'option-spec option-spec-fields)) |
173 | (define make-option-spec (record-constructor option-spec option-spec-fields)) | |
4925695e | 174 | |
b15dea68 | 175 | (eval-when (eval load compile) |
d39b9676 LC |
176 | ;; The following procedures are used only at compile-time when expanding |
177 | ;; `define-all-option-spec-accessors/modifiers' (see below). | |
178 | ||
179 | (define (define-one-option-spec-field-accessor field) | |
b15dea68 | 180 | `(define ,(symbol-append 'option-spec-> field) ;;; name slib-compat |
d39b9676 | 181 | (record-accessor option-spec ',field))) |
4925695e | 182 | |
d39b9676 | 183 | (define (define-one-option-spec-field-modifier field) |
b15dea68 AW |
184 | `(define ,(symbol-append 'set-option-spec- field '!) ;;; name slib-compat |
185 | (record-modifier option-spec ',field)))) | |
4925695e | 186 | |
3925d0c3 TTN |
187 | (defmacro define-all-option-spec-accessors/modifiers () |
188 | `(begin | |
189 | ,@(map define-one-option-spec-field-accessor option-spec-fields) | |
190 | ,@(map define-one-option-spec-field-modifier option-spec-fields))) | |
4925695e | 191 | |
3925d0c3 | 192 | (define-all-option-spec-accessors/modifiers) |
4925695e | 193 | |
3925d0c3 TTN |
194 | (define make-option-spec |
195 | (let ((ctor (record-constructor option-spec '(name)))) | |
196 | (lambda (name) | |
197 | (ctor name)))) | |
64705682 | 198 | |
4925695e | 199 | (define (parse-option-spec desc) |
3925d0c3 TTN |
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) | |
204 | ((required?) | |
205 | (set-option-spec-required?! spec (given))) | |
206 | ((value) | |
207 | (set-option-spec-value-policy! spec (given))) | |
208 | ((single-char) | |
209 | (or (char? (given)) | |
210 | (error "`single-char' value must be a char!")) | |
211 | (set-option-spec-single-char! spec (given))) | |
212 | ((predicate) | |
213 | (set-option-spec-predicate! | |
214 | spec ((lambda (pred) | |
215 | (lambda (name val) | |
216 | (or (not val) | |
217 | (pred val) | |
218 | (error "option predicate failed:" name)))) | |
219 | (given)))) | |
220 | (else | |
221 | (error "invalid getopt-long option property:" | |
222 | (car desc-elem)))))) | |
223 | (cdr desc)) | |
224 | spec)) | |
4925695e | 225 | |
4925695e | 226 | (define (split-arg-list argument-list) |
3925d0c3 TTN |
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)))))) | |
4925695e | 233 | |
3925d0c3 TTN |
234 | (define short-opt-rx (make-regexp "^-([a-zA-Z]+)(.*)")) |
235 | (define long-opt-no-value-rx (make-regexp "^--([^=]+)$")) | |
4925695e JB |
236 | (define long-opt-with-value-rx (make-regexp "^--([^=]+)=(.*)")) |
237 | ||
3925d0c3 TTN |
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)))) | |
4925695e | 242 | |
3925d0c3 TTN |
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)) | |
249 | => (lambda (match) | |
250 | (let ((singles (reverse | |
251 | (map (lambda (c) | |
252 | (string-append "-" (make-string 1 c))) | |
253 | (string->list | |
254 | (match-substring match 1))))) | |
255 | (extra (match-substring match 2))) | |
256 | (loop (cdr opt-ls) | |
257 | (append (if (string=? "" extra) | |
258 | singles | |
259 | (cons extra singles)) | |
260 | ret-ls))))) | |
261 | (else (loop (cdr opt-ls) | |
262 | (cons (car opt-ls) ret-ls)))))) | |
4925695e | 263 | |
3925d0c3 TTN |
264 | (define (looks-like-an-option string) |
265 | (some (lambda (rx) | |
266 | (regexp-exec rx string)) | |
267 | `(,short-opt-rx | |
268 | ,long-opt-with-value-rx | |
269 | ,long-opt-no-value-rx))) | |
4925695e | 270 | |
3925d0c3 TTN |
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)) | |
278 | specs)) | |
279 | (sc-idx (map (lambda (spec) | |
280 | (cons (make-string 1 (option-spec->single-char spec)) | |
281 | 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) | |
05326ffd TTN |
286 | (set-option-spec-value! |
287 | spec | |
288 | ;; handle multiple occurrances | |
289 | (cond ((option-spec->value spec) | |
290 | => (lambda (cur) | |
291 | ((if (list? cur) cons list) | |
292 | val cur))) | |
293 | (else val))) | |
3925d0c3 TTN |
294 | (loop n-ls n-found n-etc))) |
295 | (ERR:no-arg (lambda () | |
296 | (error (string-append | |
297 | "option must be specified" | |
298 | " with argument:") | |
299 | (option-spec->name spec))))) | |
300 | (cond | |
301 | ((eq? 'optional (option-spec->value-policy spec)) | |
302 | (if (or (null? (cdr ls)) | |
303 | (looks-like-an-option (cadr ls))) | |
304 | (val!loop #t | |
305 | (cdr ls) | |
306 | (cons spec found) | |
307 | etc) | |
308 | (val!loop (cadr ls) | |
309 | (cddr ls) | |
310 | (cons spec found) | |
311 | etc))) | |
312 | ((eq? #t (option-spec->value-policy spec)) | |
313 | (if (or (null? (cdr ls)) | |
314 | (looks-like-an-option (cadr ls))) | |
315 | (ERR:no-arg) | |
316 | (val!loop (cadr ls) | |
317 | (cddr ls) | |
318 | (cons spec found) | |
319 | etc))) | |
320 | (else | |
321 | (val!loop #t | |
322 | (cdr ls) | |
323 | (cons spec found) | |
324 | etc))))))) | |
325 | (if (null? argument-ls) | |
326 | (cons found (reverse etc)) ;;; retval | |
327 | (cond ((regexp-exec short-opt-rx (car argument-ls)) | |
328 | => (lambda (match) | |
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)) | |
334 | => (lambda (match) | |
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)) | |
340 | => (lambda (match) | |
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) | |
345 | (eat! spec (append | |
346 | (list 'ignored | |
347 | (match-substring match 2)) | |
348 | (cdr argument-ls))) | |
349 | (error "option does not support argument:" | |
350 | opt))))) | |
351 | (else | |
352 | (loop (cdr argument-ls) | |
353 | found | |
354 | (cons (car argument-ls) etc))))))))) | |
4925695e JB |
355 | |
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 | |
361 | following grammar: | |
362 | ||
363 | <option-spec> :: (<name> . <attribute-ls>) | |
364 | <attribute-ls> :: (<attribute> . <attribute-ls>) | |
365 | | () | |
366 | <attribute> :: <required-attribute> | |
367 | | <arg-required-attribute> | |
368 | | <single-char-attribute> | |
369 | | <predicate-attribute> | |
370 | | <value-attribute> | |
371 | <required-attribute> :: (required? <boolean>) | |
372 | <single-char-attribute> :: (single-char <char>) | |
373 | <value-attribute> :: (value #t) | |
374 | (value #f) | |
375 | (value optional) | |
376 | <predicate-attribute> :: (predicate <1-ary-function>) | |
377 | ||
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 | |
382 | or option values. | |
64705682 | 383 | By default, options are not required, and option values are not |
4925695e JB |
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 | |
3925d0c3 | 386 | to add a `single-char' clause to the option description." |
4925695e JB |
387 | (let* ((specifications (map parse-option-spec option-desc-list)) |
388 | (pair (split-arg-list (cdr program-arguments))) | |
3925d0c3 TTN |
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)) | |
402 | (or val | |
403 | (error "option must be specified with argument:" | |
404 | name))) | |
405 | (let ((pred (option-spec->predicate spec))) | |
406 | (and pred (pred name val))))) | |
407 | specifications) | |
408 | (cons (cons '() rest-ls) | |
05326ffd TTN |
409 | (let ((multi-count (map (lambda (desc) |
410 | (cons (car desc) 0)) | |
411 | option-desc-list))) | |
412 | (map (lambda (spec) | |
413 | (let ((name (string->symbol (option-spec->name spec)))) | |
414 | (cons name | |
415 | ;; handle multiple occurrances | |
416 | (let ((maybe-ls (option-spec->value spec))) | |
417 | (if (list? maybe-ls) | |
418 | (let* ((look (assq name multi-count)) | |
419 | (idx (cdr look)) | |
420 | (val (list-ref maybe-ls idx))) | |
421 | (set-cdr! look (1+ idx)) ; ugh! | |
422 | val) | |
423 | maybe-ls))))) | |
424 | found))))) | |
4925695e JB |
425 | |
426 | (define (option-ref options key default) | |
3925d0c3 TTN |
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)) | |
64705682 TTN |
430 | |
431 | ;;; getopt-long.scm ends here |