bug#42669: [PATCH 1/4] test: augment testing of (ice-9 getopt-long) module

[Dale Mellor]

Adding some 28 new tests which explore some undefined (or at least
implied) behaviour of the module.  These are all non-controversial, and
the existing module passes all of the tests.

* test-suite/tests/getopt-long.test: new code added, some slight
  re-arrangement of existing code but nothing which changes the original
  set of tests.
---
 test-suite/tests/getopt-long.test | 184 +++++++++++++++++++++++++++++-
 1 file changed, 182 insertions(+), 2 deletions(-)

diff --git a/test-suite/tests/getopt-long.test 
b/test-suite/tests/getopt-long.test
index 4ae604883..d66de0e56 100644
--- a/test-suite/tests/getopt-long.test
+++ b/test-suite/tests/getopt-long.test
@@ -1,5 +1,4 @@
 ;;;; getopt-long.test --- long options processing -*- scheme -*-
-;;;; Thien-Thi Nguyen <ttn@gnu.org> --- August 2001
 ;;;;
 ;;;;   Copyright (C) 2001, 2006, 2011 Free Software Foundation, Inc.
 ;;;;
@@ -17,10 +16,17 @@
 ;;;; 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)
@@ -49,6 +55,44 @@
 (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)))
@@ -120,7 +164,12 @@
            (equal? (test3 "prg" "--bar" "--foo")
                    '((()) (foo . #t) (bar . #t))))
 
-  )
+  (pass-if "--="
+           (equal? (test3 "prg" "--=")
+                   '((() "--="))))
+
+ )
+
 
 (with-test-prefix "option-ref"
 
@@ -299,4 +348,135 @@
 
   )
 
+
+
+(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 "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 "non-predicated --mandatory -1"
+    (test "--dave -1" '((()) (dave . "-1"))))
+
+  (pass-if "non-predicated -m -1"
+    (test "-d -1" '((()) (dave . "-1"))))
+
+  )
+
+
+
+(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  "-sd file"
+    (test  "-sd 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
-- 
2.27.0