Commit | Line | Data |
---|---|---|
23f11f1d | 1 | ;;; Copyright (C) 1998, 2001, 2006, 2009, 2011 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) | |
8b9b0af4 | 160 | #:use-module ((ice-9 common-list) #:select (remove-if-not)) |
23f11f1d | 161 | #:use-module (srfi srfi-9) |
887fac45 | 162 | #:use-module (ice-9 match) |
88c9420c | 163 | #:use-module (ice-9 regex) |
6b4b4bfb | 164 | #:use-module (ice-9 optargs) |
23f11f1d AW |
165 | #:export (getopt-long option-ref)) |
166 | ||
9447207f | 167 | (define %program-name (make-fluid "guile")) |
0bc86fce | 168 | (define (program-name) |
9447207f | 169 | (fluid-ref %program-name)) |
0bc86fce AW |
170 | |
171 | (define (fatal-error fmt . args) | |
172 | (format (current-error-port) "~a: " (program-name)) | |
173 | (apply format (current-error-port) fmt args) | |
174 | (newline (current-error-port)) | |
175 | (exit 1)) | |
176 | ||
23f11f1d | 177 | (define-record-type option-spec |
fe040dd1 | 178 | (%make-option-spec name required? option-spec->single-char predicate value-policy) |
23f11f1d AW |
179 | option-spec? |
180 | (name | |
181 | option-spec->name set-option-spec-name!) | |
23f11f1d AW |
182 | (required? |
183 | option-spec->required? set-option-spec-required?!) | |
184 | (option-spec->single-char | |
185 | option-spec->single-char set-option-spec-single-char!) | |
186 | (predicate | |
187 | option-spec->predicate set-option-spec-predicate!) | |
188 | (value-policy | |
189 | option-spec->value-policy set-option-spec-value-policy!)) | |
190 | ||
191 | (define (make-option-spec name) | |
fe040dd1 | 192 | (%make-option-spec name #f #f #f #f)) |
64705682 | 193 | |
4925695e | 194 | (define (parse-option-spec desc) |
3925d0c3 | 195 | (let ((spec (make-option-spec (symbol->string (car desc))))) |
887fac45 AW |
196 | (for-each (match-lambda |
197 | (('required? val) | |
198 | (set-option-spec-required?! spec val)) | |
199 | (('value val) | |
200 | (set-option-spec-value-policy! spec val)) | |
201 | (('single-char val) | |
202 | (or (char? val) | |
203 | (error "`single-char' value must be a char!")) | |
204 | (set-option-spec-single-char! spec val)) | |
205 | (('predicate pred) | |
206 | (set-option-spec-predicate! | |
207 | spec (lambda (name val) | |
208 | (or (not val) | |
209 | (pred val) | |
0bc86fce AW |
210 | (fatal-error "option predicate failed: --~a" |
211 | name))))) | |
887fac45 AW |
212 | ((prop val) |
213 | (error "invalid getopt-long option property:" prop))) | |
3925d0c3 TTN |
214 | (cdr desc)) |
215 | spec)) | |
4925695e | 216 | |
4925695e | 217 | (define (split-arg-list argument-list) |
3925d0c3 TTN |
218 | ;; Scan ARGUMENT-LIST for "--" and return (BEFORE-LS . AFTER-LS). |
219 | ;; Discard the "--". If no "--" is found, AFTER-LS is empty. | |
220 | (let loop ((yes '()) (no argument-list)) | |
221 | (cond ((null? no) (cons (reverse yes) no)) | |
222 | ((string=? "--" (car no)) (cons (reverse yes) (cdr no))) | |
223 | (else (loop (cons (car no) yes) (cdr no)))))) | |
4925695e | 224 | |
3925d0c3 TTN |
225 | (define short-opt-rx (make-regexp "^-([a-zA-Z]+)(.*)")) |
226 | (define long-opt-no-value-rx (make-regexp "^--([^=]+)$")) | |
4925695e JB |
227 | (define long-opt-with-value-rx (make-regexp "^--([^=]+)=(.*)")) |
228 | ||
3925d0c3 | 229 | (define (looks-like-an-option string) |
8b9b0af4 AW |
230 | (or (regexp-exec short-opt-rx string) |
231 | (regexp-exec long-opt-with-value-rx string) | |
232 | (regexp-exec long-opt-no-value-rx string))) | |
4925695e | 233 | |
6b4b4bfb | 234 | (define (process-options specs argument-ls stop-at-first-non-option) |
3925d0c3 TTN |
235 | ;; Use SPECS to scan ARGUMENT-LS; return (FOUND . ETC). |
236 | ;; FOUND is an unordered list of option specs for found options, while ETC | |
237 | ;; is an order-maintained list of elements in ARGUMENT-LS that are neither | |
238 | ;; options nor their values. | |
239 | (let ((idx (map (lambda (spec) | |
240 | (cons (option-spec->name spec) spec)) | |
241 | specs)) | |
242 | (sc-idx (map (lambda (spec) | |
243 | (cons (make-string 1 (option-spec->single-char spec)) | |
244 | spec)) | |
245 | (remove-if-not option-spec->single-char specs)))) | |
0faf4b2a | 246 | (let loop ((unclumped 0) (argument-ls argument-ls) (found '()) (etc '())) |
cafb15e9 | 247 | (define (eat! spec ls) |
cafb15e9 AW |
248 | (cond |
249 | ((eq? 'optional (option-spec->value-policy spec)) | |
13f607c1 AW |
250 | (if (or (null? ls) |
251 | (looks-like-an-option (car ls))) | |
0faf4b2a NJ |
252 | (loop (- unclumped 1) ls (acons spec #t found) etc) |
253 | (loop (- unclumped 2) (cdr ls) (acons spec (car ls) found) etc))) | |
cafb15e9 | 254 | ((eq? #t (option-spec->value-policy spec)) |
13f607c1 AW |
255 | (if (or (null? ls) |
256 | (looks-like-an-option (car ls))) | |
0bc86fce AW |
257 | (fatal-error "option must be specified with argument: --~a" |
258 | (option-spec->name spec)) | |
0faf4b2a | 259 | (loop (- unclumped 2) (cdr ls) (acons spec (car ls) found) etc))) |
cafb15e9 | 260 | (else |
0faf4b2a | 261 | (loop (- unclumped 1) ls (acons spec #t found) etc)))) |
cafb15e9 | 262 | |
13f607c1 AW |
263 | (match argument-ls |
264 | (() | |
265 | (cons found (reverse etc))) | |
266 | ((opt . rest) | |
267 | (cond | |
268 | ((regexp-exec short-opt-rx opt) | |
269 | => (lambda (match) | |
0faf4b2a NJ |
270 | (if (> unclumped 0) |
271 | ;; Next option is known not to be clumped. | |
272 | (let* ((c (match:substring match 1)) | |
273 | (spec (or (assoc-ref sc-idx c) | |
274 | (fatal-error "no such option: -~a" c)))) | |
275 | (eat! spec rest)) | |
276 | ;; Expand a clumped group of short options. | |
277 | (let* ((extra (match:substring match 2)) | |
278 | (unclumped-opts | |
279 | (append (map (lambda (c) | |
280 | (string-append "-" (make-string 1 c))) | |
281 | (string->list | |
282 | (match:substring match 1))) | |
283 | (if (string=? "" extra) '() (list extra))))) | |
284 | (loop (length unclumped-opts) | |
285 | (append unclumped-opts rest) | |
286 | found | |
287 | etc))))) | |
13f607c1 AW |
288 | ((regexp-exec long-opt-no-value-rx opt) |
289 | => (lambda (match) | |
290 | (let* ((opt (match:substring match 1)) | |
291 | (spec (or (assoc-ref idx opt) | |
0bc86fce | 292 | (fatal-error "no such option: --~a" opt)))) |
13f607c1 AW |
293 | (eat! spec rest)))) |
294 | ((regexp-exec long-opt-with-value-rx opt) | |
295 | => (lambda (match) | |
296 | (let* ((opt (match:substring match 1)) | |
297 | (spec (or (assoc-ref idx opt) | |
0bc86fce | 298 | (fatal-error "no such option: --~a" opt)))) |
13f607c1 AW |
299 | (if (option-spec->value-policy spec) |
300 | (eat! spec (cons (match:substring match 2) rest)) | |
0bc86fce AW |
301 | (fatal-error "option does not support argument: --~a" |
302 | opt))))) | |
6b4b4bfb NJ |
303 | ((and stop-at-first-non-option |
304 | (<= unclumped 0)) | |
305 | (cons found (append (reverse etc) argument-ls))) | |
13f607c1 | 306 | (else |
0faf4b2a | 307 | (loop (- unclumped 1) rest found (cons opt etc))))))))) |
4925695e | 308 | |
6b4b4bfb NJ |
309 | (define* (getopt-long program-arguments option-desc-list |
310 | #:key stop-at-first-non-option) | |
4925695e JB |
311 | "Process options, handling both long and short options, similar to |
312 | the glibc function 'getopt_long'. PROGRAM-ARGUMENTS should be a value | |
313 | similar to what (program-arguments) returns. OPTION-DESC-LIST is a | |
314 | list of option descriptions. Each option description must satisfy the | |
315 | following grammar: | |
316 | ||
317 | <option-spec> :: (<name> . <attribute-ls>) | |
318 | <attribute-ls> :: (<attribute> . <attribute-ls>) | |
319 | | () | |
320 | <attribute> :: <required-attribute> | |
321 | | <arg-required-attribute> | |
322 | | <single-char-attribute> | |
323 | | <predicate-attribute> | |
324 | | <value-attribute> | |
325 | <required-attribute> :: (required? <boolean>) | |
326 | <single-char-attribute> :: (single-char <char>) | |
327 | <value-attribute> :: (value #t) | |
328 | (value #f) | |
329 | (value optional) | |
330 | <predicate-attribute> :: (predicate <1-ary-function>) | |
331 | ||
332 | The procedure returns an alist of option names and values. Each | |
333 | option name is a symbol. The option value will be '#t' if no value | |
334 | was specified. There is a special item in the returned alist with a | |
335 | key of the empty list, (): the list of arguments that are not options | |
336 | or option values. | |
64705682 | 337 | By default, options are not required, and option values are not |
4925695e JB |
338 | required. By default, single character equivalents are not supported; |
339 | if you want to allow the user to use single character options, you need | |
3925d0c3 | 340 | to add a `single-char' clause to the option description." |
0bc86fce AW |
341 | (with-fluids ((%program-name (car program-arguments))) |
342 | (let* ((specifications (map parse-option-spec option-desc-list)) | |
343 | (pair (split-arg-list (cdr program-arguments))) | |
0faf4b2a | 344 | (split-ls (car pair)) |
0bc86fce | 345 | (non-split-ls (cdr pair)) |
6b4b4bfb NJ |
346 | (found/etc (process-options specifications split-ls |
347 | stop-at-first-non-option)) | |
0bc86fce AW |
348 | (found (car found/etc)) |
349 | (rest-ls (append (cdr found/etc) non-split-ls))) | |
350 | (for-each (lambda (spec) | |
351 | (let ((name (option-spec->name spec)) | |
1e2cc0b6 | 352 | (val (assq-ref found spec))) |
0bc86fce | 353 | (and (option-spec->required? spec) |
1e2cc0b6 | 354 | (or val |
0bc86fce AW |
355 | (fatal-error "option must be specified: --~a" |
356 | name))) | |
0bc86fce AW |
357 | (let ((pred (option-spec->predicate spec))) |
358 | (and pred (pred name val))))) | |
359 | specifications) | |
1e2cc0b6 NJ |
360 | (for-each (lambda (spec+val) |
361 | (set-car! spec+val | |
362 | (string->symbol (option-spec->name (car spec+val))))) | |
363 | found) | |
364 | (cons (cons '() rest-ls) found)))) | |
4925695e JB |
365 | |
366 | (define (option-ref options key default) | |
3925d0c3 TTN |
367 | "Return value in alist OPTIONS using KEY, a symbol; or DEFAULT if not found. |
368 | The value is either a string or `#t'." | |
369 | (or (assq-ref options key) default)) | |
64705682 TTN |
370 | |
371 | ;;; getopt-long.scm ends here |