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