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

;;;; 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