| 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 |