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

Previous Next

Package: guile;

Reported by: Dale Mellor <guile-qf1qmg <at> rdmp.org>

Date: Sun, 19 Apr 2020 19:02:03 UTC

Severity: normal

Tags: patch

Merged with 40719, 40720, 40722, 40723

Done: Dale Mellor <guile-qf1qmg <at> rdmp.org>

Bug is archived. No further changes may be made.

To add a comment to this bug, you must first unarchive it, by sending
a message to control AT debbugs.gnu.org, with unarchive 40721 in the body.
You can then email your comments to 40721 AT debbugs.gnu.org in the normal way.

Toggle the display of automated, internal messages from the tracker.

View this report as an mbox folder, status mbox, maintainer mbox


Report forwarded to bug-guile <at> gnu.org:
bug#40721; Package guile. (Sun, 19 Apr 2020 19:02:03 GMT) Full text and rfc822 format available.

Acknowledgement sent to Dale Mellor <guile-qf1qmg <at> rdmp.org>:
New bug report received and forwarded. Copy sent to bug-guile <at> gnu.org. (Sun, 19 Apr 2020 19:02:03 GMT) Full text and rfc822 format available.

Message #5 received at submit <at> debbugs.gnu.org (full text, mbox):

From: Dale Mellor <guile-qf1qmg <at> rdmp.org>
To: bug-guile <at> gnu.org
Subject: [PATCH 1/4] test: augment testing of (ice-9 getopt-long) module
Date: Sun, 19 Apr 2020 18:47:30 +0100
From b08d1cc7dc03d5e69dfd1f93e50617b81230b5e3 Mon Sep 17 00:00:00 2001
From: Dale Mellor <guile-qf1qmg <at> rdmp.org>
Date: Sun, 19 Apr 2020 18:00:04 +0100
Subject: [PATCH 1/4] test: augment testing of (ice-9 getopt-long) module

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 | 214 ++++++++++++++++++++++++++----
 1 file changed, 188 insertions(+), 26 deletions(-)

diff --git a/test-suite/tests/getopt-long.test b/test-suite/tests/getopt-long.test
index 4ae604883..a837b0799 100644
--- a/test-suite/tests/getopt-long.test
+++ b/test-suite/tests/getopt-long.test
@@ -1,7 +1,6 @@
 ;;;; getopt-long.test --- long options processing -*- scheme -*-
-;;;; Thien-Thi Nguyen <ttn <at> gnu.org> --- August 2001
 ;;;;
-;;;; 	Copyright (C) 2001, 2006, 2011 Free Software Foundation, Inc.
+;;;;	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
@@ -17,6 +16,10 @@
 ;;;; 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 <at> gnu.org> --- August 2001
+;;;          Dale Mellor <> --- April 2020
+
+
 (use-modules (test-suite lib)
              (ice-9 getopt-long)
              (ice-9 regex))
@@ -49,6 +52,31 @@
 (deferr option-must-be-specified    "option must be specified")
 (deferr option-must-have-arg        "option must be specified with argument")
 
+
+
+(define  (symbol/>string a)
+  (if (symbol? a) (symbol->string a) ""))
+
+(define (output-sort out)
+  (sort out (lambda (a b) (string<? (symbol/>string (car a))
+                                    (symbol/>string (car b))))))
+
+(define*  (A-TEST  args  option-specs  expectation
+                   #:key  stop-at-first-non-option)
+  (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))))
+
+
+
 (with-test-prefix "exported procs"
   (pass-if "`option-ref' defined"  (defined? 'option-ref))
   (pass-if "`getopt-long' defined" (defined? 'getopt-long)))
@@ -92,33 +120,39 @@
 
 (with-test-prefix "value optional"
 
-  (define (test3 . args)
-    (getopt-long args '((foo (value optional) (single-char #\f))
-                        (bar))))
+  (define (test args expect)
+    (A-TEST  args
+             '((foo (value optional) (single-char #\f))
+               (bar))
+             expect))
+
+  (pass-if "long option ‘foo’ w/ arg, long option ‘bar’"
+           (test "--foo fooval --bar"
+                 '((()) (bar . #t) (foo . "fooval"))))
 
-  (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’"
+           (test "-f 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"
+           (test "-f --bar"
+                 '((()) (bar . #t) (foo . #t))))
 
-  (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"
+           (test "--foo --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"
+           (test "--bar -f"
+                 '((()) (foo . #t) (bar . #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"
+           (test "--bar --foo"
+                 '((()) (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 "--="
+           (test "--="
+                 '((() "--="))))
 
   )
 
@@ -227,11 +261,12 @@
 
 (with-test-prefix "apples-blimps-catalexis example"
 
-  (define (test8 . args)
-    (equal? (sort (getopt-long (cons "foo" args)
-                               '((apples    (single-char #\a))
+  (define  spec '((apples    (single-char #\a))
                                  (blimps    (single-char #\b) (value #t))
                                  (catalexis (single-char #\c) (value #t))))
+
+  (define (test8 . args)
+    (equal? (sort (getopt-long (cons "foo" args) spec)
                   (lambda (a b)
                     (cond ((null? (car a)) #t)
                           ((null? (car b)) #f)
@@ -299,4 +334,131 @@
 
   )
 
+
+(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.20.1






Merged 40719 40720 40721. Request was from Ludovic Courtès <ludo <at> gnu.org> to control <at> debbugs.gnu.org. (Tue, 12 May 2020 13:06:02 GMT) Full text and rfc822 format available.

Merged 40719 40720 40721 40722. Request was from Ludovic Courtès <ludo <at> gnu.org> to control <at> debbugs.gnu.org. (Tue, 12 May 2020 13:06:02 GMT) Full text and rfc822 format available.

Merged 40719 40720 40721 40722 40723. Request was from Ludovic Courtès <ludo <at> gnu.org> to control <at> debbugs.gnu.org. (Tue, 12 May 2020 13:06:03 GMT) Full text and rfc822 format available.

bug closed, send any further explanations to 40719 <at> debbugs.gnu.org and Dale Mellor <guile-qf1qmg <at> rdmp.org> Request was from Dale Mellor <guile-qf1qmg <at> rdmp.org> to control <at> debbugs.gnu.org. (Sun, 02 Aug 2020 10:44:02 GMT) Full text and rfc822 format available.

bug archived. Request was from Debbugs Internal Request <help-debbugs <at> gnu.org> to internal_control <at> debbugs.gnu.org. (Sun, 30 Aug 2020 11:24:05 GMT) Full text and rfc822 format available.

This bug report was last modified 3 years and 211 days ago.

Previous Next


GNU bug tracking system
Copyright (C) 1999 Darren O. Benham, 1997,2003 nCipher Corporation Ltd, 1994-97 Ian Jackson.