guile18/test-suite/tests/getopt-long.test

   1 ;;;; getopt-long.test --- long options processing -*- scheme -*-
   2 ;;;; Thien-Thi Nguyen <ttn@gnu.org> --- August 2001
   3 ;;;;
   4 ;;;;    Copyright (C) 2001, 2006 Free Software Foundation, Inc.
   5 ;;;;
   6 ;;;; This program is free software; you can redistribute it and/or modify
   7 ;;;; it under the terms of the GNU General Public License as published by
   8 ;;;; the Free Software Foundation; either version 2, or (at your option)
   9 ;;;; any later version.
  10 ;;;;
  11 ;;;; This program 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
  14 ;;;; GNU General Public License for more details.
  15 ;;;;
  16 ;;;; You should have received a copy of the GNU General Public License
  17 ;;;; along with this software; see the file COPYING.  If not, write to
  18 ;;;; the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
  19 ;;;; Boston, MA 02110-1301 USA
  20
  21 (use-modules (test-suite lib)
  22              (ice-9 getopt-long)
  23              (ice-9 regex))
  24
  25 (defmacro deferr (name-frag re)
  26   (let ((name (symbol-append 'exception: name-frag)))
  27     `(define ,name (cons 'misc-error ,re))))
  28
  29 (deferr no-such-option              "^no such option")
  30 (deferr option-predicate-failed     "^option predicate failed")
  31 (deferr option-does-not-support-arg "^option does not support argument")
  32 (deferr option-must-be-specified    "^option must be specified")
  33 (deferr option-must-have-arg        "^option must be specified with argument")
  34
  35 (with-test-prefix "exported procs"
  36   (pass-if "`option-ref' defined"  (defined? 'option-ref))
  37   (pass-if "`getopt-long' defined" (defined? 'getopt-long)))
  38
  39 (with-test-prefix "specifying predicate"
  40
  41   (define (test1 . args)
  42     (getopt-long args
  43                  `((test (value #t)
  44                          (predicate ,(lambda (x)
  45                                        (string-match "^[0-9]+$" x)))))))
  46
  47   (pass-if "valid arg"
  48            (equal? (test1 "foo" "bar" "--test=123")
  49                    '((() "bar") (test . "123"))))
  50
  51   (pass-if-exception "invalid arg"
  52                      exception:option-predicate-failed
  53                      (test1 "foo" "bar" "--test=foo"))
  54
  55   (pass-if-exception "option has no arg"
  56                      exception:option-must-have-arg
  57                      (test1 "foo" "bar" "--test"))
  58
  59   )
  60
  61 (with-test-prefix "not specifying predicate"
  62
  63   (define (test2 . args)
  64     (getopt-long args `((test (value #t)))))
  65
  66   (pass-if "option has arg"
  67            (equal? (test2 "foo" "bar" "--test=foo")
  68                    '((() "bar") (test . "foo"))))
  69
  70   (pass-if "option has no arg"
  71            (equal? (test2 "foo" "bar")
  72                    '((() "bar"))))
  73
  74   )
  75
  76 (with-test-prefix "value optional"
  77
  78   (define (test3 . args)
  79     (getopt-long args '((foo (value optional) (single-char #\f))
  80                         (bar))))
  81
  82   (pass-if "long option `foo' w/ arg, long option `bar'"
  83            (equal? (test3 "prg" "--foo" "fooval" "--bar")
  84                    '((()) (bar . #t) (foo . "fooval"))))
  85
  86   (pass-if "short option `foo' w/ arg, long option `bar'"
  87            (equal? (test3 "prg" "-f" "fooval" "--bar")
  88                    '((()) (bar . #t) (foo . "fooval"))))
  89
  90   (pass-if "short option `foo', long option `bar', no args"
  91            (equal? (test3 "prg" "-f" "--bar")
  92                    '((()) (bar . #t) (foo . #t))))
  93
  94   (pass-if "long option `foo', long option `bar', no args"
  95            (equal? (test3 "prg" "--foo" "--bar")
  96                    '((()) (bar . #t) (foo . #t))))
  97
  98   (pass-if "long option `bar', short option `foo', no args"
  99            (equal? (test3 "prg" "--bar" "-f")
 100                    '((()) (foo . #t) (bar . #t))))
 101
 102   (pass-if "long option `bar', long option `foo', no args"
 103            (equal? (test3 "prg" "--bar" "--foo")
 104                    '((()) (foo . #t) (bar . #t))))
 105
 106   )
 107
 108 (with-test-prefix "option-ref"
 109
 110   (define (test4 option-arg . args)
 111     (equal? option-arg (option-ref (getopt-long
 112                                     (cons "prog" args)
 113                                     '((foo
 114                                        (value optional)
 115                                        (single-char #\f))
 116                                       (bar)))
 117                                    'foo #f)))
 118
 119   (pass-if "option-ref `--foo 4'"
 120            (test4 "4" "--foo" "4"))
 121
 122   (pass-if "option-ref `-f 4'"
 123            (test4 "4" "-f" "4"))
 124
 125   (pass-if "option-ref `-f4'"
 126            (test4 "4" "-f4"))
 127
 128   (pass-if "option-ref `--foo=4'"
 129            (test4 "4" "--foo=4"))
 130
 131   )
 132
 133 (with-test-prefix "required"
 134
 135   (define (test5 args specs)
 136     (getopt-long (cons "foo" args) specs))
 137
 138   (pass-if "not mentioned, not given"
 139            (equal? (test5 '() '())
 140                    '((()))))
 141
 142   (pass-if-exception "not mentioned, given"
 143                      exception:no-such-option
 144                      (test5 '("--req") '((something))))
 145
 146   (pass-if "not specified required, not given"
 147            (equal? (test5 '() '((req (required? #f))))
 148                    '((()))))
 149
 150   (pass-if "not specified required, given anyway"
 151            (equal? (test5 '("--req") '((req (required? #f))))
 152                    '((()) (req . #t))))
 153
 154   (pass-if "not specified required, but w/ value, given anyway w/ \"=\" val"
 155            (equal? (test5 '("--req=7") '((req (required? #f) (value #t))))
 156                    '((()) (req . "7"))))
 157
 158   (pass-if "not specified required, but w/ value, given anyway w/ non-\"=\" val"
 159            (equal? (test5 '("--req" "7") '((req (required? #f) (value #t))))
 160                    '((()) (req . "7"))))
 161
 162   (pass-if-exception "specified required, not given"
 163                      exception:option-must-be-specified
 164                      (test5 '() '((req (required? #t)))))
 165
 166   )
 167
 168 (with-test-prefix "specified no-value, given anyway"
 169
 170   (define (test6 args specs)
 171     (getopt-long (cons "foo" args) specs))
 172
 173   (pass-if-exception "using \"=\" syntax"
 174                      exception:option-does-not-support-arg
 175                      (test6 '("--maybe=yes") '((maybe))))
 176
 177   )
 178
 179 (with-test-prefix "specified arg required"
 180
 181   (define (test7 args)
 182     (getopt-long (cons "foo" args) '((hmm (value #t) (single-char #\H))
 183                                      (ignore))))
 184
 185   (pass-if "short opt, arg given"
 186            (equal? (test7 '("-H" "99"))
 187                    '((()) (hmm . "99"))))
 188
 189   (pass-if "long non-\"=\" opt, arg given"
 190            (equal? (test7 '("--hmm" "100"))
 191                    '((()) (hmm . "100"))))
 192
 193   (pass-if "long \"=\" opt, arg given"
 194            (equal? (test7 '("--hmm=101"))
 195                    '((()) (hmm . "101"))))
 196
 197   (pass-if-exception "short opt, arg not given"
 198                      exception:option-must-have-arg
 199                      (test7 '("-H")))
 200
 201   (pass-if-exception "long non-\"=\" opt, arg not given (next arg an option)"
 202                      exception:option-must-have-arg
 203                      (test7 '("--hmm" "--ignore")))
 204
 205   (pass-if-exception "long \"=\" opt, arg not given"
 206                      exception:option-must-have-arg
 207                      (test7 '("--hmm")))
 208
 209   )
 210
 211 (with-test-prefix "apples-blimps-catalexis example"
 212
 213   (define (test8 . args)
 214     (equal? (sort (getopt-long (cons "foo" args)
 215                                '((apples    (single-char #\a))
 216                                  (blimps    (single-char #\b) (value #t))
 217                                  (catalexis (single-char #\c) (value #t))))
 218                   (lambda (a b)
 219                     (cond ((null? (car a)) #t)
 220                           ((null? (car b)) #f)
 221                           (else (string<? (symbol->string (car a))
 222                                           (symbol->string (car b)))))))
 223             '((())
 224               (apples . #t)
 225               (blimps . "bang")
 226               (catalexis . "couth"))))
 227
 228   (pass-if "normal 1" (test8 "-a" "-b" "bang" "-c" "couth"))
 229   (pass-if "normal 2" (test8 "-ab" "bang" "-c" "couth"))
 230   (pass-if "normal 3" (test8 "-ac" "couth" "-b" "bang"))
 231
 232   (pass-if-exception "bad ordering causes missing option"
 233                      exception:option-must-have-arg
 234                      (test8 "-abc" "couth" "bang"))
 235
 236   )
 237
 238 (with-test-prefix "multiple occurrances"
 239
 240   (define (test9 . args)
 241     (equal? (getopt-long (cons "foo" args)
 242                          '((inc (single-char #\I) (value #t))
 243                            (foo (single-char #\f))))
 244             '((()) (inc . "2") (foo . #t) (inc . "1"))))
 245
 246   ;; terminology:
 247   ;; sf -- single-char free
 248   ;; sa -- single-char abutted
 249   ;; lf -- long free
 250   ;; la -- long abutted (using "=")
 251
 252   (pass-if "sf/sf" (test9 "-I" "1" "-f" "-I" "2"))
 253   (pass-if "sa/sa" (test9 "-I1" "-f" "-I2"))
 254   (pass-if "sf/sa" (test9 "-I" "1" "-f" "-I2"))
 255   (pass-if "sa/sf" (test9 "-I1" "-f" "-I" "2"))
 256
 257   (pass-if "lf/lf" (test9 "--inc" "1" "-f" "--inc" "2"))
 258   (pass-if "la/la" (test9 "--inc=1" "-f" "--inc=2"))
 259   (pass-if "lf/la" (test9 "--inc" "1" "-f" "--inc=2"))
 260   (pass-if "la/lf" (test9 "--inc=1" "-f" "--inc" "2"))
 261
 262   (pass-if "sf/lf" (test9 "-I" "1" "-f" "--inc" "2"))
 263   (pass-if "lf/sf" (test9 "--inc" "1" "-f" "-I" "2"))
 264   (pass-if "sf/la" (test9 "-I" "1" "-f" "--inc=2"))
 265   (pass-if "la/sf" (test9 "--inc=1" "-f" "-I" "2"))
 266
 267   (pass-if "sa/lf" (test9 "-I1" "-f" "--inc" "2"))
 268   (pass-if "lf/sa" (test9 "--inc" "1" "-f" "-I2"))
 269   (pass-if "sa/la" (test9 "-I1" "-f" "--inc=2"))
 270   (pass-if "la/sa" (test9 "--inc=1" "-f" "-I2"))
 271
 272   )
 273
 274 ;;; getopt-long.test ends here