Commit | Line | Data |
---|---|---|
c0c07ee9 | 1 | ;;;; getopt-long.test --- long options processing -*- scheme -*- |
3cc2e575 TTN |
2 | ;;;; Thien-Thi Nguyen <ttn@gnu.org> --- August 2001 |
3 | ;;;; | |
0bc86fce | 4 | ;;;; Copyright (C) 2001, 2006, 2011 Free Software Foundation, Inc. |
3cc2e575 | 5 | ;;;; |
53befeb7 NJ |
6 | ;;;; This library is free software; you can redistribute it and/or |
7 | ;;;; modify it under the terms of the GNU Lesser General Public | |
8 | ;;;; License as published by the Free Software Foundation; either | |
9 | ;;;; version 3 of the License, or (at your option) any later version. | |
10 | ;;;; | |
11 | ;;;; This library is distributed in the hope that it will be useful, | |
3cc2e575 | 12 | ;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of |
53befeb7 NJ |
13 | ;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU |
14 | ;;;; Lesser General Public License for more details. | |
15 | ;;;; | |
16 | ;;;; You should have received a copy of the GNU Lesser General Public | |
17 | ;;;; License along with this library; if not, write to the Free Software | |
18 | ;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA | |
3cc2e575 TTN |
19 | |
20 | (use-modules (test-suite lib) | |
21 | (ice-9 getopt-long) | |
22 | (ice-9 regex)) | |
23 | ||
0bc86fce AW |
24 | (define-syntax pass-if-fatal-exception |
25 | (syntax-rules () | |
26 | ((_ name exn exp) | |
27 | (let ((port (open-output-string))) | |
28 | (with-error-to-port port | |
29 | (lambda () | |
30 | (run-test | |
31 | name #t | |
32 | (lambda () | |
33 | (catch (car exn) | |
34 | (lambda () exp #f) | |
35 | (lambda (k . args) | |
36 | (let ((output (get-output-string port))) | |
37 | (close-port port) | |
38 | (if (string-match (cdr exn) output) | |
39 | #t | |
40 | (error "Unexpected output" output))))))))))))) | |
41 | ||
252422b0 TTN |
42 | (defmacro deferr (name-frag re) |
43 | (let ((name (symbol-append 'exception: name-frag))) | |
0bc86fce | 44 | `(define ,name (cons 'quit ,re)))) |
252422b0 | 45 | |
0bc86fce AW |
46 | (deferr no-such-option "no such option") |
47 | (deferr option-predicate-failed "option predicate failed") | |
48 | (deferr option-does-not-support-arg "option does not support argument") | |
49 | (deferr option-must-be-specified "option must be specified") | |
50 | (deferr option-must-have-arg "option must be specified with argument") | |
252422b0 | 51 | |
252422b0 TTN |
52 | (with-test-prefix "exported procs" |
53 | (pass-if "`option-ref' defined" (defined? 'option-ref)) | |
54 | (pass-if "`getopt-long' defined" (defined? 'getopt-long))) | |
3cc2e575 TTN |
55 | |
56 | (with-test-prefix "specifying predicate" | |
57 | ||
58 | (define (test1 . args) | |
252422b0 TTN |
59 | (getopt-long args |
60 | `((test (value #t) | |
61 | (predicate ,(lambda (x) | |
62 | (string-match "^[0-9]+$" x))))))) | |
3cc2e575 TTN |
63 | |
64 | (pass-if "valid arg" | |
65 | (equal? (test1 "foo" "bar" "--test=123") | |
66 | '((() "bar") (test . "123")))) | |
67 | ||
0bc86fce | 68 | (pass-if-fatal-exception "invalid arg" |
3cc2e575 TTN |
69 | exception:option-predicate-failed |
70 | (test1 "foo" "bar" "--test=foo")) | |
71 | ||
0bc86fce | 72 | (pass-if-fatal-exception "option has no arg" |
c0c07ee9 | 73 | exception:option-must-have-arg |
252422b0 | 74 | (test1 "foo" "bar" "--test")) |
3cc2e575 TTN |
75 | |
76 | ) | |
77 | ||
78 | (with-test-prefix "not specifying predicate" | |
79 | ||
80 | (define (test2 . args) | |
81 | (getopt-long args `((test (value #t))))) | |
82 | ||
83 | (pass-if "option has arg" | |
84 | (equal? (test2 "foo" "bar" "--test=foo") | |
85 | '((() "bar") (test . "foo")))) | |
86 | ||
87 | (pass-if "option has no arg" | |
88 | (equal? (test2 "foo" "bar") | |
89 | '((() "bar")))) | |
90 | ||
91 | ) | |
92 | ||
93 | (with-test-prefix "value optional" | |
94 | ||
95 | (define (test3 . args) | |
96 | (getopt-long args '((foo (value optional) (single-char #\f)) | |
97 | (bar)))) | |
98 | ||
99 | (pass-if "long option `foo' w/ arg, long option `bar'" | |
100 | (equal? (test3 "prg" "--foo" "fooval" "--bar") | |
101 | '((()) (bar . #t) (foo . "fooval")))) | |
102 | ||
103 | (pass-if "short option `foo' w/ arg, long option `bar'" | |
104 | (equal? (test3 "prg" "-f" "fooval" "--bar") | |
105 | '((()) (bar . #t) (foo . "fooval")))) | |
106 | ||
107 | (pass-if "short option `foo', long option `bar', no args" | |
108 | (equal? (test3 "prg" "-f" "--bar") | |
109 | '((()) (bar . #t) (foo . #t)))) | |
110 | ||
111 | (pass-if "long option `foo', long option `bar', no args" | |
112 | (equal? (test3 "prg" "--foo" "--bar") | |
113 | '((()) (bar . #t) (foo . #t)))) | |
114 | ||
115 | (pass-if "long option `bar', short option `foo', no args" | |
116 | (equal? (test3 "prg" "--bar" "-f") | |
117 | '((()) (foo . #t) (bar . #t)))) | |
118 | ||
119 | (pass-if "long option `bar', long option `foo', no args" | |
120 | (equal? (test3 "prg" "--bar" "--foo") | |
121 | '((()) (foo . #t) (bar . #t)))) | |
252422b0 TTN |
122 | |
123 | ) | |
124 | ||
125 | (with-test-prefix "option-ref" | |
126 | ||
127 | (define (test4 option-arg . args) | |
128 | (equal? option-arg (option-ref (getopt-long | |
129 | (cons "prog" args) | |
130 | '((foo | |
131 | (value optional) | |
132 | (single-char #\f)) | |
133 | (bar))) | |
134 | 'foo #f))) | |
135 | ||
136 | (pass-if "option-ref `--foo 4'" | |
137 | (test4 "4" "--foo" "4")) | |
138 | ||
139 | (pass-if "option-ref `-f 4'" | |
140 | (test4 "4" "-f" "4")) | |
141 | ||
c0c07ee9 TTN |
142 | (pass-if "option-ref `-f4'" |
143 | (test4 "4" "-f4")) | |
252422b0 TTN |
144 | |
145 | (pass-if "option-ref `--foo=4'" | |
146 | (test4 "4" "--foo=4")) | |
147 | ||
148 | ) | |
149 | ||
150 | (with-test-prefix "required" | |
151 | ||
152 | (define (test5 args specs) | |
153 | (getopt-long (cons "foo" args) specs)) | |
154 | ||
155 | (pass-if "not mentioned, not given" | |
156 | (equal? (test5 '() '()) | |
157 | '((())))) | |
158 | ||
0bc86fce | 159 | (pass-if-fatal-exception "not mentioned, given" |
c0c07ee9 TTN |
160 | exception:no-such-option |
161 | (test5 '("--req") '((something)))) | |
252422b0 TTN |
162 | |
163 | (pass-if "not specified required, not given" | |
164 | (equal? (test5 '() '((req (required? #f)))) | |
165 | '((())))) | |
166 | ||
167 | (pass-if "not specified required, given anyway" | |
168 | (equal? (test5 '("--req") '((req (required? #f)))) | |
169 | '((()) (req . #t)))) | |
170 | ||
171 | (pass-if "not specified required, but w/ value, given anyway w/ \"=\" val" | |
172 | (equal? (test5 '("--req=7") '((req (required? #f) (value #t)))) | |
173 | '((()) (req . "7")))) | |
174 | ||
175 | (pass-if "not specified required, but w/ value, given anyway w/ non-\"=\" val" | |
176 | (equal? (test5 '("--req" "7") '((req (required? #f) (value #t)))) | |
177 | '((()) (req . "7")))) | |
178 | ||
0bc86fce | 179 | (pass-if-fatal-exception "specified required, not given" |
252422b0 TTN |
180 | exception:option-must-be-specified |
181 | (test5 '() '((req (required? #t))))) | |
182 | ||
183 | ) | |
184 | ||
185 | (with-test-prefix "specified no-value, given anyway" | |
186 | ||
187 | (define (test6 args specs) | |
188 | (getopt-long (cons "foo" args) specs)) | |
189 | ||
0bc86fce | 190 | (pass-if-fatal-exception "using \"=\" syntax" |
c0c07ee9 TTN |
191 | exception:option-does-not-support-arg |
192 | (test6 '("--maybe=yes") '((maybe)))) | |
252422b0 TTN |
193 | |
194 | ) | |
195 | ||
196 | (with-test-prefix "specified arg required" | |
197 | ||
198 | (define (test7 args) | |
199 | (getopt-long (cons "foo" args) '((hmm (value #t) (single-char #\H)) | |
200 | (ignore)))) | |
201 | ||
202 | (pass-if "short opt, arg given" | |
203 | (equal? (test7 '("-H" "99")) | |
204 | '((()) (hmm . "99")))) | |
205 | ||
206 | (pass-if "long non-\"=\" opt, arg given" | |
207 | (equal? (test7 '("--hmm" "100")) | |
208 | '((()) (hmm . "100")))) | |
209 | ||
210 | (pass-if "long \"=\" opt, arg given" | |
211 | (equal? (test7 '("--hmm=101")) | |
212 | '((()) (hmm . "101")))) | |
213 | ||
0bc86fce | 214 | (pass-if-fatal-exception "short opt, arg not given" |
252422b0 TTN |
215 | exception:option-must-have-arg |
216 | (test7 '("-H"))) | |
217 | ||
0bc86fce | 218 | (pass-if-fatal-exception "long non-\"=\" opt, arg not given (next arg an option)" |
c0c07ee9 TTN |
219 | exception:option-must-have-arg |
220 | (test7 '("--hmm" "--ignore"))) | |
252422b0 | 221 | |
0bc86fce | 222 | (pass-if-fatal-exception "long \"=\" opt, arg not given" |
c0c07ee9 TTN |
223 | exception:option-must-have-arg |
224 | (test7 '("--hmm"))) | |
252422b0 | 225 | |
3cc2e575 TTN |
226 | ) |
227 | ||
4b642b08 TTN |
228 | (with-test-prefix "apples-blimps-catalexis example" |
229 | ||
230 | (define (test8 . args) | |
231 | (equal? (sort (getopt-long (cons "foo" args) | |
232 | '((apples (single-char #\a)) | |
233 | (blimps (single-char #\b) (value #t)) | |
234 | (catalexis (single-char #\c) (value #t)))) | |
235 | (lambda (a b) | |
236 | (cond ((null? (car a)) #t) | |
237 | ((null? (car b)) #f) | |
238 | (else (string<? (symbol->string (car a)) | |
239 | (symbol->string (car b))))))) | |
240 | '((()) | |
241 | (apples . #t) | |
242 | (blimps . "bang") | |
243 | (catalexis . "couth")))) | |
244 | ||
245 | (pass-if "normal 1" (test8 "-a" "-b" "bang" "-c" "couth")) | |
246 | (pass-if "normal 2" (test8 "-ab" "bang" "-c" "couth")) | |
247 | (pass-if "normal 3" (test8 "-ac" "couth" "-b" "bang")) | |
248 | ||
0bc86fce | 249 | (pass-if-fatal-exception "bad ordering causes missing option" |
4b642b08 TTN |
250 | exception:option-must-have-arg |
251 | (test8 "-abc" "couth" "bang")) | |
252 | ||
253 | ) | |
254 | ||
ec7ea550 | 255 | (with-test-prefix "multiple occurrences" |
4b642b08 TTN |
256 | |
257 | (define (test9 . args) | |
258 | (equal? (getopt-long (cons "foo" args) | |
259 | '((inc (single-char #\I) (value #t)) | |
260 | (foo (single-char #\f)))) | |
261 | '((()) (inc . "2") (foo . #t) (inc . "1")))) | |
262 | ||
263 | ;; terminology: | |
264 | ;; sf -- single-char free | |
265 | ;; sa -- single-char abutted | |
266 | ;; lf -- long free | |
267 | ;; la -- long abutted (using "=") | |
268 | ||
269 | (pass-if "sf/sf" (test9 "-I" "1" "-f" "-I" "2")) | |
270 | (pass-if "sa/sa" (test9 "-I1" "-f" "-I2")) | |
271 | (pass-if "sf/sa" (test9 "-I" "1" "-f" "-I2")) | |
272 | (pass-if "sa/sf" (test9 "-I1" "-f" "-I" "2")) | |
273 | ||
274 | (pass-if "lf/lf" (test9 "--inc" "1" "-f" "--inc" "2")) | |
275 | (pass-if "la/la" (test9 "--inc=1" "-f" "--inc=2")) | |
276 | (pass-if "lf/la" (test9 "--inc" "1" "-f" "--inc=2")) | |
277 | (pass-if "la/lf" (test9 "--inc=1" "-f" "--inc" "2")) | |
278 | ||
279 | (pass-if "sf/lf" (test9 "-I" "1" "-f" "--inc" "2")) | |
280 | (pass-if "lf/sf" (test9 "--inc" "1" "-f" "-I" "2")) | |
281 | (pass-if "sf/la" (test9 "-I" "1" "-f" "--inc=2")) | |
282 | (pass-if "la/sf" (test9 "--inc=1" "-f" "-I" "2")) | |
283 | ||
284 | (pass-if "sa/lf" (test9 "-I1" "-f" "--inc" "2")) | |
285 | (pass-if "lf/sa" (test9 "--inc" "1" "-f" "-I2")) | |
286 | (pass-if "sa/la" (test9 "-I1" "-f" "--inc=2")) | |
287 | (pass-if "la/sa" (test9 "--inc=1" "-f" "-I2")) | |
288 | ||
289 | ) | |
290 | ||
6b4b4bfb NJ |
291 | (with-test-prefix "stop-at-first-non-option" |
292 | ||
293 | (pass-if "guile-tools compile example" | |
294 | (equal? (getopt-long '("guile-tools" "compile" "-Wformat" "eval.scm" "-o" "eval.go") | |
295 | '((help (single-char #\h)) | |
296 | (version (single-char #\v))) | |
297 | #:stop-at-first-non-option #t) | |
298 | '((() "compile" "-Wformat" "eval.scm" "-o" "eval.go")))) | |
299 | ||
300 | ) | |
301 | ||
3cc2e575 | 302 | ;;; getopt-long.test ends here |