dmbcs/guile
1
0
Fork 0
Code Issues Pull requests Projects Releases Packages Wiki Activity Actions
guile/test-suite/tests/getopt-long.test
Dale Mellor ee915392f3 test *broken*: augmented tests of (ice-9 getopt-long) 
This is to prepare the ground for some test-driven development mainly to
make the module satisfy the needs of the GNU Mcron project.  The main
requirement is for the module to be more intelligent when dealing with
optional values to command-line options: if the following argument looks
like a new option then treat it as such, otherwise treat it as the value
of the current option.  The particular case is mcronʼs -s option which
needs to assume a default value of “8” if there is not one on the
command line, but currently ‘mcron -s input_file’ fails badly.

Other tests introduced involve allowing negative numbers as option
values, and dealing with various cases of option-processing termination.

* test-suite/tests/getopt-long.test: new code added.
2020-07-22 20:00:09 +01:00

586 lines
20 KiB
Scheme
Raw Blame History

This file contains ambiguous Unicode characters

This file contains Unicode characters that might be confused with other characters. If you think that this is intentional, you can safely ignore this warning. Use the Escape button to reveal them.

;;;; getopt-long.test --- long options processing -*- scheme -*-
;;;;
;;;; 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
;;; Author: Thien-Thi Nguyen <ttn@gnu.org> --- August 2001
;;; Dale Mellor --- April 2020
(use-modules (test-suite lib)
(ice-9 getopt-long)
(ice-9 regex))
;;******** Test infrastructure *********************
(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")
;;************* Newer test infrastructure ***********************
;; Many tests here are somewhat flakey as they depend on a precise
;; internal representation of the options analysis, which isn't really
;; defined or necessary. In the newer tests below we sort that
;; structure into alphabetical order, so we know exactly in advance how
;; to specify the expected results. We also make the test inputs
;; strings of command-line options, rather than lists, as these are
;; clearer and easier for us and closer to the real world.
(define* (A-TEST args option-specs expectation
#:key stop-at-first-non-option)
(define (symbol/>string a)
(if (symbol? a) (symbol->string a) ""))
(define (output-sort out)
(sort out (λ (a b) (string<? (symbol/>string (car a))
(symbol/>string (car b))))))
(let ((answer
(output-sort
(getopt-long
(cons "foo" (string-split args #\space))
option-specs
#:stop-at-first-non-option stop-at-first-non-option))))
(cond ((equal? answer (output-sort expectation)) #t)
(else (format (current-output-port)
"Test result was \n‘~s’ --VS-- \n‘~s’.\n"
answer (output-sort expectation))
#f))))
;;************ The tests ******************************
(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))))
(pass-if "long option with equals and space"
(equal? (test3 "prg" "--foo=" "test")
'((() "test") (foo . #t))))
(pass-if "long option with equals and space, not allowed a value"
(equal? (test3 "prg" "--foo=" "test")
'((() "test") (foo . #t))))
(pass-if "--="
(equal? (test3 "prg" "--=")
'((() "--="))))
)
(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"))
;;;; Dale Mellor 2020-04-14
;;;;
;;;; I disagree with this test: to my mind 'c' is 'b's argument, and
;;;; the other two arguments are non-options which get passed
;;;; through; there should not be an exception.
;; (pass-if-fatal-exception "bad ordering causes missing option"
;; exception:option-must-have-arg
;; (test8 "-abc" "couth" "bang"))
(pass-if "clumped options with trailing mandatory value"
(A-TEST "-abc couth bang"
'((apples (single-char #\a))
(blimps (single-char #\b) (value #t))
(catalexis (single-char #\c) (value #t)))
'((() "couth" "bang") (apples . #t) (blimps . "c"))))
(pass-if "clumped options with trailing optional value"
(A-TEST "-abc couth bang"
'((apples (single-char #\a))
(blimps (single-char #\b)
(value optional)))
'((() "couth" "bang") (apples . #t) (blimps . "c"))))
(pass-if "clumped options with trailing optional value"
(A-TEST "-abc couth bang"
'((apples (single-char #\a))
(blimps (single-char #\b)
(value optional))
(catalexis (single-char #\c)
(value #t)))
'((() "bang")
(apples . #t) (blimps . #t) (catalexis . "couth"))))
)
(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"))))
(pass-if "stop after option"
(equal? (getopt-long '("foo" "-a" "3" "4" "-b" "4")
'((about (single-char #\a) (value #t))
(breathe (single-char #\b) (value #t)))
#:stop-at-first-non-option #t)
'((() "4" "-b" "4") (about . "3"))))
)
(with-test-prefix "stop at end-of-options marker"
(define* (test args expectation #:key stop-at-first-non-option)
(A-TEST args
'((abby) (ben) (charles))
expectation
#:stop-at-first-non-option stop-at-first-non-option))
(pass-if "stop at start" (test "-- --abby" '((() "--abby"))))
(pass-if "stop in middle" (test "--abby dave -- --ben"
'((() "dave" "--ben") (abby . #t))))
(pass-if "stop at end" (test "--abby dave --ben --"
'((() "dave") (abby . #t) (ben . #t))))
(pass-if "marker before first non-option"
(test "--abby -- --ben dave --charles"
'((() "--ben" "dave" "--charles") (abby . #t))
#:stop-at-first-non-option #t))
(pass-if "first non-option before marker"
(test "--abby dave --ben -- --charles"
'((() "dave" "--ben" "--" "--charles") (abby . #t))
#:stop-at-first-non-option #t))
(pass-if "double end marker"
(test "--abby -- -- --ben"
'((() "--" "--ben") (abby . #t))))
(pass-if "separated double end markers"
(test "--abby dave -- --ben -- --charles"
'((() "dave" "--ben" "--" "--charles")
(abby . #t))))
)
(with-test-prefix "negative numbers for option values"
(define (test args expectation)
(A-TEST args
`((arthur (single-char #\a) (value optional)
(predicate ,string->number))
(beth (single-char #\b) (value #t)
(predicate ,string->number))
(charles (single-char #\c) (value optional))
(dave (single-char #\d) (value #t)))
expectation))
(pass-if "predicated --optional=-1"
(test "--arthur=-1" '((()) (arthur . "-1"))))
(pass-if "predicated -o-1"
(test "-a-1" '((()) (arthur . "-1"))))
(pass-if "predicated --optional -1"
(test "--arthur -1" '((()) (arthur . "-1"))))
(pass-if "predicated -o -1"
(test "-a -1" '((()) (arthur . "-1"))))
(pass-if "predicated --mandatory=-1"
(test "--beth=-1" '((()) (beth . "-1"))))
(pass-if "predicated -m-1"
(test "-b-1" '((()) (beth . "-1"))))
(pass-if "predicated --mandatory -1"
(test "--beth -1" '((()) (beth . "-1"))))
(pass-if "predicated -m -1"
(test "-b -1" '((()) (beth . "-1"))))
(pass-if "non-predicated --optional=-1"
(test "--charles=-1" '((()) (charles . "-1"))))
(pass-if "non-predicated -o-1"
(test "-c-1" '((()) (charles . "-1"))))
(pass-if "non-predicated --mandatory=-1"
(test "--dave=-1" '((()) (dave . "-1"))))
(pass-if "non-predicated -m-1"
(test "-d-1" '((()) (dave . "-1"))))
(pass-if-fatal-exception "non-predicated --optional -1"
exception:no-such-option
(test "--charles -1" '((()) (charles . "-1"))))
(pass-if-fatal-exception "non-predicated -o -1"
exception:no-such-option
(test "-c -1" '((()) (charles . "-1"))))
(pass-if "non-predicated --mandatory=-1"
(test "--dave=-1" '((()) (dave . "-1"))))
(pass-if "non-predicated --mandatory -1"
(test "--dave -1" '((()) (dave . "-1"))))
(pass-if "non-predicated -m -1"
(test "-d -1" '((()) (dave . "-1"))))
)
(with-test-prefix "negative numbers as short options"
(define (test args expectation)
(A-TEST args
`((zero (single-char #\0) (value #f))
(one (single-char #\1) (value #t)
(predicate ,string->number))
(two (single-char #\2) (value optional)
(predicate ,string->number))
(three (single-char #\3) (value #t)
(predicate ,(λ (in) (not (string->number in)))))
(four (single-char #\4) (value optional)
(predicate ,(λ (in) (not (string->number in)))))
)
expectation))
(pass-if "-0 -2" (test "-0 -2" '((()) (zero . #t) (two . #t))))
(pass-if "-1 -2" (test "-1 -2" '((()) (one . "-2"))))
(pass-if "-2 -3" (test "-2 -3" '((()) (two . "-3"))))
(pass-if "-0 -4 test" (test "-0 -4 test"
'((()) (zero . #t) (four . "test"))))
(pass-if "-4 -2" (test "-4 -2" '((()) (four . #t) (two . #t))))
(pass-if-fatal-exception "-4 -3" exception:option-must-have-arg
(test "-4 -3" '((()))))
(pass-if "-3a" (test "-3a" '((()) (three . "a"))))
(pass-if "-13" (test "-13" '((()) (one . "3"))))
(pass-if "-03a" (test "-03a" '((()) (zero . #t) (three . "a"))))
(pass-if "-023" (test "-023" '((()) (zero . #t) (two . "3"))))
(pass-if "-025" (test "-025" '((()) (zero . #t) (two . "5"))))
(pass-if-fatal-exception "-025a" exception:no-such-option
(test "-025a" '((()) (zero . #t) (two . "5"))))
(pass-if "-02 a" (test "-02 a" '((() "a") (zero . #t) (two . #t))))
(pass-if-fatal-exception "-02a" exception:no-such-option
(test "-02a" '((()))))
)
(with-test-prefix "mcron backwards compatibility"
(define (test args expectation)
(A-TEST args
`((daemon (single-char #\d) (value #f))
(stdin (single-char #\i) (value #t)
(predicate ,(λ (in) (or (string=? in "guile")
(string=? in "vixie")))))
(schedule (single-char #\s) (value optional)
(predicate ,(λ (in) (or (eq? in #t)
(and (string? in)
(string->number in))))))
(help (single-char #\?))
(version (single-char #\V)))
expectation))
(pass-if "-s8" (test "-s8 file" '((() "file") (schedule . "8"))))
(pass-if "-s 8" (test "-s 8 file" '((() "file") (schedule . "8"))))
(pass-if "-s file"
(test "-s file" '((() "file") (schedule . #t))))
(pass-if "-sd file"
(test "-sd file" '((() "file") (daemon . #t) (schedule . #t))))
(pass-if "-ds file"
(test "-ds file" '((() "file") (daemon . #t) (schedule . #t))))
(pass-if "--schedule=8" (test "--schedule=8 file"
'((() "file") (schedule . "8"))))
(pass-if "--schedule 8" (test "--schedule 8 file"
'((() "file") (schedule . "8"))))
(pass-if "-ds8" (test "-ds8 file"
'((() "file") (daemon . #t) (schedule . "8"))))
(pass-if "-ds 8" (test "-ds 8 file"
'((() "file") (daemon . #t) (schedule . "8"))))
)
;;; getopt-long.test ends here
Reference in a new issue View git blame Copy permalink