* bug#40721: [PATCH 1/4] test: augment testing of (ice-9 getopt-long) module
@ 2020-04-19 17:47 Dale Mellor
0 siblings, 0 replies; only message in thread
From: Dale Mellor @ 2020-04-19 17:47 UTC (permalink / raw)
To: 40721
From b08d1cc7dc03d5e69dfd1f93e50617b81230b5e3 Mon Sep 17 00:00:00 2001
From: Dale Mellor <guile-qf1qmg@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@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@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
^ permalink raw reply related [flat|nested] only message in thread
only message in thread, other threads:[~2020-04-19 17:47 UTC | newest]
Thread overview: (only message) (download: mbox.gz / follow: Atom feed)
-- links below jump to the message on this page --
2020-04-19 17:47 bug#40721: [PATCH 1/4] test: augment testing of (ice-9 getopt-long) module Dale Mellor
This is a public inbox, see mirroring instructions
for how to clone and mirror all data and code used for this inbox;
as well as URLs for read-only IMAP folder(s) and NNTP newsgroup(s).