Fix [7cb7409e05]: Tcl_ParseArgsObjv bug with TCL_ARGV_GENFUNC. With testcase

5 files changed, 72 insertions, 21 deletions

diff --git a/doc/ParseArgs.3 b/doc/ParseArgs.3
index f29f161..ecff658 100644
--- a/doc/ParseArgs.3
+++ b/doc/ParseArgs.3
@@ -156,11 +156,11 @@ typedef int (\fBTcl_ArgvGenFuncProc\fR)(
         void *\fIdstPtr\fR);
 .CE
 .PP
-The \fIclientData\fR is the value from the table entry, the \fIinterp\fR is
-where to store any error messages, the \fIkeyStr\fR is the name of the
-argument, \fIobjc\fR and \fIobjv\fR describe an array of all the remaining
-arguments, and \fIdstPtr\fR argument to the \fBTcl_ArgvGenFuncProc\fR is the
-location to write the parsed value (or values) to.
+The \fIclientData\fR is the value from the table entry, the \fIinterp\fR
+is where to store any error messages, \fIobjc\fR and \fIobjv\fR describe
+an array of all the remaining arguments, and \fIdstPtr\fR argument to the
+\fBTcl_ArgvGenFuncProc\fR is the location to write the parsed value
+(or values) to.
 .RE
 .TP
 \fBTCL_ARGV_HELP\fR
diff --git a/generic/tcl.h b/generic/tcl.h
index da94b47..ca8901d 100644
--- a/generic/tcl.h
+++ b/generic/tcl.h
@@ -2341,8 +2341,8 @@ typedef struct {
 
 typedef int (Tcl_ArgvFuncProc)(void *clientData, Tcl_Obj *objPtr,
 	void *dstPtr);
-typedef int (Tcl_ArgvGenFuncProc)(void *clientData, Tcl_Interp *interp,
-	int objc, Tcl_Obj *const *objv, void *dstPtr);
+typedef Tcl_Size (Tcl_ArgvGenFuncProc)(void *clientData, Tcl_Interp *interp,
+	Tcl_Size objc, Tcl_Obj *const *objv, void *dstPtr);
 
 /*
  * Shorthand for commonly used argTable entries.
diff --git a/generic/tclIndexObj.c b/generic/tclIndexObj.c
index d999cc9..135fe4a 100644
--- a/generic/tclIndexObj.c
+++ b/generic/tclIndexObj.c
@@ -1113,6 +1113,7 @@ Tcl_ParseArgsObjv(
 				 * reporting. */
     Tcl_Size objc;		/* # arguments in objv still to process. */
     Tcl_Size length;		/* Number of characters in current argument */
+    Tcl_Size gf_ret;		/* Return value from Tcl_ArgvGenFuncProc*/
 
     if (remObjv != NULL) {
 	/*
@@ -1268,10 +1269,13 @@ Tcl_ParseArgsObjv(
 	    Tcl_ArgvGenFuncProc *handlerProc = (Tcl_ArgvGenFuncProc *)
 		    infoPtr->srcPtr;
 
-	    objc = handlerProc(infoPtr->clientData, interp, objc,
+	    gf_ret = handlerProc(infoPtr->clientData, interp, objc,
 		    &objv[srcIndex], infoPtr->dstPtr);
-	    if (objc < 0) {
+	    if (gf_ret < 0) {
 		goto error;
+	    } else {
+		srcIndex += gf_ret;
+		objc -= gf_ret;
 	    }
 	    break;
 	}
diff --git a/generic/tclTest.c b/generic/tclTest.c
index 007d51a..f85858f 100644
--- a/generic/tclTest.c
+++ b/generic/tclTest.c
@@ -8404,6 +8404,7 @@ TestconcatobjCmd(
  *	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.
+ *	Also test for bug [7cb7409e05]
  *
  * Results:
  *	A standard Tcl result.
@@ -8414,6 +8415,30 @@ TestconcatobjCmd(
  *----------------------------------------------------------------------
  */
 
+static Tcl_Size
+ParseMedia(
+    TCL_UNUSED(void *),
+    Tcl_Interp *interp,
+    TCL_UNUSED(Tcl_Size),
+    Tcl_Obj *const *objv,
+    void *dstPtr)
+{
+    static const char *const mediaOpts[] = {"A4", "Legal", "Letter", NULL};
+    static const char *const ExtendedMediaOpts[] = {
+	"Paper size is ISO A4", "Paper size is US Legal",
+	"Paper size is US Letter", NULL};
+    int index;
+    const char **media = (const char **) dstPtr;
+
+    if (Tcl_GetIndexFromObjStruct(interp, objv[0], mediaOpts,
+	    sizeof(char *), "media", 0, &index) != TCL_OK) {
+	return -1;
+    }
+
+    *media = ExtendedMediaOpts[index];
+    return 1;
+}
+
 static int
 TestparseargsCmd(
     TCL_UNUSED(void *),
@@ -8422,10 +8447,13 @@ TestparseargsCmd(
     Tcl_Obj *const objv[])	/* Arguments. */
 {
     static int foo = 0;
+    const char *media = NULL, *color = NULL;
     Tcl_Size count = objc;
-    Tcl_Obj **remObjv, *result[3];
+    Tcl_Obj **remObjv, *result[5];
     const Tcl_ArgvInfo argTable[] = {
 	{TCL_ARGV_CONSTANT, "-bool", INT2PTR(1), &foo, "booltest", NULL},
+	{TCL_ARGV_STRING,  "-colormode" ,  NULL, &color,  "color mode", NULL},
+	{TCL_ARGV_GENFUNC, "-media", ParseMedia, &media,  "media page size", NULL},
 	TCL_ARGV_AUTO_REST, TCL_ARGV_AUTO_HELP, TCL_ARGV_TABLE_END
     };
 
@@ -8436,7 +8464,9 @@ TestparseargsCmd(
     result[0] = Tcl_NewWideIntObj(foo);
     result[1] = Tcl_NewWideIntObj(count);
     result[2] = Tcl_NewListObj(count, remObjv);
-    Tcl_SetObjResult(interp, Tcl_NewListObj(3, result));
+    result[3] = Tcl_NewStringObj(color ? color : "NULL", -1);
+    result[4] = Tcl_NewStringObj(media ? media : "NULL", -1);
+    Tcl_SetObjResult(interp, Tcl_NewListObj(5, result));
     ckfree(remObjv);
     return TCL_OK;
 }
diff --git a/tests/indexObj.test b/tests/indexObj.test
index 1cf782a..eec5485 100644
--- a/tests/indexObj.test
+++ b/tests/indexObj.test
@@ -147,29 +147,46 @@ test indexObj-6.7 {Tcl_GetIndexFromObjStruct} testindexobj {
 
 test indexObj-7.1 {Tcl_ParseArgsObjv} testparseargs {
     testparseargs
-} {0 1 testparseargs}
+} {0 1 testparseargs NULL NULL}
 test indexObj-7.2 {Tcl_ParseArgsObjv} testparseargs {
     testparseargs -bool
-} {1 1 testparseargs}
+} {1 1 testparseargs NULL NULL}
 test indexObj-7.3 {Tcl_ParseArgsObjv} testparseargs {
     testparseargs -bool bar
-} {1 2 {testparseargs bar}}
+} {1 2 {testparseargs bar} NULL NULL}
 test indexObj-7.4 {Tcl_ParseArgsObjv} testparseargs {
     testparseargs bar
-} {0 2 {testparseargs bar}}
+} {0 2 {testparseargs bar} NULL NULL}
 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}
+ -bool:      booltest
+ -colormode: color mode
+ -media:     media page size
+ --:         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}}
+} {0 3 {testparseargs -bool -help} NULL NULL}
 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}}
-
+} {1 21 {testparseargs 1 2 3 4 5 6 7 8 9 0 1 2 3 4 5 6 7 8 9 0} NULL NULL}
+test indexObj-7.8 {Tcl_ParseArgsObjv} testparseargs {
+    testparseargs -color Nothing
+} {0 1 testparseargs Nothing NULL}
+test indexObj-7.9 {Tcl_ParseArgsObjv} testparseargs {
+    testparseargs -media A4
+} {0 1 testparseargs NULL {Paper size is ISO A4}}
+test indexObj-7.10 {Tcl_ParseArgsObjv} testparseargs {
+    testparseargs -media A4 -color Somecolor
+} {0 1 testparseargs Somecolor {Paper size is ISO A4}}
+test indexObj-7.11 {Tcl_ParseArgsObjv} testparseargs {
+    testparseargs -color othercolor -media Letter
+} {0 1 testparseargs othercolor {Paper size is US Letter}}
+test indexObj-7.12 {Tcl_ParseArgsObjv} -constraints testparseargs -body {
+    testparseargs -color othercolor -media Nosuchmedia
+} -returnCodes error -result {bad media "Nosuchmedia": must be A4, Legal, or Letter}
+
 test indexObj-8.1 {Tcl_GetIntForIndex integer} testgetintforindex {
     testgetintforindex 0 0
 } 0