[bpt/guile.git] / test-suite / tests / getopt-long.test

;;;; 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
Commit	Line	Data
c0c07ee9	1	;;;; getopt-long.test --- long options processing -- scheme --
3cc2e575 TTN	2	;;;; Thien-Thi Nguyen <ttn@gnu.org> --- August 2001
3cc2e575 TTN	3	;;;;
0bc86fce	4	;;;; Copyright (C) 2001, 2006, 2011 Free Software Foundation, Inc.
3cc2e575	5	;;;;
53befeb7 NJ	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,
3cc2e575	12	;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
53befeb7 NJ	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
3cc2e575 TTN	19
	20	(use-modules (test-suite lib)
	21	(ice-9 getopt-long)
	22	(ice-9 regex))
	23
0bc86fce AW	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
252422b0 TTN	42	(defmacro deferr (name-frag re)
252422b0 TTN	43	(let ((name (symbol-append 'exception: name-frag)))
0bc86fce	44	`(define ,name (cons 'quit ,re))))
252422b0	45
0bc86fce AW	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")
252422b0	51
252422b0 TTN	52	(with-test-prefix "exported procs"
	53	(pass-if "`option-ref' defined" (defined? 'option-ref))
	54	(pass-if "`getopt-long' defined" (defined? 'getopt-long)))
3cc2e575 TTN	55
	56	(with-test-prefix "specifying predicate"
	57
	58	(define (test1 . args)
252422b0 TTN	59	(getopt-long args
	60	`((test (value #t)
	61	(predicate ,(lambda (x)
	62	(string-match "^[0-9]+$" x)))))))
3cc2e575 TTN	63
	64	(pass-if "valid arg"
	65	(equal? (test1 "foo" "bar" "--test=123")
	66	'((() "bar") (test . "123"))))
	67
0bc86fce	68	(pass-if-fatal-exception "invalid arg"
3cc2e575 TTN	69	exception:option-predicate-failed
	70	(test1 "foo" "bar" "--test=foo"))
	71
0bc86fce	72	(pass-if-fatal-exception "option has no arg"
c0c07ee9	73	exception:option-must-have-arg
252422b0	74	(test1 "foo" "bar" "--test"))
3cc2e575 TTN	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))))
252422b0 TTN	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
c0c07ee9 TTN	142	(pass-if "option-ref `-f4'"
c0c07ee9 TTN	143	(test4 "4" "-f4"))
252422b0 TTN	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
0bc86fce	159	(pass-if-fatal-exception "not mentioned, given"
c0c07ee9 TTN	160	exception:no-such-option
c0c07ee9 TTN	161	(test5 '("--req") '((something))))
252422b0 TTN	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
0bc86fce	179	(pass-if-fatal-exception "specified required, not given"
252422b0 TTN	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
0bc86fce	190	(pass-if-fatal-exception "using \"=\" syntax"
c0c07ee9 TTN	191	exception:option-does-not-support-arg
c0c07ee9 TTN	192	(test6 '("--maybe=yes") '((maybe))))
252422b0 TTN	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
0bc86fce	214	(pass-if-fatal-exception "short opt, arg not given"
252422b0 TTN	215	exception:option-must-have-arg
	216	(test7 '("-H")))
	217
0bc86fce	218	(pass-if-fatal-exception "long non-\"=\" opt, arg not given (next arg an option)"
c0c07ee9 TTN	219	exception:option-must-have-arg
c0c07ee9 TTN	220	(test7 '("--hmm" "--ignore")))
252422b0	221
0bc86fce	222	(pass-if-fatal-exception "long \"=\" opt, arg not given"
c0c07ee9 TTN	223	exception:option-must-have-arg
c0c07ee9 TTN	224	(test7 '("--hmm")))
252422b0	225
3cc2e575 TTN	226	)
3cc2e575 TTN	227
4b642b08 TTN	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
0bc86fce	249	(pass-if-fatal-exception "bad ordering causes missing option"
4b642b08 TTN	250	exception:option-must-have-arg
	251	(test8 "-abc" "couth" "bang"))
	252
	253	)
	254
ec7ea550	255	(with-test-prefix "multiple occurrences"
4b642b08 TTN	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
6b4b4bfb NJ	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
3cc2e575	302	;;; getopt-long.test ends here