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

Please note: This is a static page, with minimal formatting, updated once a day.
Click here to see this page with the latest information and nicer formatting.

Package: guile; Reported by: Dale Mellor <guile-qf1qmg@HIDDEN>; Keywords: patch; merged with #40719, #40720, #40722, #40723; dated Sun, 19 Apr 2020 19:02:03 UTC; Maintainer for guile is bug-guile@HIDDEN.
Merged 40719 40720 40721 40722 40723. Request was from Ludovic Courtès <ludo@HIDDEN> to control <at> debbugs.gnu.org. Full text available.
Merged 40719 40720 40721 40722. Request was from Ludovic Courtès <ludo@HIDDEN> to control <at> debbugs.gnu.org. Full text available.
Merged 40719 40720 40721. Request was from Ludovic Courtès <ludo@HIDDEN> to control <at> debbugs.gnu.org. Full text available.

Message received at submit <at> debbugs.gnu.org:


Received: (at submit) by debbugs.gnu.org; 19 Apr 2020 19:01:13 +0000
From debbugs-submit-bounces <at> debbugs.gnu.org Sun Apr 19 15:01:13 2020
Received: from localhost ([127.0.0.1]:45968 helo=debbugs.gnu.org)
	by debbugs.gnu.org with esmtp (Exim 4.84_2)
	(envelope-from <debbugs-submit-bounces <at> debbugs.gnu.org>)
	id 1jQFBo-0005xJ-7J
	for submit <at> debbugs.gnu.org; Sun, 19 Apr 2020 15:01:12 -0400
Received: from lists.gnu.org ([209.51.188.17]:47082)
 by debbugs.gnu.org with esmtp (Exim 4.84_2)
 (envelope-from <guile-qf1qmg@HIDDEN>) id 1jQEVb-0004oh-Mk
 for submit <at> debbugs.gnu.org; Sun, 19 Apr 2020 14:17:36 -0400
Received: from eggs.gnu.org ([2001:470:142:3::10]:34068 helo=eggs1p.gnu.org)
 by lists.gnu.org with esmtp (Exim 4.90_1)
 (envelope-from <guile-qf1qmg@HIDDEN>) id 1jQEVa-0005rK-MK
 for bug-guile@HIDDEN; Sun, 19 Apr 2020 14:17:35 -0400
X-Spam-Checker-Version: SpamAssassin 3.4.2 (2018-09-13) on eggs.gnu.org
X-Spam-Level: **
X-Spam-Status: No, score=2.2 required=5.0 tests=RDNS_DYNAMIC, SPF_HELO_SOFTFAIL,
 SPF_SOFTFAIL,URIBL_BLOCKED autolearn=no autolearn_force=no
 version=3.4.2
Received: from Debian-exim by eggs1p.gnu.org with spam-scanned (Exim 4.90_1)
 (envelope-from <guile-qf1qmg@HIDDEN>) id 1jQEVa-0006XG-3i
 for bug-guile@HIDDEN; Sun, 19 Apr 2020 14:17:34 -0400
Received: from ec2-52-19-174-175.eu-west-1.compute.amazonaws.com
 ([52.19.174.175]:45788 helo=rdmp.org)
 by eggs1p.gnu.org with esmtps (TLS1.2:ECDHE_RSA_AES_256_GCM_SHA384:256)
 (Exim 4.90_1) (envelope-from <guile-qf1qmg@HIDDEN>)
 id 1jQEVW-0006S6-8B
 for bug-guile@HIDDEN; Sun, 19 Apr 2020 14:17:33 -0400
Received: from [127.0.0.1] (helo=localhost) by rdmp.org with esmtp (Exim 4.92)
 (envelope-from <guile-qf1qmg@HIDDEN>) id 1jQE2U-0002XZ-DG
 for bug-guile@HIDDEN; Sun, 19 Apr 2020 17:47:30 +0000
Message-ID: <8efb525b750d216d894f7223972472332a71499c.camel@HIDDEN>
Subject: [PATCH 1/4] test: augment testing of (ice-9 getopt-long) module
From: Dale Mellor <guile-qf1qmg@HIDDEN>
To: bug-guile@HIDDEN
Date: Sun, 19 Apr 2020 18:47:30 +0100
Organization: DM Bespoke Computer Solutions Ltd
Content-Type: text/plain; charset="UTF-8"
User-Agent: Evolution 3.30.5-1.1 
MIME-Version: 1.0
Content-Transfer-Encoding: 8bit
Received-SPF: softfail client-ip=52.19.174.175;
 envelope-from=guile-qf1qmg@HIDDEN; helo=rdmp.org
X-detected-operating-system: by eggs1p.gnu.org: Genre and OS details not
 recognized.
X-Received-From: 52.19.174.175
X-Spam-Score: 0.3 (/)
X-Debbugs-Envelope-To: submit
X-Mailman-Approved-At: Sun, 19 Apr 2020 15:01:09 -0400
X-BeenThere: debbugs-submit <at> debbugs.gnu.org
X-Mailman-Version: 2.1.18
Precedence: list
List-Id: <debbugs-submit.debbugs.gnu.org>
List-Unsubscribe: <https://debbugs.gnu.org/cgi-bin/mailman/options/debbugs-submit>, 
 <mailto:debbugs-submit-request <at> debbugs.gnu.org?subject=unsubscribe>
List-Archive: <https://debbugs.gnu.org/cgi-bin/mailman/private/debbugs-submit/>
List-Post: <mailto:debbugs-submit <at> debbugs.gnu.org>
List-Help: <mailto:debbugs-submit-request <at> debbugs.gnu.org?subject=help>
List-Subscribe: <https://debbugs.gnu.org/cgi-bin/mailman/listinfo/debbugs-submit>, 
 <mailto:debbugs-submit-request <at> debbugs.gnu.org?subject=subscribe>
Errors-To: debbugs-submit-bounces <at> debbugs.gnu.org
Sender: "Debbugs-submit" <debbugs-submit-bounces <at> debbugs.gnu.org>
X-Spam-Score: -0.7 (/)

From b08d1cc7dc03d5e69dfd1f93e50617b81230b5e3 Mon Sep 17 00:00:00 2001
From: Dale Mellor <guile-qf1qmg@HIDDEN>
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@HIDDEN> --- 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@HIDDEN> --- 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






Acknowledgement sent to Dale Mellor <guile-qf1qmg@HIDDEN>:
New bug report received and forwarded. Copy sent to bug-guile@HIDDEN. Full text available.
Report forwarded to bug-guile@HIDDEN:
bug#40721; Package guile. Full text available.
Please note: This is a static page, with minimal formatting, updated once a day.
Click here to see this page with the latest information and nicer formatting.
Last modified: Tue, 12 May 2020 13:15:02 UTC

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