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