From mboxrd@z Thu Jan 1 00:00:00 1970 Path: news.gmane.io!.POSTED.ciao.gmane.io!not-for-mail From: Dale Mellor Newsgroups: gmane.lisp.guile.bugs Subject: bug#40719: [PATCH 1/4] test: augment testing of (ice-9 getopt-long) module Date: Thu, 07 May 2020 18:01:45 +0100 Organization: DM Bespoke Computer Solutions Ltd Message-ID: <50f4e281e0f364e24d2cc21f6d4163f045718981.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="ciao.gmane.io:159.69.161.202"; logging-data="49296"; mail-complaints-to="usenet@ciao.gmane.io" User-Agent: Evolution 3.30.5-1.1 To: 40719@debbugs.gnu.org Original-X-From: bug-guile-bounces+guile-bugs=m.gmane-mx.org@gnu.org Thu May 07 19:02:09 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 1jWjuS-000ChF-10 for guile-bugs@m.gmane-mx.org; Thu, 07 May 2020 19:02:08 +0200 Original-Received: from localhost ([::1]:59106 helo=lists1p.gnu.org) by lists.gnu.org with esmtp (Exim 4.90_1) (envelope-from ) id 1jWjuR-0004TI-3M for guile-bugs@m.gmane-mx.org; Thu, 07 May 2020 13:02:07 -0400 Original-Received: from eggs.gnu.org ([2001:470:142:3::10]:51316) by lists.gnu.org with esmtps (TLS1.2:ECDHE_RSA_AES_256_GCM_SHA384:256) (Exim 4.90_1) (envelope-from ) id 1jWjuM-0004TA-A9 for bug-guile@gnu.org; Thu, 07 May 2020 13:02:02 -0400 Original-Received: from debbugs.gnu.org ([209.51.188.43]:60508) by eggs.gnu.org with esmtps (TLS1.2:ECDHE_RSA_AES_128_GCM_SHA256:128) (Exim 4.90_1) (envelope-from ) id 1jWjuM-000154-0U for bug-guile@gnu.org; Thu, 07 May 2020 13:02:02 -0400 Original-Received: from Debian-debbugs by debbugs.gnu.org with local (Exim 4.84_2) (envelope-from ) id 1jWjuL-0005SC-T4 for bug-guile@gnu.org; Thu, 07 May 2020 13:02:01 -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: Thu, 07 May 2020 17:02:01 +0000 Resent-Message-ID: Resent-Sender: help-debbugs@gnu.org X-GNU-PR-Message: followup 40719 X-GNU-PR-Package: guile X-GNU-PR-Keywords: patch Original-Received: via spool by 40719-submit@debbugs.gnu.org id=B40719.158887091320947 (code B ref 40719); Thu, 07 May 2020 17:02:01 +0000 Original-Received: (at 40719) by debbugs.gnu.org; 7 May 2020 17:01:53 +0000 Original-Received: from localhost ([127.0.0.1]:43821 helo=debbugs.gnu.org) by debbugs.gnu.org with esmtp (Exim 4.84_2) (envelope-from ) id 1jWjuD-0005Rl-5J for submit@debbugs.gnu.org; Thu, 07 May 2020 13:01:53 -0400 Original-Received: from ec2-52-19-174-175.eu-west-1.compute.amazonaws.com ([52.19.174.175]:46360 helo=rdmp.org) by debbugs.gnu.org with esmtp (Exim 4.84_2) (envelope-from ) id 1jWjuB-0005RV-KP for 40719@debbugs.gnu.org; Thu, 07 May 2020 13:01:52 -0400 Original-Received: from [127.0.0.1] (helo=localhost) by rdmp.org with esmtp (Exim 4.92) (envelope-from ) id 1jWju5-0001E5-Sh for 40719@debbugs.gnu.org; Thu, 07 May 2020 17:01:45 +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:9749 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 | 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 --- 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 --- 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) (stringstring (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