From mboxrd@z Thu Jan 1 00:00:00 1970 Path: news.gmane.io!.POSTED.blaine.gmane.org!not-for-mail From: Dale Mellor Newsgroups: gmane.lisp.guile.bugs Subject: bug#42669: [PATCH 1/4] test: augment testing of (ice-9 getopt-long) module Date: Sun, 02 Aug 2020 11:32:45 +0100 Organization: DM Bespoke Computer Solutions Ltd Message-ID: <915523a92e868b15282b3cbfa9d6d84a8698a043.camel@rdmp.org> References: Mime-Version: 1.0 Content-Type: text/plain; charset="UTF-8" Content-Transfer-Encoding: 8bit Injection-Info: ciao.gmane.io; posting-host="blaine.gmane.org:116.202.254.214"; logging-data="20245"; mail-complaints-to="usenet@ciao.gmane.io" User-Agent: Evolution 3.30.5-1.1 To: 42669@debbugs.gnu.org Original-X-From: bug-guile-bounces+guile-bugs=m.gmane-mx.org@gnu.org Sun Aug 02 12:33:08 2020 Return-path: Envelope-to: guile-bugs@m.gmane-mx.org Original-Received: from lists.gnu.org ([209.51.188.17]) by ciao.gmane.io with esmtps (TLS1.2:ECDHE_RSA_AES_256_GCM_SHA384:256) (Exim 4.92) (envelope-from ) id 1k2BIi-00059T-Hs for guile-bugs@m.gmane-mx.org; Sun, 02 Aug 2020 12:33:08 +0200 Original-Received: from localhost ([::1]:58490 helo=lists1p.gnu.org) by lists.gnu.org with esmtp (Exim 4.90_1) (envelope-from ) id 1k2BIh-0000Pe-Kd for guile-bugs@m.gmane-mx.org; Sun, 02 Aug 2020 06:33:07 -0400 Original-Received: from eggs.gnu.org ([2001:470:142:3::10]:46460) by lists.gnu.org with esmtps (TLS1.2:ECDHE_RSA_AES_256_GCM_SHA384:256) (Exim 4.90_1) (envelope-from ) id 1k2BId-0000PU-3X for bug-guile@gnu.org; Sun, 02 Aug 2020 06:33:03 -0400 Original-Received: from debbugs.gnu.org ([209.51.188.43]:58446) by eggs.gnu.org with esmtps (TLS1.2:ECDHE_RSA_AES_128_GCM_SHA256:128) (Exim 4.90_1) (envelope-from ) id 1k2BIc-0004Do-NA for bug-guile@gnu.org; Sun, 02 Aug 2020 06:33:02 -0400 Original-Received: from Debian-debbugs by debbugs.gnu.org with local (Exim 4.84_2) (envelope-from ) id 1k2BIc-0001FF-CX for bug-guile@gnu.org; Sun, 02 Aug 2020 06:33:02 -0400 X-Loop: help-debbugs@gnu.org In-Reply-To: Resent-From: Dale Mellor Original-Sender: "Debbugs-submit" Resent-CC: bug-guile@gnu.org Resent-Date: Sun, 02 Aug 2020 10:33:02 +0000 Resent-Message-ID: Resent-Sender: help-debbugs@gnu.org X-GNU-PR-Message: followup 42669 X-GNU-PR-Package: guile X-GNU-PR-Keywords: patch Original-Received: via spool by 42669-submit@debbugs.gnu.org id=B42669.15963643754772 (code B ref 42669); Sun, 02 Aug 2020 10:33:02 +0000 Original-Received: (at 42669) by debbugs.gnu.org; 2 Aug 2020 10:32:55 +0000 Original-Received: from localhost ([127.0.0.1]:41759 helo=debbugs.gnu.org) by debbugs.gnu.org with esmtp (Exim 4.84_2) (envelope-from ) id 1k2BIU-0001Et-QC for submit@debbugs.gnu.org; Sun, 02 Aug 2020 06:32:55 -0400 Original-Received: from rdmp.org ([52.19.174.175]:36120) by debbugs.gnu.org with esmtp (Exim 4.84_2) (envelope-from ) id 1k2BIS-0001Ed-DU for 42669@debbugs.gnu.org; Sun, 02 Aug 2020 06:32:53 -0400 Original-Received: from [127.0.0.1] (helo=localhost) by rdmp.org with esmtp (Exim 4.92) (envelope-from ) id 1k2BIM-0005u4-4o for 42669@debbugs.gnu.org; Sun, 02 Aug 2020 10:32:46 +0000 X-BeenThere: debbugs-submit@debbugs.gnu.org X-Mailman-Version: 2.1.18 Precedence: list X-BeenThere: bug-guile@gnu.org List-Id: "Bug reports for GUILE, GNU's Ubiquitous Extension Language" List-Unsubscribe: , List-Archive: List-Post: List-Help: List-Subscribe: , Errors-To: bug-guile-bounces+guile-bugs=m.gmane-mx.org@gnu.org Original-Sender: "bug-guile" Xref: news.gmane.io gmane.lisp.guile.bugs:9850 Archived-At: 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 --- 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 --- 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) (stringstring (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