diff options
Diffstat (limited to 'test-suite/tests/getopt-long.test')
-rw-r--r-- | test-suite/tests/getopt-long.test | 302 |
1 files changed, 302 insertions, 0 deletions
diff --git a/test-suite/tests/getopt-long.test b/test-suite/tests/getopt-long.test new file mode 100644 index 000000000..4ae604883 --- /dev/null +++ b/test-suite/tests/getopt-long.test @@ -0,0 +1,302 @@ +;;;; getopt-long.test --- long options processing -*- scheme -*- +;;;; Thien-Thi Nguyen <ttn@gnu.org> --- August 2001 +;;;; +;;;; Copyright (C) 2001, 2006, 2011 Free Software Foundation, Inc. +;;;; +;;;; This library is free software; you can redistribute it and/or +;;;; modify it under the terms of the GNU Lesser General Public +;;;; License as published by the Free Software Foundation; either +;;;; version 3 of the License, or (at your option) any later version. +;;;; +;;;; This library is distributed in the hope that it will be useful, +;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +;;;; Lesser General Public License for more details. +;;;; +;;;; You should have received a copy of the GNU Lesser General Public +;;;; License along with this library; if not, write to the Free Software +;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA + +(use-modules (test-suite lib) + (ice-9 getopt-long) + (ice-9 regex)) + +(define-syntax pass-if-fatal-exception + (syntax-rules () + ((_ name exn exp) + (let ((port (open-output-string))) + (with-error-to-port port + (lambda () + (run-test + name #t + (lambda () + (catch (car exn) + (lambda () exp #f) + (lambda (k . args) + (let ((output (get-output-string port))) + (close-port port) + (if (string-match (cdr exn) output) + #t + (error "Unexpected output" output))))))))))))) + +(defmacro deferr (name-frag re) + (let ((name (symbol-append 'exception: name-frag))) + `(define ,name (cons 'quit ,re)))) + +(deferr no-such-option "no such option") +(deferr option-predicate-failed "option predicate failed") +(deferr option-does-not-support-arg "option does not support argument") +(deferr option-must-be-specified "option must be specified") +(deferr option-must-have-arg "option must be specified with argument") + +(with-test-prefix "exported procs" + (pass-if "`option-ref' defined" (defined? 'option-ref)) + (pass-if "`getopt-long' defined" (defined? 'getopt-long))) + +(with-test-prefix "specifying predicate" + + (define (test1 . args) + (getopt-long args + `((test (value #t) + (predicate ,(lambda (x) + (string-match "^[0-9]+$" x))))))) + + (pass-if "valid arg" + (equal? (test1 "foo" "bar" "--test=123") + '((() "bar") (test . "123")))) + + (pass-if-fatal-exception "invalid arg" + exception:option-predicate-failed + (test1 "foo" "bar" "--test=foo")) + + (pass-if-fatal-exception "option has no arg" + exception:option-must-have-arg + (test1 "foo" "bar" "--test")) + + ) + +(with-test-prefix "not specifying predicate" + + (define (test2 . args) + (getopt-long args `((test (value #t))))) + + (pass-if "option has arg" + (equal? (test2 "foo" "bar" "--test=foo") + '((() "bar") (test . "foo")))) + + (pass-if "option has no arg" + (equal? (test2 "foo" "bar") + '((() "bar")))) + + ) + +(with-test-prefix "value optional" + + (define (test3 . args) + (getopt-long args '((foo (value optional) (single-char #\f)) + (bar)))) + + (pass-if "long option `foo' w/ arg, long option `bar'" + (equal? (test3 "prg" "--foo" "fooval" "--bar") + '((()) (bar . #t) (foo . "fooval")))) + + (pass-if "short option `foo' w/ arg, long option `bar'" + (equal? (test3 "prg" "-f" "fooval" "--bar") + '((()) (bar . #t) (foo . "fooval")))) + + (pass-if "short option `foo', long option `bar', no args" + (equal? (test3 "prg" "-f" "--bar") + '((()) (bar . #t) (foo . #t)))) + + (pass-if "long option `foo', long option `bar', no args" + (equal? (test3 "prg" "--foo" "--bar") + '((()) (bar . #t) (foo . #t)))) + + (pass-if "long option `bar', short option `foo', no args" + (equal? (test3 "prg" "--bar" "-f") + '((()) (foo . #t) (bar . #t)))) + + (pass-if "long option `bar', long option `foo', no args" + (equal? (test3 "prg" "--bar" "--foo") + '((()) (foo . #t) (bar . #t)))) + + ) + +(with-test-prefix "option-ref" + + (define (test4 option-arg . args) + (equal? option-arg (option-ref (getopt-long + (cons "prog" args) + '((foo + (value optional) + (single-char #\f)) + (bar))) + 'foo #f))) + + (pass-if "option-ref `--foo 4'" + (test4 "4" "--foo" "4")) + + (pass-if "option-ref `-f 4'" + (test4 "4" "-f" "4")) + + (pass-if "option-ref `-f4'" + (test4 "4" "-f4")) + + (pass-if "option-ref `--foo=4'" + (test4 "4" "--foo=4")) + + ) + +(with-test-prefix "required" + + (define (test5 args specs) + (getopt-long (cons "foo" args) specs)) + + (pass-if "not mentioned, not given" + (equal? (test5 '() '()) + '((())))) + + (pass-if-fatal-exception "not mentioned, given" + exception:no-such-option + (test5 '("--req") '((something)))) + + (pass-if "not specified required, not given" + (equal? (test5 '() '((req (required? #f)))) + '((())))) + + (pass-if "not specified required, given anyway" + (equal? (test5 '("--req") '((req (required? #f)))) + '((()) (req . #t)))) + + (pass-if "not specified required, but w/ value, given anyway w/ \"=\" val" + (equal? (test5 '("--req=7") '((req (required? #f) (value #t)))) + '((()) (req . "7")))) + + (pass-if "not specified required, but w/ value, given anyway w/ non-\"=\" val" + (equal? (test5 '("--req" "7") '((req (required? #f) (value #t)))) + '((()) (req . "7")))) + + (pass-if-fatal-exception "specified required, not given" + exception:option-must-be-specified + (test5 '() '((req (required? #t))))) + + ) + +(with-test-prefix "specified no-value, given anyway" + + (define (test6 args specs) + (getopt-long (cons "foo" args) specs)) + + (pass-if-fatal-exception "using \"=\" syntax" + exception:option-does-not-support-arg + (test6 '("--maybe=yes") '((maybe)))) + + ) + +(with-test-prefix "specified arg required" + + (define (test7 args) + (getopt-long (cons "foo" args) '((hmm (value #t) (single-char #\H)) + (ignore)))) + + (pass-if "short opt, arg given" + (equal? (test7 '("-H" "99")) + '((()) (hmm . "99")))) + + (pass-if "long non-\"=\" opt, arg given" + (equal? (test7 '("--hmm" "100")) + '((()) (hmm . "100")))) + + (pass-if "long \"=\" opt, arg given" + (equal? (test7 '("--hmm=101")) + '((()) (hmm . "101")))) + + (pass-if-fatal-exception "short opt, arg not given" + exception:option-must-have-arg + (test7 '("-H"))) + + (pass-if-fatal-exception "long non-\"=\" opt, arg not given (next arg an option)" + exception:option-must-have-arg + (test7 '("--hmm" "--ignore"))) + + (pass-if-fatal-exception "long \"=\" opt, arg not given" + exception:option-must-have-arg + (test7 '("--hmm"))) + + ) + +(with-test-prefix "apples-blimps-catalexis example" + + (define (test8 . args) + (equal? (sort (getopt-long (cons "foo" args) + '((apples (single-char #\a)) + (blimps (single-char #\b) (value #t)) + (catalexis (single-char #\c) (value #t)))) + (lambda (a b) + (cond ((null? (car a)) #t) + ((null? (car b)) #f) + (else (string<? (symbol->string (car a)) + (symbol->string (car b))))))) + '((()) + (apples . #t) + (blimps . "bang") + (catalexis . "couth")))) + + (pass-if "normal 1" (test8 "-a" "-b" "bang" "-c" "couth")) + (pass-if "normal 2" (test8 "-ab" "bang" "-c" "couth")) + (pass-if "normal 3" (test8 "-ac" "couth" "-b" "bang")) + + (pass-if-fatal-exception "bad ordering causes missing option" + exception:option-must-have-arg + (test8 "-abc" "couth" "bang")) + + ) + +(with-test-prefix "multiple occurrences" + + (define (test9 . args) + (equal? (getopt-long (cons "foo" args) + '((inc (single-char #\I) (value #t)) + (foo (single-char #\f)))) + '((()) (inc . "2") (foo . #t) (inc . "1")))) + + ;; terminology: + ;; sf -- single-char free + ;; sa -- single-char abutted + ;; lf -- long free + ;; la -- long abutted (using "=") + + (pass-if "sf/sf" (test9 "-I" "1" "-f" "-I" "2")) + (pass-if "sa/sa" (test9 "-I1" "-f" "-I2")) + (pass-if "sf/sa" (test9 "-I" "1" "-f" "-I2")) + (pass-if "sa/sf" (test9 "-I1" "-f" "-I" "2")) + + (pass-if "lf/lf" (test9 "--inc" "1" "-f" "--inc" "2")) + (pass-if "la/la" (test9 "--inc=1" "-f" "--inc=2")) + (pass-if "lf/la" (test9 "--inc" "1" "-f" "--inc=2")) + (pass-if "la/lf" (test9 "--inc=1" "-f" "--inc" "2")) + + (pass-if "sf/lf" (test9 "-I" "1" "-f" "--inc" "2")) + (pass-if "lf/sf" (test9 "--inc" "1" "-f" "-I" "2")) + (pass-if "sf/la" (test9 "-I" "1" "-f" "--inc=2")) + (pass-if "la/sf" (test9 "--inc=1" "-f" "-I" "2")) + + (pass-if "sa/lf" (test9 "-I1" "-f" "--inc" "2")) + (pass-if "lf/sa" (test9 "--inc" "1" "-f" "-I2")) + (pass-if "sa/la" (test9 "-I1" "-f" "--inc=2")) + (pass-if "la/sa" (test9 "--inc=1" "-f" "-I2")) + + ) + +(with-test-prefix "stop-at-first-non-option" + + (pass-if "guile-tools compile example" + (equal? (getopt-long '("guile-tools" "compile" "-Wformat" "eval.scm" "-o" "eval.go") + '((help (single-char #\h)) + (version (single-char #\v))) + #:stop-at-first-non-option #t) + '((() "compile" "-Wformat" "eval.scm" "-o" "eval.go")))) + + ) + +;;; getopt-long.test ends here |