565 lines
20 KiB
Scheme
565 lines
20 KiB
Scheme
;;;; 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 <guile-qf1qmg@rdmp.org> --- April 2020
|
||
|
||
|
||
(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")
|
||
|
||
|
||
|
||
(define (symbol/>string a)
|
||
(if (symbol? a) (symbol->string a) ""))
|
||
|
||
(define (output-sort out)
|
||
(sort out (lambda (a b) (string<? (symbol/>string (car a))
|
||
(symbol/>string (car b))))))
|
||
|
||
(define* (A-TEST args option-specs expectation
|
||
#:key stop-at-first-non-option)
|
||
(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))))
|
||
|
||
|
||
|
||
(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 (test args expect)
|
||
(A-TEST args
|
||
'((foo (value optional) (single-char #\f))
|
||
(bar))
|
||
expect))
|
||
|
||
(pass-if "long option ‘foo’ w/ arg, long option ‘bar’"
|
||
(test "--foo fooval --bar"
|
||
'((()) (bar . #t) (foo . "fooval"))))
|
||
|
||
(pass-if "short option ‘foo’ w/ arg, long option ‘bar’"
|
||
(test "-f fooval --bar"
|
||
'((()) (bar . #t) (foo . "fooval"))))
|
||
|
||
(pass-if "short option ‘foo’, long option ‘bar’, no args"
|
||
(test "-f --bar"
|
||
'((()) (bar . #t) (foo . #t))))
|
||
|
||
(pass-if "long option ‘foo’, long option ‘bar’, no args"
|
||
(test "--foo --bar"
|
||
'((()) (bar . #t) (foo . #t))))
|
||
|
||
(pass-if "long option ‘bar’, short option ‘foo’, no args"
|
||
(test "--bar -f"
|
||
'((()) (foo . #t) (bar . #t))))
|
||
|
||
(pass-if "long option ‘bar’, long option ‘foo’, no args"
|
||
(test "--bar --foo"
|
||
'((()) (foo . #t) (bar . #t))))
|
||
|
||
(pass-if "long option with equals and space"
|
||
(test "--foo= test"
|
||
'((() "test") (foo . #t))))
|
||
|
||
(pass-if "long option with equals and space, not allowed a value"
|
||
(A-TEST "--foo= test"
|
||
'((foo (value #f)))
|
||
'((() "test") (foo . #t))))
|
||
|
||
(pass-if "--="
|
||
(test "--="
|
||
'((() "--="))))
|
||
|
||
)
|
||
|
||
(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 spec '((apples (single-char #\a))
|
||
(blimps (single-char #\b) (value #t))
|
||
(catalexis (single-char #\c) (value #t))))
|
||
|
||
(define (test8 . args)
|
||
(equal? (sort (getopt-long (cons "foo" args) spec)
|
||
(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"
|
||
spec
|
||
'((() "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-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 -m-1"
|
||
(test "-d-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
|