From 70d6ba87462da32e8515e346a38eae4c9c9ab83f Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Fri, 2 Sep 2022 10:17:44 +0000 Subject: Finish remaining part of TIP-627 for Tcl 9.0: Handle objProc2/objClientData2 fields correctly in Tcl_CmdInfo struct. --- generic/tclBasic.c | 95 +++++++++++++++++++++++++++++++++++++++++++-------- generic/tclIndexObj.c | 2 +- generic/tclTest.c | 37 ++++++++++++-------- 3 files changed, 105 insertions(+), 29 deletions(-) diff --git a/generic/tclBasic.c b/generic/tclBasic.c index eb3889d..379ab10 100644 --- a/generic/tclBasic.c +++ b/generic/tclBasic.c @@ -608,13 +608,13 @@ TclFinalizeEvaluation(void) */ static int -buildInfoObjCmd( +buildInfoObjCmd2( void *clientData, Tcl_Interp *interp, /* Current interpreter. */ - int objc, /* Number of arguments. */ + size_t objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ { - if (objc > 2) { + if (objc - 1 > 1) { Tcl_WrongNumArgs(interp, 1, objv, "?option?"); return TCL_ERROR; } @@ -693,6 +693,16 @@ buildInfoObjCmd( return TCL_OK; } +static int +buildInfoObjCmd( + void *clientData, + Tcl_Interp *interp, /* Current interpreter. */ + int objc, /* Number of arguments. */ + Tcl_Obj *const objv[]) /* Argument objects. */ +{ + return buildInfoObjCmd2(clientData, interp, (size_t)objc, objv); +} + /* *---------------------------------------------------------------------- * @@ -1234,9 +1244,13 @@ Tcl_CreateInterp(void) Tcl_PkgProvideEx(interp, "Tcl", TCL_PATCH_LEVEL, &tclStubs); Tcl_PkgProvideEx(interp, "tcl", TCL_PATCH_LEVEL, &tclStubs); - Tcl_CreateObjCommand(interp, "::tcl::build-info", - buildInfoObjCmd, (void *)version, NULL); - + Tcl_CmdInfo info2; + Tcl_Command buildInfoCmd = Tcl_CreateObjCommand2(interp, "::tcl::build-info", + buildInfoObjCmd2, (void *)version, NULL); + Tcl_GetCommandInfoFromToken(buildInfoCmd, &info2); + info2.objProc = buildInfoObjCmd; + info2.objClientData = (void *)version; + Tcl_SetCommandInfoFromToken(buildInfoCmd, &info2); if (TclTommath_Init(interp) != TCL_OK) { Tcl_Panic("%s", Tcl_GetStringResult(interp)); @@ -2631,10 +2645,11 @@ Tcl_CreateCommand( */ typedef struct { - void *clientData; /* Arbitrary value to pass to object function. */ Tcl_ObjCmdProc2 *proc; - Tcl_ObjCmdProc2 *nreProc; + void *clientData; /* Arbitrary value to pass to proc function. */ Tcl_CmdDeleteProc *deleteProc; + void *deleteData; /* Arbitrary value to pass to deleteProc function. */ + Tcl_ObjCmdProc2 *nreProc; } CmdWrapperInfo; @@ -2650,7 +2665,7 @@ static int cmdWrapperProc(void *clientData, static void cmdWrapperDeleteProc(void *clientData) { CmdWrapperInfo *info = (CmdWrapperInfo *)clientData; - clientData = info->clientData; + clientData = info->deleteData; Tcl_CmdDeleteProc *deleteProc = info->deleteProc; Tcl_Free(info); if (deleteProc != NULL) { @@ -2677,8 +2692,9 @@ Tcl_CreateObjCommand2( { CmdWrapperInfo *info = (CmdWrapperInfo *)Tcl_Alloc(sizeof(CmdWrapperInfo)); info->proc = proc; - info->deleteProc = deleteProc; info->clientData = clientData; + info->deleteProc = deleteProc; + info->deleteData = clientData; return Tcl_CreateObjCommand(interp, cmdName, (proc ? cmdWrapperProc : NULL), @@ -3265,6 +3281,28 @@ Tcl_SetCommandInfo( *---------------------------------------------------------------------- */ +static int +invokeObj2Command( + void *clientData, /* Points to command's Command structure. */ + Tcl_Interp *interp, /* Current interpreter. */ + size_t objc, /* Number of arguments. */ + Tcl_Obj *const objv[]) /* Argument objects. */ +{ + int result; + Command *cmdPtr = (Command *) clientData; + + if (objc > INT_MAX) { + objc = TCL_INDEX_NONE; + } + if (cmdPtr->objProc != NULL) { + result = cmdPtr->objProc(cmdPtr->objClientData, interp, objc, objv); + } else { + result = Tcl_NRCallObjProc(interp, cmdPtr->nreProc, + cmdPtr->objClientData, objc, objv); + } + return result; +} + int Tcl_SetCommandInfoFromToken( Tcl_Command cmd, @@ -3296,8 +3334,19 @@ Tcl_SetCommandInfoFromToken( } if (cmdPtr->deleteProc == cmdWrapperDeleteProc) { CmdWrapperInfo *info = (CmdWrapperInfo *)cmdPtr->deleteData; + if (infoPtr->objProc2 == NULL) { + info->proc = invokeObj2Command; + info->clientData = cmdPtr; + info->nreProc = NULL; + } else { + if (infoPtr->objProc2 != info->proc) { + info->nreProc = NULL; + info->proc = infoPtr->objProc2; + } + info->clientData = infoPtr->objClientData2; + } info->deleteProc = infoPtr->deleteProc; - info->clientData = infoPtr->deleteData; + info->deleteData = infoPtr->deleteData; } else { cmdPtr->deleteProc = infoPtr->deleteProc; cmdPtr->deleteData = infoPtr->deleteData; @@ -3355,6 +3404,15 @@ Tcl_GetCommandInfo( *---------------------------------------------------------------------- */ +static int cmdWrapper2Proc(void *clientData, + Tcl_Interp *interp, + size_t objc, + Tcl_Obj *const objv[]) +{ + Command *cmdPtr = (Command *)clientData; + return cmdPtr->objProc(cmdPtr->objClientData, interp, objc, objv); +} + int Tcl_GetCommandInfoFromToken( Tcl_Command cmd, @@ -3368,7 +3426,8 @@ Tcl_GetCommandInfoFromToken( /* * Set isNativeObjectProc 1 if objProc was registered by a call to - * Tcl_CreateObjCommand. Otherwise set it to 0. + * Tcl_CreateObjCommand. Set isNativeObjectProc 2 if objProc was + * registered by a call to Tcl_CreateObjCommand. Otherwise set it to 0. */ cmdPtr = (Command *) cmd; @@ -3381,10 +3440,17 @@ Tcl_GetCommandInfoFromToken( if (cmdPtr->deleteProc == cmdWrapperDeleteProc) { CmdWrapperInfo *info = (CmdWrapperInfo *)cmdPtr->deleteData; infoPtr->deleteProc = info->deleteProc; - infoPtr->deleteData = info->clientData; + infoPtr->deleteData = info->deleteData; + infoPtr->objProc2 = info->proc; + infoPtr->objClientData2 = info->clientData; + if (cmdPtr->objProc == cmdWrapperProc) { + infoPtr->isNativeObjectProc = 2; + } } else { infoPtr->deleteProc = cmdPtr->deleteProc; infoPtr->deleteData = cmdPtr->deleteData; + infoPtr->objProc2 = cmdWrapper2Proc; + infoPtr->objClientData2 = cmdPtr; } infoPtr->namespacePtr = (Tcl_Namespace *) cmdPtr->nsPtr; return 1; @@ -8491,9 +8557,10 @@ Tcl_NRCreateCommand2( { CmdWrapperInfo *info = (CmdWrapperInfo *)Tcl_Alloc(sizeof(CmdWrapperInfo)); info->proc = proc; + info->clientData = clientData; info->nreProc = nreProc; info->deleteProc = deleteProc; - info->clientData = clientData; + info->deleteData = clientData; return Tcl_NRCreateCommand(interp, cmdName, (proc ? cmdWrapperProc : NULL), (nreProc ? cmdWrapperNreProc : NULL), diff --git a/generic/tclIndexObj.c b/generic/tclIndexObj.c index 78dd47e..763d661 100644 --- a/generic/tclIndexObj.c +++ b/generic/tclIndexObj.c @@ -944,7 +944,7 @@ Tcl_WrongNumArgs( * (either another element from objv, or the message string). */ - if (i 8 + if (info.isNativeObjectProc == 2) { + Tcl_CreateObjCommand2(interp, "::tcl::test::build-info", + info.objProc2, (void *)version, NULL); + } else +#endif Tcl_CreateObjCommand(interp, "::tcl::test::build-info", info.objProc, (void *)version, NULL); } @@ -573,7 +579,7 @@ Tcltest_Init( Tcl_CreateObjCommand(interp, "testsetbytearraylength", TestsetbytearraylengthObjCmd, NULL, NULL); Tcl_CreateObjCommand(interp, "testbytestring", TestbytestringObjCmd, NULL, NULL); Tcl_CreateObjCommand(interp, "teststringbytes", TeststringbytesObjCmd, NULL, NULL); - Tcl_CreateObjCommand(interp, "testwrongnumargs", TestWrongNumArgsObjCmd, + Tcl_CreateObjCommand2(interp, "testwrongnumargs", TestWrongNumArgsObjCmd, NULL, NULL); Tcl_CreateObjCommand(interp, "testfilesystem", TestFilesystemObjCmd, NULL, NULL); @@ -811,6 +817,12 @@ Tcltest_SafeInit( return TCL_ERROR; } if (Tcl_GetCommandInfo(interp, "::tcl::build-info", &info)) { +#if TCL_MAJOR_VERSION > 8 + if (info.isNativeObjectProc == 2) { + Tcl_CreateObjCommand2(interp, "::tcl::test::build-info", + info.objProc2, (void *)version, NULL); + } else +#endif Tcl_CreateObjCommand(interp, "::tcl::test::build-info", info.objProc, (void *)version, NULL); } @@ -6508,22 +6520,18 @@ static int TestWrongNumArgsObjCmd( TCL_UNUSED(void *), Tcl_Interp *interp, /* Current interpreter. */ - int objc, /* Number of arguments. */ + size_t objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ { - int i, length; + Tcl_WideInt i; + size_t length; const char *msg; - if (objc < 3) { - /* - * Don't use Tcl_WrongNumArgs here, as that is the function - * we want to test! - */ - Tcl_AppendResult(interp, "insufficient arguments", NULL); - return TCL_ERROR; + if (objc + 1 < 4) { + goto insufArgs; } - if (Tcl_GetIntFromObj(interp, objv[1], &i) != TCL_OK) { + if (Tcl_GetWideIntFromObj(interp, objv[1], &i) != TCL_OK) { return TCL_ERROR; } @@ -6532,15 +6540,16 @@ TestWrongNumArgsObjCmd( msg = NULL; } - if (i > objc - 3) { + if (i < 0 || (Tcl_WideUInt)i + 3 > (Tcl_WideUInt)objc) { /* * Asked for more arguments than were given. */ + insufArgs: Tcl_AppendResult(interp, "insufficient arguments", NULL); return TCL_ERROR; } - Tcl_WrongNumArgs(interp, i, &(objv[3]), msg); + Tcl_WrongNumArgs(interp, (size_t)i, &(objv[3]), msg); return TCL_OK; } -- cgit v0.12 From 007dfc95a9870b057dda71b51dc84e856aa09a38 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Fri, 2 Sep 2022 14:41:09 +0000 Subject: Some additional protection for objc < 0 --- generic/tclBasic.c | 10 ++++++++-- 1 file changed, 8 insertions(+), 2 deletions(-) diff --git a/generic/tclBasic.c b/generic/tclBasic.c index b1b35e1..f474b5d 100644 --- a/generic/tclBasic.c +++ b/generic/tclBasic.c @@ -8480,7 +8480,10 @@ int wrapperNRObjProc( clientData = info->clientData; Tcl_ObjCmdProc2 *proc = info->proc; Tcl_Free(info); - return proc(clientData, interp, objc, objv); + if (objc < 0) { + objc = -1; + } + return proc(clientData, interp, (size_t)objc, objv); } int @@ -8536,7 +8539,10 @@ static int cmdWrapperNreProc( Tcl_Obj *const objv[]) { CmdWrapperInfo *info = (CmdWrapperInfo *)clientData; - return info->nreProc(info->clientData, interp, objc, objv); + if (objc < 0) { + objc = -1; + } + return info->nreProc(info->clientData, interp, (size_t)objc, objv); } Tcl_Command -- cgit v0.12 From cd5e1b2e6cc18917b875413e8b7e40da7fb5002f Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Fri, 2 Sep 2022 22:41:50 +0000 Subject: Complete Tcl_SetCommandInfoFromToken() implementation, in case Tcl_CreateObjCommand() is used to create the original Command, while objProc2 is filled later --- generic/tclBasic.c | 41 ++++++++++++++++++++++++++--------------- 1 file changed, 26 insertions(+), 15 deletions(-) diff --git a/generic/tclBasic.c b/generic/tclBasic.c index f474b5d..b2ec58e 100644 --- a/generic/tclBasic.c +++ b/generic/tclBasic.c @@ -1245,11 +1245,11 @@ Tcl_CreateInterp(void) Tcl_PkgProvideEx(interp, "Tcl", TCL_PATCH_LEVEL, &tclStubs); Tcl_PkgProvideEx(interp, "tcl", TCL_PATCH_LEVEL, &tclStubs); Tcl_CmdInfo info2; - Tcl_Command buildInfoCmd = Tcl_CreateObjCommand2(interp, "::tcl::build-info", - buildInfoObjCmd2, (void *)version, NULL); + Tcl_Command buildInfoCmd = Tcl_CreateObjCommand(interp, "::tcl::build-info", + buildInfoObjCmd, (void *)version, NULL); Tcl_GetCommandInfoFromToken(buildInfoCmd, &info2); - info2.objProc = buildInfoObjCmd; - info2.objClientData = (void *)version; + info2.objProc2 = buildInfoObjCmd2; + info2.objClientData2 = (void *)version; Tcl_SetCommandInfoFromToken(buildInfoCmd, &info2); if (TclTommath_Init(interp) != TCL_OK) { @@ -3306,6 +3306,15 @@ invokeObj2Command( return result; } +static int cmdWrapper2Proc(void *clientData, + Tcl_Interp *interp, + size_t objc, + Tcl_Obj *const objv[]) +{ + Command *cmdPtr = (Command *)clientData; + return cmdPtr->objProc(cmdPtr->objClientData, interp, objc, objv); +} + int Tcl_SetCommandInfoFromToken( Tcl_Command cmd, @@ -3351,8 +3360,19 @@ Tcl_SetCommandInfoFromToken( info->deleteProc = infoPtr->deleteProc; info->deleteData = infoPtr->deleteData; } else { - cmdPtr->deleteProc = infoPtr->deleteProc; - cmdPtr->deleteData = infoPtr->deleteData; + if ((infoPtr->objProc2 != NULL) && (infoPtr->objProc2 != cmdWrapper2Proc)) { + CmdWrapperInfo *info = (CmdWrapperInfo *)Tcl_Alloc(sizeof(CmdWrapperInfo)); + info->proc = infoPtr->objProc2; + info->clientData = infoPtr->objClientData2; + info->nreProc = NULL; + info->deleteProc = infoPtr->deleteProc; + info->deleteData = infoPtr->deleteData; + cmdPtr->deleteProc = cmdWrapperDeleteProc; + cmdPtr->deleteData = info; + } else { + cmdPtr->deleteProc = infoPtr->deleteProc; + cmdPtr->deleteData = infoPtr->deleteData; + } } return 1; } @@ -3407,15 +3427,6 @@ Tcl_GetCommandInfo( *---------------------------------------------------------------------- */ -static int cmdWrapper2Proc(void *clientData, - Tcl_Interp *interp, - size_t objc, - Tcl_Obj *const objv[]) -{ - Command *cmdPtr = (Command *)clientData; - return cmdPtr->objProc(cmdPtr->objClientData, interp, objc, objv); -} - int Tcl_GetCommandInfoFromToken( Tcl_Command cmd, -- cgit v0.12