From 599a1dd2b77ed55cc53798a6ca94b659a9b9edac Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Wed, 3 Apr 2024 22:09:01 +0000 Subject: Proposed fix for [7cb7409e05]: Tcl_ParseArgsObjv bug with TCL_ARGV_GENFUNC --- doc/ParseArgs.3 | 10 +++++----- generic/tclIndexObj.c | 8 ++++++-- 2 files changed, 11 insertions(+), 7 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/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; } -- cgit v0.12 From b3e3d35bef643c773ffdba698d0b74b4f2e74a0d Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Wed, 3 Apr 2024 22:21:47 +0000 Subject: Add "testparseargsobj" command. Testcases to be added --- generic/tclTest.c | 79 +++++++++++++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 79 insertions(+) diff --git a/generic/tclTest.c b/generic/tclTest.c index 007d51a..5491d80 100644 --- a/generic/tclTest.c +++ b/generic/tclTest.c @@ -246,6 +246,7 @@ static Tcl_ObjCmdProc TestbumpinterpepochObjCmd; static Tcl_ObjCmdProc TestbytestringObjCmd; static Tcl_ObjCmdProc TestsetbytearraylengthObjCmd; static Tcl_ObjCmdProc TestpurebytesobjObjCmd; +static Tcl_ObjCmdProc TestparseargsObjCmd; static Tcl_ObjCmdProc TeststringbytesObjCmd; static Tcl_ObjCmdProc Testutf16stringObjCmd; static Tcl_ObjCmdProc TestcmdinfoObjCmd; @@ -592,6 +593,7 @@ Tcltest_Init( Tcl_CreateCommand(interp, "noop", NoopCmd, NULL, NULL); Tcl_CreateObjCommand(interp, "noop", NoopObjCmd, NULL, NULL); Tcl_CreateObjCommand(interp, "testpurebytesobj", TestpurebytesobjObjCmd, NULL, NULL); + Tcl_CreateObjCommand(interp, "testparseargsobj", TestparseargsObjCmd, NULL, NULL); Tcl_CreateObjCommand(interp, "testsetbytearraylength", TestsetbytearraylengthObjCmd, NULL, NULL); Tcl_CreateObjCommand(interp, "testbytestring", TestbytestringObjCmd, NULL, NULL); Tcl_CreateObjCommand(interp, "teststringbytes", TeststringbytesObjCmd, NULL, NULL); @@ -5643,6 +5645,83 @@ TestpurebytesobjObjCmd( /* *---------------------------------------------------------------------- * + * TestparseargsObjCmd -- + * + * This object-based procedure tests the TCL_ARGV_GENFUNC functionality. + * + * Results: + * Returns the TCL_OK result code. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +static int +ParseMedia( + TCL_UNUSED(void *), + Tcl_Interp *interp, + TCL_UNUSED(int), + 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 +TestparseargsObjCmd( + TCL_UNUSED(void *), + Tcl_Interp *interp, + int objc, + Tcl_Obj *const objv[]) +{ + Tcl_Size count; + + const char *media = NULL, *color = NULL; + + const Tcl_ArgvInfo argTable[] = { + {TCL_ARGV_STRING, "-colormode" , NULL, &color, "color mode", NULL}, + {TCL_ARGV_GENFUNC, "-media", ParseMedia, &media, "media page size", NULL}, + TCL_ARGV_TABLE_END + }; + + if (objc%2 != 1) { + Tcl_WrongNumArgs(interp, 1, objv, "?-opt arg ...?"); + return TCL_ERROR; + } + + count = objc; + + if (Tcl_ParseArgsObjv(interp, argTable, &count, objv, NULL)!=TCL_OK) { + return TCL_ERROR; + } + + /* show color and media parsed values */ + Tcl_SetObjResult(interp, Tcl_ObjPrintf("Color: |%d|%s|, Media: |%d|%s|", + color?1:0, color?color:"NO COLOR", + media?1:0, media?media:"NO MEDIA" + )); + + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * * TestsetbytearraylengthObjCmd -- * * Testing command 'testsetbytearraylength` used to test the public -- cgit v0.12 From 4e1c4f560a7a0c6588845ca2b96e0a4f11392af8 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Thu, 4 Apr 2024 20:01:44 +0000 Subject: Combine with "testparseargs" command. With testcases now --- generic/tclTest.c | 113 +++++++++++++++------------------------------------- tests/indexObj.test | 37 ++++++++++++----- 2 files changed, 59 insertions(+), 91 deletions(-) diff --git a/generic/tclTest.c b/generic/tclTest.c index 5491d80..cc193ef 100644 --- a/generic/tclTest.c +++ b/generic/tclTest.c @@ -246,7 +246,6 @@ static Tcl_ObjCmdProc TestbumpinterpepochObjCmd; static Tcl_ObjCmdProc TestbytestringObjCmd; static Tcl_ObjCmdProc TestsetbytearraylengthObjCmd; static Tcl_ObjCmdProc TestpurebytesobjObjCmd; -static Tcl_ObjCmdProc TestparseargsObjCmd; static Tcl_ObjCmdProc TeststringbytesObjCmd; static Tcl_ObjCmdProc Testutf16stringObjCmd; static Tcl_ObjCmdProc TestcmdinfoObjCmd; @@ -593,7 +592,6 @@ Tcltest_Init( Tcl_CreateCommand(interp, "noop", NoopCmd, NULL, NULL); Tcl_CreateObjCommand(interp, "noop", NoopObjCmd, NULL, NULL); Tcl_CreateObjCommand(interp, "testpurebytesobj", TestpurebytesobjObjCmd, NULL, NULL); - Tcl_CreateObjCommand(interp, "testparseargsobj", TestparseargsObjCmd, NULL, NULL); Tcl_CreateObjCommand(interp, "testsetbytearraylength", TestsetbytearraylengthObjCmd, NULL, NULL); Tcl_CreateObjCommand(interp, "testbytestring", TestbytestringObjCmd, NULL, NULL); Tcl_CreateObjCommand(interp, "teststringbytes", TeststringbytesObjCmd, NULL, NULL); @@ -5645,83 +5643,6 @@ TestpurebytesobjObjCmd( /* *---------------------------------------------------------------------- * - * TestparseargsObjCmd -- - * - * This object-based procedure tests the TCL_ARGV_GENFUNC functionality. - * - * Results: - * Returns the TCL_OK result code. - * - * Side effects: - * None. - * - *---------------------------------------------------------------------- - */ - -static int -ParseMedia( - TCL_UNUSED(void *), - Tcl_Interp *interp, - TCL_UNUSED(int), - 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 -TestparseargsObjCmd( - TCL_UNUSED(void *), - Tcl_Interp *interp, - int objc, - Tcl_Obj *const objv[]) -{ - Tcl_Size count; - - const char *media = NULL, *color = NULL; - - const Tcl_ArgvInfo argTable[] = { - {TCL_ARGV_STRING, "-colormode" , NULL, &color, "color mode", NULL}, - {TCL_ARGV_GENFUNC, "-media", ParseMedia, &media, "media page size", NULL}, - TCL_ARGV_TABLE_END - }; - - if (objc%2 != 1) { - Tcl_WrongNumArgs(interp, 1, objv, "?-opt arg ...?"); - return TCL_ERROR; - } - - count = objc; - - if (Tcl_ParseArgsObjv(interp, argTable, &count, objv, NULL)!=TCL_OK) { - return TCL_ERROR; - } - - /* show color and media parsed values */ - Tcl_SetObjResult(interp, Tcl_ObjPrintf("Color: |%d|%s|, Media: |%d|%s|", - color?1:0, color?color:"NO COLOR", - media?1:0, media?media:"NO MEDIA" - )); - - return TCL_OK; -} - -/* - *---------------------------------------------------------------------- - * * TestsetbytearraylengthObjCmd -- * * Testing command 'testsetbytearraylength` used to test the public @@ -8483,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. @@ -8494,6 +8416,30 @@ TestconcatobjCmd( */ static int +ParseMedia( + TCL_UNUSED(void *), + Tcl_Interp *interp, + TCL_UNUSED(int), + 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 *), Tcl_Interp *interp, /* Current interpreter. */ @@ -8501,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 }; @@ -8515,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 -- cgit v0.12 From 236e3e1beace12620e71c3bc5abb2616d69c1f07 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Thu, 4 Apr 2024 20:14:07 +0000 Subject: Tcl_ArgvGenFuncProc: int -> Tcl_Size (twice) --- generic/tcl.h | 4 ++-- generic/tclTest.c | 2 +- 2 files changed, 3 insertions(+), 3 deletions(-) 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/tclTest.c b/generic/tclTest.c index cc193ef..e2ffda9 100644 --- a/generic/tclTest.c +++ b/generic/tclTest.c @@ -8419,7 +8419,7 @@ static int ParseMedia( TCL_UNUSED(void *), Tcl_Interp *interp, - TCL_UNUSED(int), + TCL_UNUSED(Tcl_Size), Tcl_Obj *const *objv, void *dstPtr) { -- cgit v0.12 From efbc62529da829fc2384f7b0fce70ffcb1183dc7 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Thu, 4 Apr 2024 20:43:08 +0000 Subject: Fix [7cb7409e05] by backporting tclIndexObj.c from [c3b23bf0c7] --- generic/tclIndexObj.c | 119 +++++++++++++++++++++++++------------------------- tests/indexObj.test | 6 +-- 2 files changed, 63 insertions(+), 62 deletions(-) diff --git a/generic/tclIndexObj.c b/generic/tclIndexObj.c index c024b60..5738bbf 100644 --- a/generic/tclIndexObj.c +++ b/generic/tclIndexObj.c @@ -25,15 +25,9 @@ static int GetIndexFromObjList(Tcl_Interp *interp, static void UpdateStringOfIndex(Tcl_Obj *objPtr); static void DupIndex(Tcl_Obj *srcPtr, Tcl_Obj *dupPtr); static void FreeIndex(Tcl_Obj *objPtr); -static int PrefixAllObjCmd(ClientData clientData, - Tcl_Interp *interp, int objc, - Tcl_Obj *const objv[]); -static int PrefixLongestObjCmd(ClientData clientData, - Tcl_Interp *interp, int objc, - Tcl_Obj *const objv[]); -static int PrefixMatchObjCmd(ClientData clientData, - Tcl_Interp *interp, int objc, - Tcl_Obj *const objv[]); +static Tcl_ObjCmdProc PrefixAllObjCmd; +static Tcl_ObjCmdProc PrefixLongestObjCmd; +static Tcl_ObjCmdProc PrefixMatchObjCmd; static void PrintUsage(Tcl_Interp *interp, const Tcl_ArgvInfo *argTable); @@ -172,10 +166,11 @@ GetIndexFromObjList( const char *msg, /* Identifying word to use in error * messages. */ int flags, /* 0 or TCL_EXACT */ - int *indexPtr) /* Place to store resulting integer index. */ + int *indexPtr) /* Place to store resulting index. */ { - int objc, result, t; + int objc, t; + int result; Tcl_Obj **objv; const char **tablePtr; @@ -205,7 +200,7 @@ GetIndexFromObjList( return TCL_OK; } - tablePtr[t] = Tcl_GetString(objv[t]); + tablePtr[t] = TclGetString(objv[t]); } tablePtr[objc] = NULL; @@ -373,26 +368,26 @@ Tcl_GetIndexFromObjStruct( } Tcl_AppendStringsToObj(resultPtr, (numAbbrev>1 && !(flags & TCL_EXACT) ? "ambiguous " : "bad "), - msg, " \"", key, NULL); + msg, " \"", key, (char *)NULL); if (*entryPtr == NULL) { - Tcl_AppendStringsToObj(resultPtr, "\": no valid options", NULL); + Tcl_AppendStringsToObj(resultPtr, "\": no valid options", (char *)NULL); } else { Tcl_AppendStringsToObj(resultPtr, "\": must be ", - *entryPtr, NULL); + *entryPtr, (char *)NULL); entryPtr = NEXT_ENTRY(entryPtr, offset); while (*entryPtr != NULL) { if (*NEXT_ENTRY(entryPtr, offset) == NULL) { Tcl_AppendStringsToObj(resultPtr, (count > 0 ? "," : ""), - " or ", *entryPtr, NULL); + " or ", *entryPtr, (char *)NULL); } else if (**entryPtr) { - Tcl_AppendStringsToObj(resultPtr, ", ", *entryPtr, NULL); + Tcl_AppendStringsToObj(resultPtr, ", ", *entryPtr, (char *)NULL); count++; } entryPtr = NEXT_ENTRY(entryPtr, offset); } } Tcl_SetObjResult(interp, resultPtr); - Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "INDEX", msg, key, NULL); + Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "INDEX", msg, key, (char *)NULL); } return TCL_ERROR; } @@ -545,7 +540,7 @@ PrefixMatchObjCmd( Tcl_Obj *const objv[]) /* Argument objects. */ { int flags = 0, result, index; - int dummyLength, i, errorLength; + int dummyLength, errorLength, i; Tcl_Obj *errorPtr = NULL; const char *message = "option"; Tcl_Obj *tablePtr, *objPtr, *resultPtr; @@ -562,8 +557,8 @@ PrefixMatchObjCmd( } for (i = 1; i < (objc - 2); i++) { - if (Tcl_GetIndexFromObj(interp, objv[i], matchOptions, "option", 0, - &index) != TCL_OK) { + if (Tcl_GetIndexFromObjStruct(interp, objv[i], matchOptions, + sizeof(char *), "option", 0, &index) != TCL_OK) { return TCL_ERROR; } switch ((enum matchOptionsEnum) index) { @@ -574,17 +569,17 @@ PrefixMatchObjCmd( if (i > objc-4) { Tcl_SetObjResult(interp, Tcl_NewStringObj( "missing value for -message", -1)); - Tcl_SetErrorCode(interp, "TCL", "OPERATION", "NOARG", NULL); + Tcl_SetErrorCode(interp, "TCL", "OPERATION", "NOARG", (char *)NULL); return TCL_ERROR; } i++; - message = Tcl_GetString(objv[i]); + message = TclGetString(objv[i]); break; case PRFMATCH_ERROR: if (i > objc-4) { Tcl_SetObjResult(interp, Tcl_NewStringObj( "missing value for -error", -1)); - Tcl_SetErrorCode(interp, "TCL", "OPERATION", "NOARG", NULL); + Tcl_SetErrorCode(interp, "TCL", "OPERATION", "NOARG", (char *)NULL); return TCL_ERROR; } i++; @@ -596,7 +591,7 @@ PrefixMatchObjCmd( Tcl_SetObjResult(interp, Tcl_NewStringObj( "error options must have an even number of elements", -1)); - Tcl_SetErrorCode(interp, "TCL", "VALUE", "DICTIONARY", NULL); + Tcl_SetErrorCode(interp, "TCL", "VALUE", "DICTIONARY", (char *)NULL); return TCL_ERROR; } errorPtr = objv[i]; @@ -668,7 +663,8 @@ PrefixAllObjCmd( int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ { - int tableObjc, result, t, length, elemLength; + int result; + int length, elemLength, tableObjc, t; const char *string, *elemString; Tcl_Obj **tableObjv, *resultPtr; @@ -682,10 +678,10 @@ PrefixAllObjCmd( return result; } resultPtr = Tcl_NewListObj(0, NULL); - string = Tcl_GetStringFromObj(objv[2], &length); + string = TclGetStringFromObj(objv[2], &length); for (t = 0; t < tableObjc; t++) { - elemString = Tcl_GetStringFromObj(tableObjv[t], &elemLength); + elemString = TclGetStringFromObj(tableObjv[t], &elemLength); /* * A prefix cannot match if it is longest. @@ -725,7 +721,8 @@ PrefixLongestObjCmd( int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ { - int tableObjc, result, i, t, length, elemLength, resultLength; + int result; + int i, length, elemLength, resultLength, tableObjc, t; const char *string, *elemString, *resultString; Tcl_Obj **tableObjv; @@ -738,13 +735,13 @@ PrefixLongestObjCmd( if (result != TCL_OK) { return result; } - string = Tcl_GetStringFromObj(objv[2], &length); + string = TclGetStringFromObj(objv[2], &length); resultString = NULL; resultLength = 0; for (t = 0; t < tableObjc; t++) { - elemString = Tcl_GetStringFromObj(tableObjv[t], &elemLength); + elemString = TclGetStringFromObj(tableObjv[t], &elemLength); /* * First check if the prefix string matches the element. A prefix @@ -850,7 +847,7 @@ Tcl_WrongNumArgs( Tcl_Obj *objPtr; int i, len, elemLen; char flags; - Interp *iPtr = (Interp *) interp; + Interp *iPtr = (Interp *)interp; const char *elementStr; /* @@ -914,7 +911,7 @@ Tcl_WrongNumArgs( objc -= toSkip; /* - * We assume no object is of index type. + * Assume no object is of index type. */ for (i=0 ; itypePtr == &indexType) { IndexRep *indexRep = - origObjv[i]->internalRep.twoPtrValue.ptr1; + (IndexRep *)origObjv[i]->internalRep.twoPtrValue.ptr1; elementStr = EXPAND_OF(indexRep); elemLen = strlen(elementStr); @@ -952,8 +949,8 @@ Tcl_WrongNumArgs( * moderately complex condition here). */ - if (itypePtr == &indexType) { - IndexRep *indexRep = objv[i]->internalRep.twoPtrValue.ptr1; + IndexRep *indexRep = (IndexRep *)objv[i]->internalRep.twoPtrValue.ptr1; - Tcl_AppendStringsToObj(objPtr, EXPAND_OF(indexRep), NULL); + Tcl_AppendStringsToObj(objPtr, EXPAND_OF(indexRep), (char *)NULL); } else { /* * Quote the argument if it contains spaces (Bug 942757). @@ -1003,8 +1000,8 @@ Tcl_WrongNumArgs( * (either another element from objv, or the message string). */ - if (i 0) { c = str[1]; } else { @@ -1117,7 +1115,7 @@ Tcl_ParseArgsObjv( } /* - * Loop throught the argument descriptors searching for one with the + * Loop through the argument descriptors searching for one with the * matching key string. If found, leave a pointer to it in matchPtr. */ @@ -1177,7 +1175,7 @@ Tcl_ParseArgsObjv( (int *) infoPtr->dstPtr) == TCL_ERROR) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( "expected integer argument for \"%s\" but got \"%s\"", - infoPtr->keyStr, Tcl_GetString(objv[srcIndex]))); + infoPtr->keyStr, TclGetString(objv[srcIndex]))); goto error; } srcIndex++; @@ -1188,7 +1186,7 @@ Tcl_ParseArgsObjv( goto missingArg; } *((const char **) infoPtr->dstPtr) = - Tcl_GetString(objv[srcIndex]); + TclGetString(objv[srcIndex]); srcIndex++; objc--; break; @@ -1210,7 +1208,7 @@ Tcl_ParseArgsObjv( (double *) infoPtr->dstPtr) == TCL_ERROR) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( "expected floating-point argument for \"%s\" but got \"%s\"", - infoPtr->keyStr, Tcl_GetString(objv[srcIndex]))); + infoPtr->keyStr, TclGetString(objv[srcIndex]))); goto error; } srcIndex++; @@ -1236,10 +1234,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; } @@ -1420,8 +1421,8 @@ TclGetCompletionCodeFromObj( && TclGetIntFromObj(NULL, value, codePtr) == TCL_OK) { return TCL_OK; } - if (Tcl_GetIndexFromObj(NULL, value, returnCodes, NULL, TCL_EXACT, - codePtr) == TCL_OK) { + if (Tcl_GetIndexFromObjStruct(NULL, value, returnCodes, + sizeof(char *), NULL, TCL_EXACT, codePtr) == TCL_OK) { return TCL_OK; } @@ -1434,7 +1435,7 @@ TclGetCompletionCodeFromObj( "bad completion code \"%s\": must be" " ok, error, return, break, continue, or an integer", TclGetString(value))); - Tcl_SetErrorCode(interp, "TCL", "RESULT", "ILLEGAL_CODE", NULL); + Tcl_SetErrorCode(interp, "TCL", "RESULT", "ILLEGAL_CODE", (char *)NULL); } return TCL_ERROR; } diff --git a/tests/indexObj.test b/tests/indexObj.test index 4ff1a6f..bf9a434 100644 --- a/tests/indexObj.test +++ b/tests/indexObj.test @@ -169,13 +169,13 @@ test indexObj-7.7 {Tcl_ParseArgsObjv memory management} testparseargs { test indexObj-7.8 {Tcl_ParseArgsObjv} testparseargs { testparseargs -color Nothing } {0 1 testparseargs Nothing NULL} -test indexObj-7.9 {Tcl_ParseArgsObjv} {testparseargs knownBug} { +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 knownBug} { +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 knownBug} { +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 { -- cgit v0.12