1 ;;;; getopt-long.test --- long options processing -*- scheme -*-
2 ;;;; Thien-Thi Nguyen <ttn@gnu.org> --- August 2001
4 ;;;; Copyright (C) 2001, 2006, 2011 Free Software Foundation, Inc.
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.
11 ;;;; This library 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 GNU
14 ;;;; Lesser General Public License for more details.
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
20 (use-modules (test-suite lib)
24 (define-syntax pass-if-fatal-exception
27 (let ((port (open-output-string)))
28 (with-error-to-port port
36 (let ((output (get-output-string port)))
38 (if (string-match (cdr exn) output)
40 (error "Unexpected output" output)))))))))))))
42 (defmacro deferr (name-frag re)
43 (let ((name (symbol-append 'exception: name-frag)))
44 `(define ,name (cons 'quit ,re))))
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")
52 (with-test-prefix "exported procs"
53 (pass-if "`option-ref' defined" (defined? 'option-ref))
54 (pass-if "`getopt-long' defined" (defined? 'getopt-long)))
56 (with-test-prefix "specifying predicate"
58 (define (test1 . args)
61 (predicate ,(lambda (x)
62 (string-match "^[0-9]+$" x)))))))
65 (equal? (test1 "foo" "bar" "--test=123")
66 '((() "bar") (test . "123"))))
68 (pass-if-fatal-exception "invalid arg"
69 exception:option-predicate-failed
70 (test1 "foo" "bar" "--test=foo"))
72 (pass-if-fatal-exception "option has no arg"
73 exception:option-must-have-arg
74 (test1 "foo" "bar" "--test"))
78 (with-test-prefix "not specifying predicate"
80 (define (test2 . args)
81 (getopt-long args `((test (value #t)))))
83 (pass-if "option has arg"
84 (equal? (test2 "foo" "bar" "--test=foo")
85 '((() "bar") (test . "foo"))))
87 (pass-if "option has no arg"
88 (equal? (test2 "foo" "bar")
93 (with-test-prefix "value optional"
95 (define (test3 . args)
96 (getopt-long args '((foo (value optional) (single-char #\f))
99 (pass-if "long option `foo' w/ arg, long option `bar'"
100 (equal? (test3 "prg" "--foo" "fooval" "--bar")
101 '((()) (bar . #t) (foo . "fooval"))))
103 (pass-if "short option `foo' w/ arg, long option `bar'"
104 (equal? (test3 "prg" "-f" "fooval" "--bar")
105 '((()) (bar . #t) (foo . "fooval"))))
107 (pass-if "short option `foo', long option `bar', no args"
108 (equal? (test3 "prg" "-f" "--bar")
109 '((()) (bar . #t) (foo . #t))))
111 (pass-if "long option `foo', long option `bar', no args"
112 (equal? (test3 "prg" "--foo" "--bar")
113 '((()) (bar . #t) (foo . #t))))
115 (pass-if "long option `bar', short option `foo', no args"
116 (equal? (test3 "prg" "--bar" "-f")
117 '((()) (foo . #t) (bar . #t))))
119 (pass-if "long option `bar', long option `foo', no args"
120 (equal? (test3 "prg" "--bar" "--foo")
121 '((()) (foo . #t) (bar . #t))))
125 (with-test-prefix "option-ref"
127 (define (test4 option-arg . args)
128 (equal? option-arg (option-ref (getopt-long
136 (pass-if "option-ref `--foo 4'"
137 (test4 "4" "--foo" "4"))
139 (pass-if "option-ref `-f 4'"
140 (test4 "4" "-f" "4"))
142 (pass-if "option-ref `-f4'"
145 (pass-if "option-ref `--foo=4'"
146 (test4 "4" "--foo=4"))
150 (with-test-prefix "required"
152 (define (test5 args specs)
153 (getopt-long (cons "foo" args) specs))
155 (pass-if "not mentioned, not given"
156 (equal? (test5 '() '())
159 (pass-if-fatal-exception "not mentioned, given"
160 exception:no-such-option
161 (test5 '("--req") '((something))))
163 (pass-if "not specified required, not given"
164 (equal? (test5 '() '((req (required? #f))))
167 (pass-if "not specified required, given anyway"
168 (equal? (test5 '("--req") '((req (required? #f))))
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"))))
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"))))
179 (pass-if-fatal-exception "specified required, not given"
180 exception:option-must-be-specified
181 (test5 '() '((req (required? #t)))))
185 (with-test-prefix "specified no-value, given anyway"
187 (define (test6 args specs)
188 (getopt-long (cons "foo" args) specs))
190 (pass-if-fatal-exception "using \"=\" syntax"
191 exception:option-does-not-support-arg
192 (test6 '("--maybe=yes") '((maybe))))
196 (with-test-prefix "specified arg required"
199 (getopt-long (cons "foo" args) '((hmm (value #t) (single-char #\H))
202 (pass-if "short opt, arg given"
203 (equal? (test7 '("-H" "99"))
204 '((()) (hmm . "99"))))
206 (pass-if "long non-\"=\" opt, arg given"
207 (equal? (test7 '("--hmm" "100"))
208 '((()) (hmm . "100"))))
210 (pass-if "long \"=\" opt, arg given"
211 (equal? (test7 '("--hmm=101"))
212 '((()) (hmm . "101"))))
214 (pass-if-fatal-exception "short opt, arg not given"
215 exception:option-must-have-arg
218 (pass-if-fatal-exception "long non-\"=\" opt, arg not given (next arg an option)"
219 exception:option-must-have-arg
220 (test7 '("--hmm" "--ignore")))
222 (pass-if-fatal-exception "long \"=\" opt, arg not given"
223 exception:option-must-have-arg
228 (with-test-prefix "apples-blimps-catalexis example"
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))))
236 (cond ((null? (car a)) #t)
238 (else (string<? (symbol->string (car a))
239 (symbol->string (car b)))))))
243 (catalexis . "couth"))))
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"))
249 (pass-if-fatal-exception "bad ordering causes missing option"
250 exception:option-must-have-arg
251 (test8 "-abc" "couth" "bang"))
255 (with-test-prefix "multiple occurrences"
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"))))
264 ;; sf -- single-char free
265 ;; sa -- single-char abutted
267 ;; la -- long abutted (using "=")
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"))
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"))
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"))
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"))
291 (with-test-prefix "stop-at-first-non-option"
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"))))
302 ;;; getopt-long.test ends here