From a235eed74f319d7860e973935e2064bd1bb30e18 Mon Sep 17 00:00:00 2001
From: dkf <donal.k.fellows@manchester.ac.uk>
Date: Tue, 27 Sep 2011 09:45:40 +0000
Subject: Test harness for Tcl_ParseArgsObjv
---
generic/tclTest.c | 45 +++++++++++++++++++++++++++++++++++++++++++++
tests/indexObj.test | 38 ++++++++++++++++++++++++++++++++------
2 files changed, 77 insertions(+), 6 deletions(-)
diff --git a/generic/tclTest.c b/generic/tclTest.c
index 96dcb36..5b74663 100644
--- a/generic/tclTest.c
+++ b/generic/tclTest.c
@@ -311,6 +311,8 @@ static int TestpanicCmd(ClientData dummy,
static int TestfinexitObjCmd(ClientData dummy,
Tcl_Interp *interp, int objc,
Tcl_Obj *const objv[]);
+static int TestparseargsCmd(ClientData dummy, Tcl_Interp *interp,
+ int objc, Tcl_Obj *const objv[]);
static int TestparserObjCmd(ClientData dummy,
Tcl_Interp *interp, int objc,
Tcl_Obj *const objv[]);
@@ -624,6 +626,7 @@ Tcltest_Init(
NULL);
Tcl_CreateCommand(interp, "testpanic", TestpanicCmd, NULL, NULL);
Tcl_CreateObjCommand(interp, "testfinexit", TestfinexitObjCmd, NULL, NULL);
+ Tcl_CreateObjCommand(interp, "testparseargs", TestparseargsCmd,NULL,NULL);
Tcl_CreateObjCommand(interp, "testparser", TestparserObjCmd,
NULL, NULL);
Tcl_CreateObjCommand(interp, "testparsevar", TestparsevarObjCmd,
@@ -7082,6 +7085,48 @@ TestconcatobjCmd(
}
/*
+ *----------------------------------------------------------------------
+ *
+ * TestparseargsCmd --
+ *
+ * This procedure implements the "testparseargs" command. It is used to
+ * test that Tcl_ParseArgsObjv does indeed return the right number of
+ * arguments. In other words, that [Bug 3413857] was fixed properly.
+ *
+ * Results:
+ * A standard Tcl result.
+ *
+ * Side effects:
+ * None.
+ *
+ *----------------------------------------------------------------------
+ */
+
+static int
+TestparseargsCmd(
+ ClientData dummy, /* Not used. */
+ Tcl_Interp *interp, /* Current interpreter. */
+ int objc, /* Number of arguments. */
+ Tcl_Obj *const objv[]) /* Arguments. */
+{
+ int count = objc, foo = 0;
+ Tcl_Obj **remObjv, *result[3];
+ Tcl_ArgvInfo argTable[] = {
+ {TCL_ARGV_CONSTANT, "-bool", INT2PTR(1), &foo, "booltest", NULL},
+ TCL_ARGV_AUTO_REST, TCL_ARGV_AUTO_HELP, TCL_ARGV_TABLE_END
+ };
+
+ if (Tcl_ParseArgsObjv(interp, argTable, &count, objv, &remObjv)!=TCL_OK) {
+ return TCL_ERROR;
+ }
+ result[0] = Tcl_NewIntObj(foo);
+ result[1] = Tcl_NewIntObj(count);
+ result[2] = Tcl_NewListObj(count, remObjv);
+ Tcl_SetObjResult(interp, Tcl_NewListObj(3, result));
+ return TCL_OK;
+}
+
+/*
* Local Variables:
* mode: c
* c-basic-offset: 4
diff --git a/tests/indexObj.test b/tests/indexObj.test
index 098aec0..479cc3b 100644
--- a/tests/indexObj.test
+++ b/tests/indexObj.test
@@ -1,20 +1,21 @@
# This file is a Tcl script to test out the the procedures in file
-# tkIndexObj.c, which implement indexed table lookups. The tests here
-# are organized in the standard fashion for Tcl tests.
+# tkIndexObj.c, which implement indexed table lookups. The tests here are
+# organized in the standard fashion for Tcl tests.
#
# Copyright (c) 1997 Sun Microsystems, Inc.
# Copyright (c) 1998-1999 by Scriptics Corporation.
#
-# See the file "license.terms" for information on usage and redistribution
-# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
+# See the file "license.terms" for information on usage and redistribution of
+# this file, and for a DISCLAIMER OF ALL WARRANTIES.
if {[lsearch [namespace children] ::tcltest] == -1} {
- package require tcltest
+ package require tcltest 2
namespace import -force ::tcltest::*
}
testConstraint testindexobj [llength [info commands testindexobj]]
-
+testConstraint testparseargs [llength [info commands testparseargs]]
+
test indexObj-1.1 {exact match} testindexobj {
testindexobj 1 1 xyz abc def xyz alm
} {2}
@@ -128,6 +129,31 @@ test indexObj-6.4 {Tcl_GetIndexFromObjStruct} testindexobj {
testgetindexfromobjstruct $x 1
} "wrong # args: should be \"testgetindexfromobjstruct c 1\""
+test indexObj-7.1 {Tcl_ParseArgsObjv} testparseargs {
+ testparseargs
+} {0 1 testparseargs}
+test indexObj-7.2 {Tcl_ParseArgsObjv} testparseargs {
+ testparseargs -bool
+} {1 1 testparseargs}
+test indexObj-7.3 {Tcl_ParseArgsObjv} testparseargs {
+ testparseargs -bool bar
+} {1 2 {testparseargs bar}}
+test indexObj-7.4 {Tcl_ParseArgsObjv} testparseargs {
+ testparseargs bar
+} {0 2 {testparseargs bar}}
+test indexObj-7.5 {Tcl_ParseArgsObjv} -constraints testparseargs -body {
+ testparseargs -help
+} -returnCodes error -result {Command-specific options:
+ -bool: booltest
+ --: Marks the end of the options
+ -help: Print summary of command-line options and abort}
+test indexObj-7.6 {Tcl_ParseArgsObjv} testparseargs {
+ testparseargs -- -bool -help
+} {0 3 {testparseargs -bool -help}}
+test indexObj-7.7 {Tcl_ParseArgsObjv memory management} testparseargs {
+ testparseargs 1 2 3 4 5 6 7 8 9 0 -bool 1 2 3 4 5 6 7 8 9 0
+} {1 21 {testparseargs 1 2 3 4 5 6 7 8 9 0 1 2 3 4 5 6 7 8 9 0}}
+
# cleanup
::tcltest::cleanupTests
return
--
cgit v0.12