From f21fa0e01c0fb463b0ec26f3b0cef1218243908a Mon Sep 17 00:00:00 2001 From: dkf Date: Fri, 29 Oct 2004 15:39:02 +0000 Subject: Allow ensembles to rewrite their subcommands' error messages to be more relevant to users. [Patch 1056864] Also patches to core to take advantage of this Also other general cleaning up of Tcl_WrongNumArgs usage --- ChangeLog | 27 +++++++++++++ generic/tclBasic.c | 15 ++++++- generic/tclClock.c | 108 ++++++++++++++++++++++++-------------------------- generic/tclConfig.c | 8 ++-- generic/tclIndexObj.c | 87 +++++++++++++++++++++++++++++++++++++--- generic/tclInt.h | 20 +++++++++- generic/tclNamesp.c | 80 ++++++++++++++++++++++++++++++------- generic/tclProc.c | 52 ++++++++++-------------- generic/tclVar.c | 14 +++---- library/tm.tcl | 23 +++-------- tests/clock.test | 4 +- tests/config.test | 10 ++--- tests/namespace.test | 33 ++++++++++++++- tests/proc-old.test | 6 +-- tests/tm.test | 6 +-- 15 files changed, 340 insertions(+), 153 deletions(-) diff --git a/ChangeLog b/ChangeLog index 4421e8d..6aa13f2 100644 --- a/ChangeLog +++ b/ChangeLog @@ -1,3 +1,30 @@ +2004-10-29 Donal K. Fellows + + * library/tm.tcl (::tcl::tm::*): Use the core proc engine to + generate the wrong-num-args error messages for the path ensemble. + + Ensembles can now (sometimes) rewrite the error messages of their + subcommands so they appear more like the arguments that the user + passed to the ensemble. Below is a description of changes involved + in doing this. + + * tests/namespace.test (namespace-50.*): Tests of ensemble + subcommand error message rewriting. + * generic/tclProc.c (TclObjInterpProc): Make procedures implement + their wrong-num-args message using Tcl_WrongNumArgs instead of + something baked-at-home. + * generic/tclNamesp.c (TclIsEnsemble, NsEnsembleImplementationCmd): + Added test of ensemble-hood (available to rest of core) and made + ensembles set up the rewriting for Tcl_WrongNumArgs to take + advantage of. + * generic/tclInt.h (Interp.ensembleRewrite): Extra fields. + * generic/tclIndexObj.c (Tcl_WrongNumArgs): Add knowledge of what + is going on in ensembles' command rewriting so this command can + generate the right error message itself. + * generic/tclBasic.c (Tcl_CreateInterp, TclEvalObjvInternal): + Added code to initialize (as empty) the rewriting fields and reset + them when we leak outside an ensemble implementation. + 2004-10-28 Miguel Sofer * generic/tclExecute.c (INST_START_CMD): diff --git a/generic/tclBasic.c b/generic/tclBasic.c index 0102390..2375920 100644 --- a/generic/tclBasic.c +++ b/generic/tclBasic.c @@ -13,7 +13,7 @@ * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclBasic.c,v 1.133 2004/10/24 22:25:12 dgp Exp $ + * RCS: @(#) $Id: tclBasic.c,v 1.134 2004/10/29 15:39:04 dkf Exp $ */ #include "tclInt.h" @@ -314,6 +314,14 @@ Tcl_CreateInterp() iPtr->stubTable = &tclStubs; /* + * Initialize the ensemble error message rewriting support. + */ + + iPtr->ensembleRewrite.sourceObjs = NULL; + iPtr->ensembleRewrite.numRemovedObjs = 0; + iPtr->ensembleRewrite.numInsertedObjs = 0; + + /* * TIP#143: Initialise the resource limit support. */ @@ -3031,6 +3039,11 @@ TclEvalObjvInternal(interp, objc, objv, command, length, flags) if (flags & TCL_EVAL_GLOBAL) { iPtr->varFramePtr = NULL; } + if (!(flags & TCL_EVAL_INVOKE) && + (iPtr->ensembleRewrite.sourceObjs != NULL) && + !TclIsEnsemble(cmdPtr)) { + iPtr->ensembleRewrite.sourceObjs = NULL; + } code = (*cmdPtr->objProc)(cmdPtr->objClientData, interp, objc, objv); iPtr->varFramePtr = savedVarFramePtr; } diff --git a/generic/tclClock.c b/generic/tclClock.c index 68b7142..ff63767 100644 --- a/generic/tclClock.c +++ b/generic/tclClock.c @@ -12,7 +12,7 @@ * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclClock.c,v 1.35 2004/10/21 03:53:04 kennykb Exp $ + * RCS: @(#) $Id: tclClock.c,v 1.36 2004/10/29 15:39:05 dkf Exp $ */ #include "tclInt.h" @@ -336,7 +336,6 @@ TclClockMktimeObjCmd( ClientData clientData, } - /*---------------------------------------------------------------------- * * TclClockClicksObjCmd -- @@ -356,7 +355,7 @@ TclClockMktimeObjCmd( ClientData clientData, */ int -TclClockClicksObjCmd( clientData, interp, objc, objv ) +TclClockClicksObjCmd(clientData, interp, objc, objv) ClientData clientData; /* Client data is unused */ Tcl_Interp* interp; /* Tcl interpreter */ int objc; /* Parameter count */ @@ -371,46 +370,43 @@ TclClockClicksObjCmd( clientData, interp, objc, objv ) int index = CLICKS_NATIVE; Tcl_Time now; - switch ( objc ) { - case 1: - break; - case 2: - if ( Tcl_GetIndexFromObj( interp, objv[1], clicksSwitches, - "option", 0, &index) != TCL_OK ) { - return TCL_ERROR; - } - break; - default: - Tcl_WrongNumArgs( interp, 1, objv, "?option?" ); + switch (objc) { + case 1: + break; + case 2: + if (Tcl_GetIndexFromObj(interp, objv[1], clicksSwitches, "option", 0, + &index) != TCL_OK) { return TCL_ERROR; + } + break; + default: + Tcl_WrongNumArgs(interp, 1, objv, "?option?"); + return TCL_ERROR; } - switch ( index ) { - case CLICKS_MILLIS: - Tcl_GetTime( &now ); - Tcl_SetObjResult( interp, - Tcl_NewWideIntObj( (Tcl_WideInt) now.sec * 1000 - + now.usec / 1000 ) ); - break; - case CLICKS_NATIVE: + switch (index) { + case CLICKS_MILLIS: + Tcl_GetTime(&now); + Tcl_SetObjResult(interp, Tcl_NewWideIntObj( (Tcl_WideInt) + now.sec * 1000 + now.usec / 1000 ) ); + break; + case CLICKS_NATIVE: #if 0 - /* - * The following code will be used once this is incorporated - * into Tcl. But TEA bugs prevent it for right now. :( - * So we fall through this case and return the microseconds - * instead. - */ - Tcl_SetObjResult( interp, - Tcl_NewWideIntObj( (Tcl_WideInt) TclpGetClicks() ) ); - break; + /* + * The following code will be used once this is incorporated + * into Tcl. But TEA bugs prevent it for right now. :( + * So we fall through this case and return the microseconds + * instead. + */ + Tcl_SetObjResult(interp, Tcl_NewWideIntObj( (Tcl_WideInt) + TclpGetClicks())); + break; #endif - case CLICKS_MICROS: - Tcl_GetTime( &now ); - Tcl_SetObjResult( interp, - Tcl_NewWideIntObj( ( (Tcl_WideInt) now.sec - * 1000000 ) - + now.usec ) ); - break; + case CLICKS_MICROS: + Tcl_GetTime(&now); + Tcl_SetObjResult(interp, Tcl_NewWideIntObj( + ((Tcl_WideInt) now.sec * 1000000) + now.usec)); + break; } return TCL_OK; @@ -435,21 +431,20 @@ TclClockClicksObjCmd( clientData, interp, objc, objv ) */ int -TclClockMillisecondsObjCmd( clientData, interp, objc, objv ) +TclClockMillisecondsObjCmd(clientData, interp, objc, objv) ClientData clientData; /* Client data is unused */ Tcl_Interp* interp; /* Tcl interpreter */ int objc; /* Parameter count */ Tcl_Obj* CONST* objv; /* Parameter values */ { Tcl_Time now; - if ( objc != 1 ) { - Tcl_WrongNumArgs( interp, 1, objv, "" ); + if (objc != 1) { + Tcl_WrongNumArgs(interp, 1, objv, NULL); return TCL_ERROR; } - Tcl_GetTime( &now ); - Tcl_SetObjResult( interp, - Tcl_NewWideIntObj( (Tcl_WideInt) now.sec * 1000 - + now.usec / 1000 ) ); + Tcl_GetTime(&now); + Tcl_SetObjResult(interp, Tcl_NewWideIntObj( (Tcl_WideInt) + now.sec * 1000 + now.usec / 1000)); return TCL_OK; } @@ -472,21 +467,20 @@ TclClockMillisecondsObjCmd( clientData, interp, objc, objv ) */ int -TclClockMicrosecondsObjCmd( clientData, interp, objc, objv ) +TclClockMicrosecondsObjCmd(clientData, interp, objc, objv) ClientData clientData; /* Client data is unused */ Tcl_Interp* interp; /* Tcl interpreter */ int objc; /* Parameter count */ Tcl_Obj* CONST* objv; /* Parameter values */ { Tcl_Time now; - if ( objc != 1 ) { - Tcl_WrongNumArgs( interp, 1, objv, "" ); + if (objc != 1) { + Tcl_WrongNumArgs(interp, 1, objv, NULL); return TCL_ERROR; } - Tcl_GetTime( &now ); - Tcl_SetObjResult( interp, - Tcl_NewWideIntObj( ( (Tcl_WideInt) now.sec * 1000000 ) - + now.usec ) ); + Tcl_GetTime(&now); + Tcl_SetObjResult(interp, Tcl_NewWideIntObj( + ((Tcl_WideInt) now.sec * 1000000) + now.usec)); return TCL_OK; } @@ -509,19 +503,19 @@ TclClockMicrosecondsObjCmd( clientData, interp, objc, objv ) */ int -TclClockSecondsObjCmd( clientData, interp, objc, objv ) +TclClockSecondsObjCmd(clientData, interp, objc, objv) ClientData clientData; /* Client data is unused */ Tcl_Interp* interp; /* Tcl interpreter */ int objc; /* Parameter count */ Tcl_Obj* CONST* objv; /* Parameter values */ { Tcl_Time now; - if ( objc != 1 ) { - Tcl_WrongNumArgs( interp, 1, objv, "" ); + if (objc != 1) { + Tcl_WrongNumArgs(interp, 1, objv, NULL); return TCL_ERROR; } - Tcl_GetTime( &now ); - Tcl_SetObjResult( interp, Tcl_NewWideIntObj( (Tcl_WideInt) now.sec ) ); + Tcl_GetTime(&now); + Tcl_SetObjResult(interp, Tcl_NewWideIntObj((Tcl_WideInt) now.sec)); return TCL_OK; } diff --git a/generic/tclConfig.c b/generic/tclConfig.c index 3cd5813..4daf92f 100644 --- a/generic/tclConfig.c +++ b/generic/tclConfig.c @@ -9,7 +9,7 @@ * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclConfig.c,v 1.5 2003/12/24 04:18:19 davygrvy Exp $ + * RCS: @(#) $Id: tclConfig.c,v 1.6 2004/10/29 15:39:05 dkf Exp $ */ #include "tclInt.h" @@ -209,7 +209,7 @@ QueryConfigObjCmd(clientData, interp, objc, objv) }; if ((objc < 2) || (objc > 3)) { - Tcl_WrongNumArgs (interp, 0, NULL, "list | get key"); + Tcl_WrongNumArgs(interp, 1, objv, "subcommand ?argument?"); return TCL_ERROR; } if (Tcl_GetIndexFromObj(interp, objv[1], subcmdStrings, @@ -228,7 +228,7 @@ QueryConfigObjCmd(clientData, interp, objc, objv) switch ((enum subcmds) index) { case CFG_GET: if (objc != 3) { - Tcl_WrongNumArgs(interp, 0, NULL, "get key"); + Tcl_WrongNumArgs(interp, 1, objv, "get key"); return TCL_ERROR; } @@ -243,7 +243,7 @@ QueryConfigObjCmd(clientData, interp, objc, objv) case CFG_LIST: if (objc != 2) { - Tcl_WrongNumArgs(interp, 0, NULL, "list"); + Tcl_WrongNumArgs(interp, 1, objv, "list"); return TCL_ERROR; } diff --git a/generic/tclIndexObj.c b/generic/tclIndexObj.c index 22397af..cd4dc44 100644 --- a/generic/tclIndexObj.c +++ b/generic/tclIndexObj.c @@ -10,7 +10,7 @@ * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclIndexObj.c,v 1.20 2004/10/06 14:59:02 dgp Exp $ + * RCS: @(#) $Id: tclIndexObj.c,v 1.21 2004/10/29 15:39:05 dkf Exp $ */ #include "tclInt.h" @@ -445,12 +445,69 @@ Tcl_WrongNumArgs(interp, objc, objv, message) * message may be NULL. */ { Tcl_Obj *objPtr; - int i; + int i, len, elemLen, flags; register IndexRep *indexRep; + Interp *iPtr = (Interp *) interp; + char *elementStr; TclNewObj(objPtr); - Tcl_SetObjResult(interp, objPtr); Tcl_AppendToObj(objPtr, "wrong # args: should be \"", -1); + + /* + * Check to see if we are processing an ensemble implementation, + * and if so rewrite the results in terms of how the ensemble was + * invoked. + */ + + if (iPtr->ensembleRewrite.sourceObjs != NULL) { + /* + * We only know how to do rewriting if all the replaced + * objects are actually arguments (in objv) to this function. + * Otherwise it just gets too complicated... + */ + + if (objc >= iPtr->ensembleRewrite.numInsertedObjs) { + objv += iPtr->ensembleRewrite.numInsertedObjs; + objc -= iPtr->ensembleRewrite.numInsertedObjs; + /* + * We assume no object is of index type. + */ + for (i=0 ; iensembleRewrite.numRemovedObjs ; i++) { + /* + * Add the element, quoting it if necessary. + */ + + elementStr = Tcl_GetStringFromObj( + iPtr->ensembleRewrite.sourceObjs[i], &elemLen); + len = Tcl_ScanCountedElement(elementStr, elemLen, &flags); + if (len != elemLen) { + char *quotedElementStr = ckalloc((unsigned) len); + len = Tcl_ConvertCountedElement(elementStr, elemLen, + quotedElementStr, flags); + Tcl_AppendToObj(objPtr, quotedElementStr, len); + ckfree(quotedElementStr); + } else { + Tcl_AppendToObj(objPtr, elementStr, elemLen); + } + + /* + * Add a space if the word is not the last one (which + * has a moderately complex condition here). + */ + + if ((i < (iPtr->ensembleRewrite.numRemovedObjs - 1)) + || objc || message) { + Tcl_AppendStringsToObj(objPtr, " ", (char *) NULL); + } + } + } + } + + /* + * Now add the arguments (other than those rewritten) that the + * caller took from its calling context. + */ + for (i = 0; i < objc; i++) { /* * If the object is an index type use the index table which allows @@ -462,8 +519,21 @@ Tcl_WrongNumArgs(interp, objc, objv, message) indexRep = (IndexRep *) objv[i]->internalRep.otherValuePtr; Tcl_AppendStringsToObj(objPtr, EXPAND_OF(indexRep), (char *) NULL); } else { - Tcl_AppendStringsToObj(objPtr, Tcl_GetString(objv[i]), - (char *) NULL); + /* + * Quote the argument if it contains spaces (Bug 942757). + */ + + elementStr = Tcl_GetStringFromObj(objv[i], &elemLen); + len = Tcl_ScanCountedElement(elementStr, elemLen, &flags); + if (len != elemLen) { + char *quotedElementStr = ckalloc((unsigned) len); + len = Tcl_ConvertCountedElement(elementStr, elemLen, + quotedElementStr, flags); + Tcl_AppendToObj(objPtr, quotedElementStr, len); + ckfree(quotedElementStr); + } else { + Tcl_AppendToObj(objPtr, elementStr, elemLen); + } } /* @@ -475,8 +545,15 @@ Tcl_WrongNumArgs(interp, objc, objv, message) } } + /* + * Add any trailing message bits and set the resulting string as + * the interpreter result. Caller is responsible for reporting + * this as an actual error. + */ + if (message) { Tcl_AppendStringsToObj(objPtr, message, (char *) NULL); } Tcl_AppendStringsToObj(objPtr, "\"", (char *) NULL); + Tcl_SetObjResult(interp, objPtr); } diff --git a/generic/tclInt.h b/generic/tclInt.h index ca5727c..c4182db 100644 --- a/generic/tclInt.h +++ b/generic/tclInt.h @@ -12,7 +12,7 @@ * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclInt.h,v 1.189 2004/10/27 17:13:58 davygrvy Exp $ + * RCS: @(#) $Id: tclInt.h,v 1.190 2004/10/29 15:39:05 dkf Exp $ */ #ifndef _TCLINT @@ -1400,6 +1400,23 @@ typedef struct Interp { } limit; /* + * Information for improved default error generation from + * ensembles (TIP#112). + */ + + struct { + Tcl_Obj * CONST *sourceObjs; + /* What arguments were actually input into + * the *root* ensemble command? (Nested + * ensembles don't rewrite this.) NULL if + * we're not processing an ensemble. */ + int numRemovedObjs; /* How many arguments have been stripped off + * because of ensemble processing. */ + int numInsertedObjs; /* How many of the current arguments were + * inserted by an ensemble. */ + } ensembleRewrite; + + /* * Statistical information about the bytecode compiler and interpreter's * operation. */ @@ -1949,6 +1966,7 @@ EXTERN int TclpDlopen _ANSI_ARGS_((Tcl_Interp *interp, Tcl_FSUnloadFileProc **unloadProcPtr)); EXTERN int TclpUtime _ANSI_ARGS_((Tcl_Obj *pathPtr, struct utimbuf *tval)); +EXTERN int TclIsEnsemble _ANSI_ARGS_((Command *cmdPtr)); /* *---------------------------------------------------------------- diff --git a/generic/tclNamesp.c b/generic/tclNamesp.c index 38c5dd7..34faf71 100644 --- a/generic/tclNamesp.c +++ b/generic/tclNamesp.c @@ -21,7 +21,7 @@ * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclNamesp.c,v 1.63 2004/10/22 15:46:37 dkf Exp $ + * RCS: @(#) $Id: tclNamesp.c,v 1.64 2004/10/29 15:39:06 dkf Exp $ */ #include "tclInt.h" @@ -3367,8 +3367,7 @@ NamespaceExportCmd(dummy, interp, objc, objv) int firstArg, patternCt, i, result; if (objc < 2) { - Tcl_WrongNumArgs(interp, 2, objv, - "?-clear? ?pattern pattern...?"); + Tcl_WrongNumArgs(interp, 2, objv, "?-clear? ?pattern pattern...?"); return TCL_ERROR; } @@ -3526,8 +3525,7 @@ NamespaceImportCmd(dummy, interp, objc, objv) int firstArg; if (objc < 2) { - Tcl_WrongNumArgs(interp, 2, objv, - "?-force? ?pattern pattern...?"); + Tcl_WrongNumArgs(interp, 2, objv, "?-force? ?pattern pattern...?"); return TCL_ERROR; } @@ -4863,6 +4861,37 @@ FindEnsemble(interp, cmdNameObj, flags) /* *---------------------------------------------------------------------- * + * TclIsEnsemble -- + * + * Simple test for ensemble-hood that takes into account imported + * ensemble commands as well. + * + * Results: + * Boolean value + * + * Side effects: + * None + * + *---------------------------------------------------------------------- + */ + +int +TclIsEnsemble(cmdPtr) + Command *cmdPtr; +{ + if (cmdPtr->objProc == NsEnsembleImplementationCmd) { + return 1; + } + cmdPtr = (Command *) TclGetOriginalCommand((Tcl_Command) cmdPtr); + if (cmdPtr == NULL || cmdPtr->objProc != NsEnsembleImplementationCmd) { + return 0; + } + return 1; +} + +/* + *---------------------------------------------------------------------- + * * NsEnsembleImplementationCmd -- * * Implements an ensemble of commands (being those exported by a @@ -5045,15 +5074,38 @@ NsEnsembleImplementationCmd(clientData, interp, objc, objv) Tcl_IncrRefCount(prefixObj); runResultingSubcommand: - Tcl_ListObjGetElements(NULL, prefixObj, &prefixObjc, &prefixObjv); - tempObjv = (Tcl_Obj **) ckalloc(sizeof(Tcl_Obj *)*(objc-2+prefixObjc)); - memcpy(tempObjv, prefixObjv, sizeof(Tcl_Obj *) * prefixObjc); - memcpy(tempObjv+prefixObjc, objv+2, sizeof(Tcl_Obj *) * (objc-2)); - result = Tcl_EvalObjv(interp, objc-2+prefixObjc, tempObjv, - TCL_EVAL_INVOKE); - Tcl_DecrRefCount(prefixObj); - ckfree((char *)tempObjv); - return result; + { + Interp *iPtr = (Interp *) interp; + int isRootEnsemble = (iPtr->ensembleRewrite.sourceObjs == NULL); + + Tcl_ListObjGetElements(NULL, prefixObj, &prefixObjc, &prefixObjv); + if (isRootEnsemble) { + iPtr->ensembleRewrite.sourceObjs = objv; + iPtr->ensembleRewrite.numRemovedObjs = 2; + iPtr->ensembleRewrite.numInsertedObjs = prefixObjc; + } else { + int ni = iPtr->ensembleRewrite.numInsertedObjs; + if (ni < 2) { + iPtr->ensembleRewrite.numRemovedObjs += 2 - ni; + iPtr->ensembleRewrite.numInsertedObjs += prefixObjc - 1; + } else { + iPtr->ensembleRewrite.numInsertedObjs += prefixObjc - 2; + } + } + tempObjv = (Tcl_Obj **) ckalloc(sizeof(Tcl_Obj *)*(objc-2+prefixObjc)); + memcpy(tempObjv, prefixObjv, sizeof(Tcl_Obj *) * prefixObjc); + memcpy(tempObjv+prefixObjc, objv+2, sizeof(Tcl_Obj *) * (objc-2)); + result = Tcl_EvalObjv(interp, objc-2+prefixObjc, tempObjv, + TCL_EVAL_INVOKE); + Tcl_DecrRefCount(prefixObj); + ckfree((char *)tempObjv); + if (isRootEnsemble) { + iPtr->ensembleRewrite.sourceObjs = NULL; + iPtr->ensembleRewrite.numRemovedObjs = 0; + iPtr->ensembleRewrite.numInsertedObjs = 0; + } + return result; + } unknownOrAmbiguousSubcommand: /* diff --git a/generic/tclProc.c b/generic/tclProc.c index d35ba32..adca38d 100644 --- a/generic/tclProc.c +++ b/generic/tclProc.c @@ -10,7 +10,7 @@ * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclProc.c,v 1.63 2004/10/22 13:48:58 dkf Exp $ + * RCS: @(#) $Id: tclProc.c,v 1.64 2004/10/29 15:39:06 dkf Exp $ */ #include "tclInt.h" @@ -1043,47 +1043,39 @@ TclObjInterpProc(clientData, interp, objc, objv) localPtr = localPtr->nextPtr; } if (argCt > 0) { - Tcl_Obj *objResult; - int len, flags; + Tcl_Obj **desiredObjs, *argObj; - incorrectArgs: + incorrectArgs: /* - * Build up equivalent to Tcl_WrongNumArgs message for proc + * Build up desired argument list for Tcl_WrongNumArgs */ - Tcl_ResetResult(interp); - TclNewObj(objResult); - Tcl_AppendToObj(objResult, "wrong # args: should be \"", -1); - - /* - * Quote the proc name if it contains spaces (Bug 942757). - */ - - len = Tcl_ScanCountedElement(procName, nameLen, &flags); - if (len != nameLen) { - char *procName1 = ckalloc((unsigned) len); - len = Tcl_ConvertCountedElement(procName, nameLen, procName1, flags); - Tcl_AppendToObj(objResult, procName1, len); - ckfree(procName1); - } else { - Tcl_AppendToObj(objResult, procName, len); - } - + desiredObjs = (Tcl_Obj **) + ckalloc(sizeof(Tcl_Obj *) * (unsigned)(numArgs+1)); + desiredObjs[0] = objv[0]; localPtr = procPtr->firstLocalPtr; - for (i = 1; i <= numArgs; i++) { + for (i=1 ; i<=numArgs ; i++) { + TclNewObj(argObj); if (localPtr->defValuePtr != NULL) { - Tcl_AppendStringsToObj(objResult, - " ?", localPtr->name, "?", (char *) NULL); + Tcl_AppendStringsToObj(argObj, + "?", localPtr->name, "?", (char *) NULL); + } else if ((i==numArgs) && (strcmp(localPtr->name, "args")==0)) { + Tcl_AppendStringsToObj(argObj, "...", (char *) NULL); } else { - Tcl_AppendStringsToObj(objResult, - " ", localPtr->name, (char *) NULL); + Tcl_AppendStringsToObj(argObj, localPtr->name, (char *) NULL); } + desiredObjs[i] = argObj; localPtr = localPtr->nextPtr; } - Tcl_AppendStringsToObj(objResult, "\"", (char *) NULL); - Tcl_SetObjResult(interp, objResult); + Tcl_ResetResult(interp); + Tcl_WrongNumArgs(interp, numArgs+1, desiredObjs, NULL); result = TCL_ERROR; + + for (i=1 ; i<=numArgs ; i++) { + TclDecrRefCount(desiredObjs[i]); + } + ckfree((char *) desiredObjs); goto procDone; } diff --git a/generic/tclVar.c b/generic/tclVar.c index 7dc0bfe..6162fc3 100644 --- a/generic/tclVar.c +++ b/generic/tclVar.c @@ -15,7 +15,7 @@ * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclVar.c,v 1.97 2004/10/26 16:19:58 msofer Exp $ + * RCS: @(#) $Id: tclVar.c,v 1.98 2004/10/29 15:39:06 dkf Exp $ */ #ifdef STDC_HEADERS @@ -2729,8 +2729,7 @@ Tcl_ArrayObjCmd(dummy, interp, objc, objv) ArraySearch *searchPtr; if (objc != 4) { - Tcl_WrongNumArgs(interp, 2, objv, - "arrayName searchId"); + Tcl_WrongNumArgs(interp, 2, objv, "arrayName searchId"); return TCL_ERROR; } if (notArray) { @@ -2762,8 +2761,7 @@ Tcl_ArrayObjCmd(dummy, interp, objc, objv) ArraySearch *searchPtr, *prevPtr; if (objc != 4) { - Tcl_WrongNumArgs(interp, 2, objv, - "arrayName searchId"); + Tcl_WrongNumArgs(interp, 2, objv, "arrayName searchId"); return TCL_ERROR; } if (notArray) { @@ -2914,8 +2912,7 @@ Tcl_ArrayObjCmd(dummy, interp, objc, objv) mode = OPT_GLOB; if ((objc < 3) || (objc > 5)) { - Tcl_WrongNumArgs(interp, 2, objv, - "arrayName ?mode? ?pattern?"); + Tcl_WrongNumArgs(interp, 2,objv, "arrayName ?mode? ?pattern?"); return TCL_ERROR; } if (notArray) { @@ -2975,8 +2972,7 @@ Tcl_ArrayObjCmd(dummy, interp, objc, objv) Tcl_HashEntry *hPtr; if (objc != 4) { - Tcl_WrongNumArgs(interp, 2, objv, - "arrayName searchId"); + Tcl_WrongNumArgs(interp, 2, objv, "arrayName searchId"); return TCL_ERROR; } if (notArray) { diff --git a/library/tm.tcl b/library/tm.tcl index 491d25d..14dab45 100644 --- a/library/tm.tcl +++ b/library/tm.tcl @@ -79,7 +79,7 @@ namespace eval ::tcl::tm { # paths to search for Tcl Modules. The subcommand 'list' has no # sideeffects. -proc ::tcl::tm::add {args} { +proc ::tcl::tm::add {path args} { # PART OF THE ::tcl::tm::path ENSEMBLE # # The path is added at the head to the list of module paths. @@ -91,11 +91,6 @@ proc ::tcl::tm::add {args} { # If the path is already present as is no error will be raised and # no action will be taken. - if {[llength $args] == 0} { - return -code error \ - "wrong # args: should be \"::tcl::tm::path add path ?path ...?\"" - } - variable paths # We use a copy of the path as source during validation, and @@ -107,7 +102,7 @@ proc ::tcl::tm::add {args} { # paths to the official state var. set newpaths $paths - foreach p $args { + foreach p [linsert $args 0 $path] { if {$p in $newpaths} { # Ignore a path already on the list. continue @@ -148,20 +143,15 @@ proc ::tcl::tm::add {args} { return } -proc ::tcl::tm::remove {args} { +proc ::tcl::tm::remove {path args} { # PART OF THE ::tcl::tm::path ENSEMBLE # # Removes the path from the list of module paths. The command is # silently ignored if the path is not on the list. - if {[llength $args] == 0} { - return -code error \ - "wrong # args: should be \"::tcl::tm::path remove path ?path ...?\"" - } - variable paths - foreach p $args { + foreach p [linsert $args 0 $path] { set pos [lsearch -exact $paths $p] if {$pos >= 0} { set paths [lreplace $paths $pos $pos] @@ -169,12 +159,9 @@ proc ::tcl::tm::remove {args} { } } -proc ::tcl::tm::list {args} { +proc ::tcl::tm::list {} { # PART OF THE ::tcl::tm::path ENSEMBLE - if {[llength $args] != 0} { - return -code error "wrong # args: should be \"::tcl::tm::path list\"" - } variable paths return $paths } diff --git a/tests/clock.test b/tests/clock.test index 746e26a..20fec79 100644 --- a/tests/clock.test +++ b/tests/clock.test @@ -11,7 +11,7 @@ # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # -# RCS: @(#) $Id: clock.test,v 1.49 2004/10/28 00:04:33 dgp Exp $ +# RCS: @(#) $Id: clock.test,v 1.50 2004/10/29 15:39:07 dkf Exp $ if {[lsearch [namespace children] ::tcltest] == -1} { package require tcltest 2 @@ -35223,7 +35223,7 @@ test clock-35.1 {clock seconds tests} { } {} test clock-35.2 {clock seconds tests} { list [catch {clock seconds foo} msg] $msg -} {1 {wrong # args: should be "::tcl::clock::seconds "}} +} {1 {wrong # args: should be "clock seconds"}} test clock-35.3 {clock seconds tests} { set start [clock seconds] after 2000 diff --git a/tests/config.test b/tests/config.test index 8c05a7e..2023d9c 100644 --- a/tests/config.test +++ b/tests/config.test @@ -12,7 +12,7 @@ # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # -# RCS: @(#) $Id: config.test,v 1.3 2004/05/19 12:22:13 dkf Exp $ +# RCS: @(#) $Id: config.test,v 1.4 2004/10/29 15:39:10 dkf Exp $ if {[lsearch [namespace children] ::tcltest] == -1} { package require tcltest @@ -35,7 +35,7 @@ test pkgconfig-1.3 {query value multiple times} { test pkgconfig-2.0 {error: missing subcommand} { catch {::tcl::pkgconfig} msg set msg -} {wrong # args: should be "list | get key"} +} {wrong # args: should be "::tcl::pkgconfig subcommand ?argument?"} test pkgconfig-2.1 {error: illegal subcommand} { catch {::tcl::pkgconfig foo} msg set msg @@ -43,11 +43,11 @@ test pkgconfig-2.1 {error: illegal subcommand} { test pkgconfig-2.2 {error: list with arguments} { catch {::tcl::pkgconfig list foo} msg set msg -} {wrong # args: should be "list"} +} {wrong # args: should be "::tcl::pkgconfig list"} test pkgconfig-2.3 {error: get without arguments} { catch {::tcl::pkgconfig get} msg set msg -} {wrong # args: should be "get key"} +} {wrong # args: should be "::tcl::pkgconfig get key"} test pkgconfig-2.4 {error: query unknown key} { catch {::tcl::pkgconfig get foo} msg set msg @@ -55,7 +55,7 @@ test pkgconfig-2.4 {error: query unknown key} { test pkgconfig-2.5 {error: query with to many arguments} { catch {::tcl::pkgconfig get foo bar} msg set msg -} {wrong # args: should be "list | get key"} +} {wrong # args: should be "::tcl::pkgconfig subcommand ?argument?"} # cleanup ::tcltest::cleanupTests diff --git a/tests/namespace.test b/tests/namespace.test index 4180ca5..9341ecf 100644 --- a/tests/namespace.test +++ b/tests/namespace.test @@ -11,7 +11,7 @@ # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # -# RCS: @(#) $Id: namespace.test,v 1.42 2004/10/28 00:04:39 dgp Exp $ +# RCS: @(#) $Id: namespace.test,v 1.43 2004/10/29 15:39:10 dkf Exp $ if {[lsearch [namespace children] ::tcltest] == -1} { package require tcltest 2 @@ -1925,6 +1925,37 @@ test namespace-49.1 {ensemble subcommand caching} -body { rename x {} } +test namespace-50.1 {ensembles affect proc arguments error messages} -body { + namespace ens cre -command a -map {b {bb foo}} + proc bb {c d {e f} args} {list $c $args} + a b +} -returnCodes error -result "wrong # args: should be \"a b d ?e? ...\"" -cleanup { + rename a {} + rename bb {} +} +test namespace-50.2 {ensembles affect WrongNumArgs error messages} -body { + namespace ens cre -command a -map {b {string is}} + a b boolean +} -returnCodes error -result "wrong # args: should be \"a b class ?-strict? ?-failindex var? str\"" -cleanup { + rename a {} +} +test namespace-50.3 {chained ensembles affect error messages} -body { + namespace ens cre -command a -map {b c} + namespace ens cre -command c -map {d e} + proc e f {} + a b d +} -returnCodes error -result "wrong # args: should be \"a b d f\"" -cleanup { + rename a {} +} +test namespace-50.4 {chained ensembles affect error messages} -body { + namespace ens cre -command a -map {b {c d}} + namespace ens cre -command c -map {d {e f}} + proc e f {} + a b d +} -returnCodes error -result "wrong # args: should be \"a b\"" -cleanup { + rename a {} +} + # cleanup catch {rename cmd1 {}} catch {unset l} diff --git a/tests/proc-old.test b/tests/proc-old.test index 8203601..860279e 100644 --- a/tests/proc-old.test +++ b/tests/proc-old.test @@ -14,7 +14,7 @@ # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # -# RCS: @(#) $Id: proc-old.test,v 1.12 2004/05/19 12:56:54 dkf Exp $ +# RCS: @(#) $Id: proc-old.test,v 1.13 2004/10/29 15:39:10 dkf Exp $ if {[lsearch [namespace children] ::tcltest] == -1} { package require tcltest @@ -233,7 +233,7 @@ test proc-old-30.12 {arguments and defaults} { return [list $x $y $args] } list [catch {tproc} msg] $msg -} {1 {wrong # args: should be "tproc x ?y? args"}} +} {1 {wrong # args: should be "tproc x ?y? ..."}} test proc-old-4.1 {variable numbers of arguments} { proc tproc args {return $args} @@ -258,7 +258,7 @@ test proc-old-4.5 {variable numbers of arguments} { test proc-old-4.6 {variable numbers of arguments} { proc tproc {x missing args} {return $args} list [catch {tproc 1} msg] $msg -} {1 {wrong # args: should be "tproc x missing args"}} +} {1 {wrong # args: should be "tproc x missing ..."}} test proc-old-5.1 {error conditions} { list [catch {proc} msg] $msg diff --git a/tests/tm.test b/tests/tm.test index 91329a2..9327530 100644 --- a/tests/tm.test +++ b/tests/tm.test @@ -6,7 +6,7 @@ # Copyright (c) 2004 by Donal K. Fellows. # All rights reserved. # -# RCS: @(#) $Id: tm.test,v 1.3 2004/10/27 17:01:46 andreas_kupries Exp $ +# RCS: @(#) $Id: tm.test,v 1.4 2004/10/29 15:39:10 dkf Exp $ package require Tcl 8.5 if {"::tcltest" ni [namespace children]} { @@ -23,10 +23,10 @@ test tm-1.2 {tm: path command syntax} -returnCodes error -body { } -result {unknown or ambiguous subcommand "foo": must be add, list, or remove} test tm-1.3 {tm: path command syntax} -returnCodes error -body { ::tcl::tm::path add -} -result "wrong # args: should be \"::tcl::tm::path add path ?path ...?\"" +} -result "wrong # args: should be \"::tcl::tm::path add path ...\"" test tm-1.4 {tm: path command syntax} -returnCodes error -body { ::tcl::tm::path remove -} -result "wrong # args: should be \"::tcl::tm::path remove path ?path ...?\"" +} -result "wrong # args: should be \"::tcl::tm::path remove path ...\"" test tm-1.5 {tm: path command syntax} -returnCodes error -body { ::tcl::tm::path list foobar } -result "wrong # args: should be \"::tcl::tm::path list\"" -- cgit v0.12