1 ;;; Copyright (C) 1998, 2001, 2006, 2009, 2011 Free Software Foundation, Inc.
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.
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.
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
17 ;;; Author: Russ McManus (rewritten by Thien-Thi Nguyen)
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.
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.
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.
33 ;;; (getopt-long ARGS GRAMMAR)
34 ;;; Parse the arguments ARGS according to the argument list grammar GRAMMAR.
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.
41 ;;; GRAMMAR is a list of the form:
42 ;;; ((OPTION (PROPERTY VALUE) ...) ...)
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:
48 ;;; (single-char CHAR) --- Accept `-CHAR' as a single-character
49 ;;; equivalent to `--OPTION'. This is how to specify traditional
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
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.
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
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)
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.
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
94 ;;; ("--apples" "Braeburn" "--blimps" "Goodyear")
95 ;;; ("--apples=Braeburn" "--blimps" "Goodyear")
96 ;;; ("--blimps" "Goodyear" "--apples=Braeburn")
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.
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.
112 ;;; All arguments that are not the value of any option are returned
113 ;;; as a list, associated with the empty list.
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
128 ;;; `((lockfile-dir (required? #t)
130 ;;; (single-char #\k)
131 ;;; (predicate ,file-is-directory?))
132 ;;; (verbose (required? #f)
133 ;;; (single-char #\v)
135 ;;; (x-includes (single-char #\x))
136 ;;; (rnet-server (single-char #\y)
137 ;;; (predicate ,string?))))
139 ;;; (getopt-long '("my-prog" "-vk" "/tmp" "foo1" "--x-includes=/usr/include"
140 ;;; "--rnet-server=lamprod" "--" "-fred" "foo2" "foo3")
142 ;;; => ((() "foo1" "-fred" "foo2" "foo3")
143 ;;; (rnet-server . "lamprod")
144 ;;; (x-includes . "/usr/include")
145 ;;; (lockfile-dir . "/tmp")
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'.
152 ;;; For example, using the `getopt-long' return value from above:
154 ;;; (option-ref (getopt-long ...) 'x-includes 42) => "/usr/include"
155 ;;; (option-ref (getopt-long ...) 'not-a-key! 31) => 31
159 (define-module (ice-9 getopt-long)
160 #:use-module ((ice-9 common-list) #:select (remove-if-not))
161 #:use-module (srfi srfi-9)
162 #:use-module (ice-9 match)
163 #:use-module (ice-9 regex)
164 #:use-module (ice-9 optargs)
165 #:export (getopt-long option-ref))
167 (define %program-name (make-fluid "guile"))
168 (define (program-name)
169 (fluid-ref %program-name))
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))
177 (define-record-type option-spec
178 (%make-option-spec name required? option-spec->single-char predicate value-policy)
181 option-spec->name set-option-spec-name!)
183 option-spec->required? set-option-spec-required?!)
184 (option-spec->single-char
185 option-spec->single-char set-option-spec-single-char!)
187 option-spec->predicate set-option-spec-predicate!)
189 option-spec->value-policy set-option-spec-value-policy!))
191 (define (make-option-spec name)
192 (%make-option-spec name #f #f #f #f))
194 (define (parse-option-spec desc)
195 (let ((spec (make-option-spec (symbol->string (car desc)))))
196 (for-each (match-lambda
198 (set-option-spec-required?! spec val))
200 (set-option-spec-value-policy! spec val))
203 (error "`single-char' value must be a char!"))
204 (set-option-spec-single-char! spec val))
206 (set-option-spec-predicate!
207 spec (lambda (name val)
210 (fatal-error "option predicate failed: --~a"
213 (error "invalid getopt-long option property:" prop)))
217 (define (split-arg-list argument-list)
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))))))
225 (define short-opt-rx (make-regexp "^-([a-zA-Z]+)(.*)"))
226 (define long-opt-no-value-rx (make-regexp "^--([^=]+)$"))
227 (define long-opt-with-value-rx (make-regexp "^--([^=]+)=(.*)"))
229 (define (looks-like-an-option string)
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)))
234 (define (process-options specs argument-ls stop-at-first-non-option)
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))
242 (sc-idx (map (lambda (spec)
243 (cons (make-string 1 (option-spec->single-char spec))
245 (remove-if-not option-spec->single-char specs))))
246 (let loop ((unclumped 0) (argument-ls argument-ls) (found '()) (etc '()))
247 (define (eat! spec ls)
249 ((eq? 'optional (option-spec->value-policy spec))
251 (looks-like-an-option (car ls)))
252 (loop (- unclumped 1) ls (acons spec #t found) etc)
253 (loop (- unclumped 2) (cdr ls) (acons spec (car ls) found) etc)))
254 ((eq? #t (option-spec->value-policy spec))
256 (looks-like-an-option (car ls)))
257 (fatal-error "option must be specified with argument: --~a"
258 (option-spec->name spec))
259 (loop (- unclumped 2) (cdr ls) (acons spec (car ls) found) etc)))
261 (loop (- unclumped 1) ls (acons spec #t found) etc))))
265 (cons found (reverse etc)))
268 ((regexp-exec short-opt-rx opt)
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))))
276 ;; Expand a clumped group of short options.
277 (let* ((extra (match:substring match 2))
279 (append (map (lambda (c)
280 (string-append "-" (make-string 1 c)))
282 (match:substring match 1)))
283 (if (string=? "" extra) '() (list extra)))))
284 (loop (length unclumped-opts)
285 (append unclumped-opts rest)
288 ((regexp-exec long-opt-no-value-rx opt)
290 (let* ((opt (match:substring match 1))
291 (spec (or (assoc-ref idx opt)
292 (fatal-error "no such option: --~a" opt))))
294 ((regexp-exec long-opt-with-value-rx opt)
296 (let* ((opt (match:substring match 1))
297 (spec (or (assoc-ref idx opt)
298 (fatal-error "no such option: --~a" opt))))
299 (if (option-spec->value-policy spec)
300 (eat! spec (cons (match:substring match 2) rest))
301 (fatal-error "option does not support argument: --~a"
303 ((and stop-at-first-non-option
305 (cons found (append (reverse etc) argument-ls)))
307 (loop (- unclumped 1) rest found (cons opt etc)))))))))
309 (define* (getopt-long program-arguments option-desc-list
310 #:key stop-at-first-non-option)
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
317 <option-spec> :: (<name> . <attribute-ls>)
318 <attribute-ls> :: (<attribute> . <attribute-ls>)
320 <attribute> :: <required-attribute>
321 | <arg-required-attribute>
322 | <single-char-attribute>
323 | <predicate-attribute>
325 <required-attribute> :: (required? <boolean>)
326 <single-char-attribute> :: (single-char <char>)
327 <value-attribute> :: (value #t)
330 <predicate-attribute> :: (predicate <1-ary-function>)
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
337 By default, options are not required, and option values are not
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
340 to add a `single-char' clause to the option description."
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)))
344 (split-ls (car pair))
345 (non-split-ls (cdr pair))
346 (found/etc (process-options specifications split-ls
347 stop-at-first-non-option))
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))
352 (val (assq-ref found spec)))
353 (and (option-spec->required? spec)
355 (fatal-error "option must be specified: --~a"
357 (let ((pred (option-spec->predicate spec)))
358 (and pred (pred name val)))))
360 (for-each (lambda (spec+val)
362 (string->symbol (option-spec->name (car spec+val)))))
364 (cons (cons '() rest-ls) found))))
366 (define (option-ref options key default)
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))
371 ;;; getopt-long.scm ends here