1;;;; getopt-long.test --- long options processing -*- scheme -*-
2;;;; Thien-Thi Nguyen <ttn@gnu.org> --- August 2001
3;;;;
4;;;; 	Copyright (C) 2001, 2006, 2011 Free Software Foundation, Inc.
5;;;;
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,
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.
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
19
20(use-modules (test-suite lib)
21             (ice-9 getopt-long)
22             (ice-9 regex))
23
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
42(defmacro deferr (name-frag re)
43  (let ((name (symbol-append 'exception: name-frag)))
44    `(define ,name (cons 'quit ,re))))
45
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")
51
52(with-test-prefix "exported procs"
53  (pass-if "`option-ref' defined"  (defined? 'option-ref))
54  (pass-if "`getopt-long' defined" (defined? 'getopt-long)))
55
56(with-test-prefix "specifying predicate"
57
58  (define (test1 . args)
59    (getopt-long args
60                 `((test (value #t)
61                         (predicate ,(lambda (x)
62                                       (string-match "^[0-9]+$" x)))))))
63
64  (pass-if "valid arg"
65           (equal? (test1 "foo" "bar" "--test=123")
66                   '((() "bar") (test . "123"))))
67
68  (pass-if-fatal-exception "invalid arg"
69                     exception:option-predicate-failed
70                     (test1 "foo" "bar" "--test=foo"))
71
72  (pass-if-fatal-exception "option has no arg"
73                     exception:option-must-have-arg
74                     (test1 "foo" "bar" "--test"))
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))))
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
142  (pass-if "option-ref `-f4'"
143           (test4 "4" "-f4"))
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
159  (pass-if-fatal-exception "not mentioned, given"
160                     exception:no-such-option
161                     (test5 '("--req") '((something))))
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
179  (pass-if-fatal-exception "specified required, not given"
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
190  (pass-if-fatal-exception "using \"=\" syntax"
191                     exception:option-does-not-support-arg
192                     (test6 '("--maybe=yes") '((maybe))))
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
214  (pass-if-fatal-exception "short opt, arg not given"
215                     exception:option-must-have-arg
216                     (test7 '("-H")))
217
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")))
221
222  (pass-if-fatal-exception "long \"=\" opt, arg not given"
223                     exception:option-must-have-arg
224                     (test7 '("--hmm")))
225
226  )
227
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
249  (pass-if-fatal-exception "bad ordering causes missing option"
250                     exception:option-must-have-arg
251                     (test8 "-abc" "couth" "bang"))
252
253  )
254
255(with-test-prefix "multiple occurrences"
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
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
302;;; getopt-long.test ends here
303