From 21d8621d11bcad78438d51a17dd685e4c8c3c557 Mon Sep 17 00:00:00 2001 From: dkf Date: Sun, 7 Jul 2013 11:15:08 +0000 Subject: Added a mechanism for discovering the "type" of a command. --- generic/tclBasic.c | 92 ++++++++++++++++++++++++++++++++++++++++++++++++++- generic/tclCmdIL.c | 47 ++++++++++++++++++++++++++ generic/tclEnsemble.c | 41 +++++++++++------------ generic/tclInt.h | 15 +++++++++ generic/tclInterp.c | 33 ++++++++---------- generic/tclNamesp.c | 10 +++--- generic/tclOO.c | 29 +++++++--------- 7 files changed, 203 insertions(+), 64 deletions(-) diff --git a/generic/tclBasic.c b/generic/tclBasic.c index b2a505a..94697b2 100644 --- a/generic/tclBasic.c +++ b/generic/tclBasic.c @@ -74,7 +74,18 @@ typedef struct { } CancelInfo; static Tcl_HashTable cancelTable; static int cancelTableInitialized = 0; /* 0 means not yet initialized. */ -TCL_DECLARE_MUTEX(cancelLock) +TCL_DECLARE_MUTEX(cancelLock); + +/* + * Table used to map command implementation functions to a human-readable type + * name, for [info type]. The keys in the table are function addresses, and + * the values in the table are static char* containing strings in Tcl's + * internal encoding (almost UTF-8). + */ + +static Tcl_HashTable commandTypeTable; +static int commandTypeInit = 0; +TCL_DECLARE_MUTEX(commandTypeLock); /* * Declarations for managing contexts for non-recursive coroutines. Contexts @@ -430,6 +441,13 @@ TclFinalizeEvaluation(void) cancelTableInitialized = 0; } Tcl_MutexUnlock(&cancelLock); + + Tcl_MutexLock(&commandTypeLock); + if (commandTypeInit) { + Tcl_DeleteHashTable(&commandTypeTable); + commandTypeInit = 0; + } + Tcl_MutexUnlock(&commandTypeLock); } /* @@ -507,6 +525,16 @@ Tcl_CreateInterp(void) Tcl_MutexUnlock(&cancelLock); } + if (commandTypeInit == 0) { + TclRegisterCommandTypeName(TclObjInterpProc, "proc"); + TclRegisterCommandTypeName(TclEnsembleImplementationCmd, "ensemble"); + TclRegisterCommandTypeName(TclAliasObjCmd, "alias"); + TclRegisterCommandTypeName(TclSlaveObjCmd, "slave"); + TclRegisterCommandTypeName(TclInvokeImportedCmd, "import"); + TclRegisterCommandTypeName(TclOOPublicObjectCmd, "object"); + TclRegisterCommandTypeName(TclOOPrivateObjectCmd, "privateObject"); + } + /* * Initialize support for namespaces and create the global namespace * (whose name is ""; an alias is "::"). This also initializes the Tcl @@ -995,6 +1023,68 @@ DeleteOpCmdClientData( } /* + * --------------------------------------------------------------------- + * + * TclRegisterCommandTypeName, TclGetCommandTypeName -- + * + * Command type registration and lookup mechanism. Everything is keyed by + * the Tcl_ObjCmdProc for the command, and that is used as the *key* into + * the hash table that maps to constant strings that are names. (It is + * recommended that those names be ASCII.) + * + * --------------------------------------------------------------------- + */ + +void +TclRegisterCommandTypeName( + Tcl_ObjCmdProc *implementationProc, + const char *nameStr) +{ + Tcl_HashEntry *hPtr; + + Tcl_MutexLock(&commandTypeLock); + if (commandTypeInit == 0) { + Tcl_InitHashTable(&commandTypeTable, TCL_ONE_WORD_KEYS); + commandTypeInit = 1; + } + if (nameStr != NULL) { + int isNew; + + hPtr = Tcl_CreateHashEntry(&commandTypeTable, + (void *) implementationProc, &isNew); + Tcl_SetHashValue(hPtr, (void *) nameStr); + } else { + hPtr = Tcl_FindHashEntry(&commandTypeTable, + (void *) implementationProc); + if (hPtr != NULL) { + Tcl_DeleteHashEntry(hPtr); + } + } + Tcl_MutexUnlock(&commandTypeLock); +} + +const char * +TclGetCommandTypeName( + Tcl_Command command) +{ + Command *cmdPtr = (Command *) command; + const char *name = "native"; + + Tcl_MutexLock(&commandTypeLock); + if (commandTypeInit) { + Tcl_HashEntry *hPtr = Tcl_FindHashEntry(&commandTypeTable, + (void *) cmdPtr->objProc); + + if (hPtr && Tcl_GetHashValue(hPtr)) { + name = (const char *) Tcl_GetHashValue(hPtr); + } + } + Tcl_MutexUnlock(&commandTypeLock); + + return name; +} + +/* *---------------------------------------------------------------------- * * TclHideUnsafeCommands -- diff --git a/generic/tclCmdIL.c b/generic/tclCmdIL.c index 0e33392..1b6f9c1 100644 --- a/generic/tclCmdIL.c +++ b/generic/tclCmdIL.c @@ -146,6 +146,8 @@ static int InfoScriptCmd(ClientData dummy, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); static int InfoSharedlibCmd(ClientData dummy, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); +static int InfoTypeCmd(ClientData dummy, Tcl_Interp *interp, + int objc, Tcl_Obj *const objv[]); static int InfoTclVersionCmd(ClientData dummy, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); static SortElement * MergeLists(SortElement *leftPtr, SortElement *rightPtr, @@ -184,6 +186,7 @@ static const EnsembleImplMap defaultInfoMap[] = { {"script", InfoScriptCmd, TclCompileBasic0Or1ArgCmd, NULL, NULL, 0}, {"sharedlibextension", InfoSharedlibCmd, TclCompileBasic0ArgCmd, NULL, NULL, 0}, {"tclversion", InfoTclVersionCmd, TclCompileBasic0ArgCmd, NULL, NULL, 0}, + {"type", InfoTypeCmd, TclCompileBasic1ArgCmd, NULL, NULL, 0}, {"vars", TclInfoVarsCmd, TclCompileBasic0Or1ArgCmd, NULL, NULL, 0}, {NULL, NULL, NULL, NULL, NULL, 0} }; @@ -2141,6 +2144,50 @@ InfoTclVersionCmd( /* *---------------------------------------------------------------------- * + * InfoTypeCmd -- + * + * Called to implement the "info type" command that returns the type of a + * given command. Handles the following syntax: + * + * info type cmdName + * + * Results: + * Returns TCL_OK if successful and TCL_ERROR if there is an error. + * + * Side effects: + * Returns a type name. If there is an error, the result is an error + * message. + * + *---------------------------------------------------------------------- + */ + +static int +InfoTypeCmd( + ClientData dummy, /* Not used. */ + Tcl_Interp *interp, /* Current interpreter. */ + int objc, /* Number of arguments. */ + Tcl_Obj *const objv[]) /* Argument objects. */ +{ + Tcl_Command command; + + if (objc != 2) { + Tcl_WrongNumArgs(interp, 1, objv, "commandName"); + return TCL_ERROR; + } + command = Tcl_FindCommand(interp, Tcl_GetString(objv[1]), NULL, + TCL_LEAVE_ERR_MSG); + if (command == NULL) { + return TCL_ERROR; + } + + Tcl_SetObjResult(interp, + Tcl_NewStringObj(TclGetCommandTypeName(command), -1)); + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * * Tcl_JoinObjCmd -- * * This procedure is invoked to process the "join" Tcl command. See the diff --git a/generic/tclEnsemble.c b/generic/tclEnsemble.c index 813e056..e81fa1b 100644 --- a/generic/tclEnsemble.c +++ b/generic/tclEnsemble.c @@ -21,8 +21,6 @@ static inline Tcl_Obj * NewNsObj(Tcl_Namespace *namespacePtr); static inline int EnsembleUnknownCallback(Tcl_Interp *interp, EnsembleConfig *ensemblePtr, int objc, Tcl_Obj *const objv[], Tcl_Obj **prefixObjPtr); -static int NsEnsembleImplementationCmd(ClientData clientData, - Tcl_Interp *interp,int objc,Tcl_Obj *const objv[]); static int NsEnsembleImplementationCmdNR(ClientData clientData, Tcl_Interp *interp,int objc,Tcl_Obj *const objv[]); static void BuildEnsembleConfig(EnsembleConfig *ensemblePtr); @@ -687,7 +685,7 @@ Tcl_CreateEnsemble( ensemblePtr->parameterList = NULL; ensemblePtr->unknownHandler = NULL; ensemblePtr->token = Tcl_NRCreateCommand(interp, name, - NsEnsembleImplementationCmd, NsEnsembleImplementationCmdNR, + TclEnsembleImplementationCmd, NsEnsembleImplementationCmdNR, ensemblePtr, DeleteEnsembleConfig); ensemblePtr->next = (EnsembleConfig *) nsPtr->ensembles; nsPtr->ensembles = (Tcl_Ensemble *) ensemblePtr; @@ -738,7 +736,7 @@ Tcl_SetEnsembleSubcommandList( EnsembleConfig *ensemblePtr; Tcl_Obj *oldList; - if (cmdPtr->objProc != NsEnsembleImplementationCmd) { + if (cmdPtr->objProc != TclEnsembleImplementationCmd) { Tcl_SetObjResult(interp, Tcl_NewStringObj( "command is not an ensemble", -1)); Tcl_SetErrorCode(interp, "TCL", "ENSEMBLE", "NOT_ENSEMBLE", NULL); @@ -814,7 +812,7 @@ Tcl_SetEnsembleParameterList( Tcl_Obj *oldList; int length; - if (cmdPtr->objProc != NsEnsembleImplementationCmd) { + if (cmdPtr->objProc != TclEnsembleImplementationCmd) { Tcl_SetObjResult(interp, Tcl_NewStringObj( "command is not an ensemble", -1)); Tcl_SetErrorCode(interp, "TCL", "ENSEMBLE", "NOT_ENSEMBLE", NULL); @@ -890,7 +888,7 @@ Tcl_SetEnsembleMappingDict( EnsembleConfig *ensemblePtr; Tcl_Obj *oldDict; - if (cmdPtr->objProc != NsEnsembleImplementationCmd) { + if (cmdPtr->objProc != TclEnsembleImplementationCmd) { Tcl_SetObjResult(interp, Tcl_NewStringObj( "command is not an ensemble", -1)); Tcl_SetErrorCode(interp, "TCL", "ENSEMBLE", "NOT_ENSEMBLE", NULL); @@ -989,7 +987,7 @@ Tcl_SetEnsembleUnknownHandler( EnsembleConfig *ensemblePtr; Tcl_Obj *oldList; - if (cmdPtr->objProc != NsEnsembleImplementationCmd) { + if (cmdPtr->objProc != TclEnsembleImplementationCmd) { Tcl_SetObjResult(interp, Tcl_NewStringObj( "command is not an ensemble", -1)); Tcl_SetErrorCode(interp, "TCL", "ENSEMBLE", "NOT_ENSEMBLE", NULL); @@ -1055,7 +1053,7 @@ Tcl_SetEnsembleFlags( EnsembleConfig *ensemblePtr; int wasCompiled; - if (cmdPtr->objProc != NsEnsembleImplementationCmd) { + if (cmdPtr->objProc != TclEnsembleImplementationCmd) { Tcl_SetObjResult(interp, Tcl_NewStringObj( "command is not an ensemble", -1)); Tcl_SetErrorCode(interp, "TCL", "ENSEMBLE", "NOT_ENSEMBLE", NULL); @@ -1131,7 +1129,7 @@ Tcl_GetEnsembleSubcommandList( Command *cmdPtr = (Command *) token; EnsembleConfig *ensemblePtr; - if (cmdPtr->objProc != NsEnsembleImplementationCmd) { + if (cmdPtr->objProc != TclEnsembleImplementationCmd) { if (interp != NULL) { Tcl_SetObjResult(interp, Tcl_NewStringObj( "command is not an ensemble", -1)); @@ -1173,7 +1171,7 @@ Tcl_GetEnsembleParameterList( Command *cmdPtr = (Command *) token; EnsembleConfig *ensemblePtr; - if (cmdPtr->objProc != NsEnsembleImplementationCmd) { + if (cmdPtr->objProc != TclEnsembleImplementationCmd) { if (interp != NULL) { Tcl_SetObjResult(interp, Tcl_NewStringObj( "command is not an ensemble", -1)); @@ -1215,7 +1213,7 @@ Tcl_GetEnsembleMappingDict( Command *cmdPtr = (Command *) token; EnsembleConfig *ensemblePtr; - if (cmdPtr->objProc != NsEnsembleImplementationCmd) { + if (cmdPtr->objProc != TclEnsembleImplementationCmd) { if (interp != NULL) { Tcl_SetObjResult(interp, Tcl_NewStringObj( "command is not an ensemble", -1)); @@ -1256,7 +1254,7 @@ Tcl_GetEnsembleUnknownHandler( Command *cmdPtr = (Command *) token; EnsembleConfig *ensemblePtr; - if (cmdPtr->objProc != NsEnsembleImplementationCmd) { + if (cmdPtr->objProc != TclEnsembleImplementationCmd) { if (interp != NULL) { Tcl_SetObjResult(interp, Tcl_NewStringObj( "command is not an ensemble", -1)); @@ -1297,7 +1295,7 @@ Tcl_GetEnsembleFlags( Command *cmdPtr = (Command *) token; EnsembleConfig *ensemblePtr; - if (cmdPtr->objProc != NsEnsembleImplementationCmd) { + if (cmdPtr->objProc != TclEnsembleImplementationCmd) { if (interp != NULL) { Tcl_SetObjResult(interp, Tcl_NewStringObj( "command is not an ensemble", -1)); @@ -1338,7 +1336,7 @@ Tcl_GetEnsembleNamespace( Command *cmdPtr = (Command *) token; EnsembleConfig *ensemblePtr; - if (cmdPtr->objProc != NsEnsembleImplementationCmd) { + if (cmdPtr->objProc != TclEnsembleImplementationCmd) { if (interp != NULL) { Tcl_SetObjResult(interp, Tcl_NewStringObj( "command is not an ensemble", -1)); @@ -1388,7 +1386,7 @@ Tcl_FindEnsemble( return NULL; } - if (cmdPtr->objProc != NsEnsembleImplementationCmd) { + if (cmdPtr->objProc != TclEnsembleImplementationCmd) { /* * Reuse existing infrastructure for following import link chains * rather than duplicating it. @@ -1396,7 +1394,8 @@ Tcl_FindEnsemble( cmdPtr = (Command *) TclGetOriginalCommand((Tcl_Command) cmdPtr); - if (cmdPtr == NULL || cmdPtr->objProc != NsEnsembleImplementationCmd){ + if (cmdPtr == NULL + || cmdPtr->objProc != TclEnsembleImplementationCmd) { if (flags & TCL_LEAVE_ERR_MSG) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( "\"%s\" is not an ensemble command", @@ -1434,11 +1433,11 @@ Tcl_IsEnsemble( { Command *cmdPtr = (Command *) token; - if (cmdPtr->objProc == NsEnsembleImplementationCmd) { + if (cmdPtr->objProc == TclEnsembleImplementationCmd) { return 1; } cmdPtr = (Command *) TclGetOriginalCommand((Tcl_Command) cmdPtr); - if (cmdPtr == NULL || cmdPtr->objProc != NsEnsembleImplementationCmd) { + if (cmdPtr == NULL || cmdPtr->objProc != TclEnsembleImplementationCmd) { return 0; } return 1; @@ -1609,7 +1608,7 @@ TclMakeEnsemble( /* *---------------------------------------------------------------------- * - * NsEnsembleImplementationCmd -- + * TclEnsembleImplementationCmd -- * * Implements an ensemble of commands (being those exported by a * namespace other than the global namespace) as a command with the same @@ -1628,8 +1627,8 @@ TclMakeEnsemble( *---------------------------------------------------------------------- */ -static int -NsEnsembleImplementationCmd( +int +TclEnsembleImplementationCmd( ClientData clientData, Tcl_Interp *interp, int objc, diff --git a/generic/tclInt.h b/generic/tclInt.h index b940225..ce8ef8f 100644 --- a/generic/tclInt.h +++ b/generic/tclInt.h @@ -3096,6 +3096,10 @@ MODULE_SCOPE int TclTrimLeft(const char *bytes, int numBytes, const char *trim, int numTrim); MODULE_SCOPE int TclTrimRight(const char *bytes, int numBytes, const char *trim, int numTrim); +MODULE_SCOPE const char*TclGetCommandTypeName(Tcl_Command command); +MODULE_SCOPE void TclRegisterCommandTypeName( + Tcl_ObjCmdProc *implementationProc, + const char *nameStr); MODULE_SCOPE int TclUtfCasecmp(const char *cs, const char *ct); MODULE_SCOPE Tcl_Obj * TclpNativeToNormalized(ClientData clientData); MODULE_SCOPE Tcl_Obj * TclpFilesystemPathType(Tcl_Obj *pathPtr); @@ -3886,6 +3890,17 @@ MODULE_SCOPE unsigned TclHashObjKey(Tcl_HashTable *tablePtr, void *keyPtr); MODULE_SCOPE int TclFullFinalizationRequested(void); /* + * Just for the purposes of command-type registration. + */ + +MODULE_SCOPE Tcl_ObjCmdProc TclEnsembleImplementationCmd; +MODULE_SCOPE Tcl_ObjCmdProc TclAliasObjCmd; +MODULE_SCOPE Tcl_ObjCmdProc TclSlaveObjCmd; +MODULE_SCOPE Tcl_ObjCmdProc TclInvokeImportedCmd; +MODULE_SCOPE Tcl_ObjCmdProc TclOOPublicObjectCmd; +MODULE_SCOPE Tcl_ObjCmdProc TclOOPrivateObjectCmd; + +/* *---------------------------------------------------------------- * Macros used by the Tcl core to create and release Tcl objects. * TclNewObj(objPtr) creates a new object denoting an empty string. diff --git a/generic/tclInterp.c b/generic/tclInterp.c index 1a4297b..fe218ff 100644 --- a/generic/tclInterp.c +++ b/generic/tclInterp.c @@ -222,9 +222,6 @@ static int AliasDelete(Tcl_Interp *interp, static int AliasDescribe(Tcl_Interp *interp, Tcl_Interp *slaveInterp, Tcl_Obj *objPtr); static int AliasList(Tcl_Interp *interp, Tcl_Interp *slaveInterp); -static int AliasObjCmd(ClientData dummy, - Tcl_Interp *currentInterp, int objc, - Tcl_Obj *const objv[]); static int AliasNRCmd(ClientData dummy, Tcl_Interp *currentInterp, int objc, Tcl_Obj *const objv[]); @@ -257,8 +254,6 @@ static int SlaveInvokeHidden(Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); static int SlaveMarkTrusted(Tcl_Interp *interp, Tcl_Interp *slaveInterp); -static int SlaveObjCmd(ClientData dummy, Tcl_Interp *interp, - int objc, Tcl_Obj *const objv[]); static void SlaveObjCmdDeleteProc(ClientData clientData); static int SlaveRecursionLimit(Tcl_Interp *interp, Tcl_Interp *slaveInterp, int objc, @@ -1390,7 +1385,7 @@ TclPreventAliasLoop( * create or rename the command. */ - if (cmdPtr->objProc != AliasObjCmd) { + if (cmdPtr->objProc != TclAliasObjCmd) { return TCL_OK; } @@ -1445,7 +1440,7 @@ TclPreventAliasLoop( * Otherwise we do not have a loop. */ - if (aliasCmdPtr->objProc != AliasObjCmd) { + if (aliasCmdPtr->objProc != TclAliasObjCmd) { return TCL_OK; } nextAliasPtr = aliasCmdPtr->objClientData; @@ -1511,12 +1506,12 @@ AliasCreate( if (slaveInterp == masterInterp) { aliasPtr->slaveCmd = Tcl_NRCreateCommand(slaveInterp, - TclGetString(namePtr), AliasObjCmd, AliasNRCmd, aliasPtr, + TclGetString(namePtr), TclAliasObjCmd, AliasNRCmd, aliasPtr, AliasObjCmdDeleteProc); } else { - aliasPtr->slaveCmd = Tcl_CreateObjCommand(slaveInterp, - TclGetString(namePtr), AliasObjCmd, aliasPtr, - AliasObjCmdDeleteProc); + aliasPtr->slaveCmd = Tcl_CreateObjCommand(slaveInterp, + TclGetString(namePtr), TclAliasObjCmd, aliasPtr, + AliasObjCmdDeleteProc); } if (TclPreventAliasLoop(interp, slaveInterp, @@ -1752,7 +1747,7 @@ AliasList( /* *---------------------------------------------------------------------- * - * AliasObjCmd -- + * TclAliasObjCmd -- * * This is the function that services invocations of aliases in a slave * interpreter. One such command exists for each alias. When invoked, @@ -1835,8 +1830,8 @@ AliasNRCmd( return Tcl_NREvalObj(interp, listPtr, flags); } -static int -AliasObjCmd( +int +TclAliasObjCmd( ClientData clientData, /* Alias record. */ Tcl_Interp *interp, /* Current interpreter. */ int objc, /* Number of arguments. */ @@ -2373,7 +2368,7 @@ SlaveCreate( slavePtr->slaveEntryPtr = hPtr; slavePtr->slaveInterp = slaveInterp; slavePtr->interpCmd = Tcl_CreateObjCommand(masterInterp, path, - SlaveObjCmd, slaveInterp, SlaveObjCmdDeleteProc); + TclSlaveObjCmd, slaveInterp, SlaveObjCmdDeleteProc); Tcl_InitHashTable(&slavePtr->aliasTable, TCL_STRING_KEYS); Tcl_SetHashValue(hPtr, slavePtr); Tcl_SetVar(slaveInterp, "tcl_interactive", "0", TCL_GLOBAL_ONLY); @@ -2441,7 +2436,7 @@ SlaveCreate( /* *---------------------------------------------------------------------- * - * SlaveObjCmd -- + * TclSlaveObjCmd -- * * Command to manipulate an interpreter, e.g. to send commands to it to * be evaluated. One such command exists for each slave interpreter. @@ -2455,8 +2450,8 @@ SlaveCreate( *---------------------------------------------------------------------- */ -static int -SlaveObjCmd( +int +TclSlaveObjCmd( ClientData clientData, /* Slave interpreter. */ Tcl_Interp *interp, /* Current interpreter. */ int objc, /* Number of arguments. */ @@ -2478,7 +2473,7 @@ SlaveObjCmd( }; if (slaveInterp == NULL) { - Tcl_Panic("SlaveObjCmd: interpreter has been deleted"); + Tcl_Panic("TclSlaveObjCmd: interpreter has been deleted"); } if (objc < 2) { diff --git a/generic/tclNamesp.c b/generic/tclNamesp.c index aed623a..cc2f953 100644 --- a/generic/tclNamesp.c +++ b/generic/tclNamesp.c @@ -89,8 +89,6 @@ static char * EstablishErrorInfoTraces(ClientData clientData, static void FreeNsNameInternalRep(Tcl_Obj *objPtr); static int GetNamespaceFromObj(Tcl_Interp *interp, Tcl_Obj *objPtr, Tcl_Namespace **nsPtrPtr); -static int InvokeImportedCmd(ClientData clientData, - Tcl_Interp *interp,int objc,Tcl_Obj *const objv[]); static int InvokeImportedNRCmd(ClientData clientData, Tcl_Interp *interp,int objc,Tcl_Obj *const objv[]); static int NamespaceChildrenCmd(ClientData dummy, @@ -1693,7 +1691,7 @@ DoImport( dataPtr = ckalloc(sizeof(ImportedCmdData)); importedCmd = Tcl_NRCreateCommand(interp, Tcl_DStringValue(&ds), - InvokeImportedCmd, InvokeImportedNRCmd, dataPtr, + TclInvokeImportedCmd, InvokeImportedNRCmd, dataPtr, DeleteImportedCmd); dataPtr->realCmdPtr = cmdPtr; dataPtr->selfPtr = (Command *) importedCmd; @@ -1914,7 +1912,7 @@ TclGetOriginalCommand( /* *---------------------------------------------------------------------- * - * InvokeImportedCmd -- + * TclInvokeImportedCmd -- * * Invoked by Tcl whenever the user calls an imported command that was * created by Tcl_Import. Finds the "real" command (in another @@ -1945,8 +1943,8 @@ InvokeImportedNRCmd( return Tcl_NRCmdSwap(interp, (Tcl_Command) realCmdPtr, objc, objv, 0); } -static int -InvokeImportedCmd( +int +TclInvokeImportedCmd( ClientData clientData, /* Points to the imported command's * ImportedCmdData structure. */ Tcl_Interp *interp, /* Current interpreter. */ diff --git a/generic/tclOO.c b/generic/tclOO.c index cb22de6..1138c99 100644 --- a/generic/tclOO.c +++ b/generic/tclOO.c @@ -84,15 +84,9 @@ static void ReleaseClassContents(Tcl_Interp *interp,Object *oPtr); static inline void SquelchCachedName(Object *oPtr); static void SquelchedNsFirst(ClientData clientData); -static int PublicObjectCmd(ClientData clientData, - Tcl_Interp *interp, int objc, - Tcl_Obj *const *objv); static int PublicNRObjectCmd(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const *objv); -static int PrivateObjectCmd(ClientData clientData, - Tcl_Interp *interp, int objc, - Tcl_Obj *const *objv); static int PrivateNRObjectCmd(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const *objv); @@ -650,10 +644,11 @@ AllocObject( if (!nameStr) { oPtr->command = Tcl_CreateObjCommand(interp, - oPtr->namespacePtr->fullName, PublicObjectCmd, oPtr, NULL); + oPtr->namespacePtr->fullName, TclOOPublicObjectCmd, oPtr, + NULL); } else if (nameStr[0] == ':' && nameStr[1] == ':') { oPtr->command = Tcl_CreateObjCommand(interp, nameStr, - PublicObjectCmd, oPtr, NULL); + TclOOPublicObjectCmd, oPtr, NULL); } else { Tcl_DString buffer; @@ -663,7 +658,7 @@ AllocObject( TclDStringAppendLiteral(&buffer, "::"); Tcl_DStringAppend(&buffer, nameStr, -1); oPtr->command = Tcl_CreateObjCommand(interp, - Tcl_DStringValue(&buffer), PublicObjectCmd, oPtr, NULL); + Tcl_DStringValue(&buffer), TclOOPublicObjectCmd, oPtr, NULL); Tcl_DStringFree(&buffer); } @@ -692,7 +687,7 @@ AllocObject( cmdPtr->hPtr = Tcl_CreateHashEntry(&cmdPtr->nsPtr->cmdTable, "my", &ignored); cmdPtr->refCount = 1; - cmdPtr->objProc = PrivateObjectCmd; + cmdPtr->objProc = TclOOPrivateObjectCmd; cmdPtr->deleteProc = MyDeleted; cmdPtr->objClientData = cmdPtr->deleteData = oPtr; cmdPtr->proc = TclInvokeObjectCommand; @@ -2368,7 +2363,7 @@ Tcl_ObjectSetMetadata( /* * ---------------------------------------------------------------------- * - * PublicObjectCmd, PrivateObjectCmd, TclOOInvokeObject -- + * TclOOPublicObjectCmd, TclOOPrivateObjectCmd, TclOOInvokeObject -- * * Main entry point for object invokations. The Public* and Private* * wrapper functions (implementations of both object instance commands @@ -2378,8 +2373,8 @@ Tcl_ObjectSetMetadata( * ---------------------------------------------------------------------- */ -static int -PublicObjectCmd( +int +TclOOPublicObjectCmd( ClientData clientData, Tcl_Interp *interp, int objc, @@ -2399,8 +2394,8 @@ PublicNRObjectCmd( NULL); } -static int -PrivateObjectCmd( +int +TclOOPrivateObjectCmd( ClientData clientData, Tcl_Interp *interp, int objc, @@ -2784,9 +2779,9 @@ Tcl_GetObjectFromObj( if (cmdPtr == NULL) { goto notAnObject; } - if (cmdPtr->objProc != PublicObjectCmd) { + if (cmdPtr->objProc != TclOOPublicObjectCmd) { cmdPtr = (Command *) TclGetOriginalCommand((Tcl_Command) cmdPtr); - if (cmdPtr == NULL || cmdPtr->objProc != PublicObjectCmd) { + if (cmdPtr == NULL || cmdPtr->objProc != TclOOPublicObjectCmd) { goto notAnObject; } } -- cgit v0.12 From 82132b6c4c3b3779d75abdb7283c82bc90012d82 Mon Sep 17 00:00:00 2001 From: dkf Date: Wed, 10 Jul 2013 13:45:52 +0000 Subject: Some documentation. --- doc/CrtObjCmd.3 | 29 ++++++++++++++++++++++++++++- doc/info.n | 30 ++++++++++++++++++++++++++++++ 2 files changed, 58 insertions(+), 1 deletion(-) diff --git a/doc/CrtObjCmd.3 b/doc/CrtObjCmd.3 index faf8b74..16e7c92 100644 --- a/doc/CrtObjCmd.3 +++ b/doc/CrtObjCmd.3 @@ -8,7 +8,7 @@ .TH Tcl_CreateObjCommand 3 8.0 Tcl "Tcl Library Procedures" .BS .SH NAME -Tcl_CreateObjCommand, Tcl_DeleteCommand, Tcl_DeleteCommandFromToken, Tcl_GetCommandInfo, Tcl_GetCommandInfoFromToken, Tcl_SetCommandInfo, Tcl_SetCommandInfoFromToken, Tcl_GetCommandName, Tcl_GetCommandFullName, Tcl_GetCommandFromObj \- implement new commands in C +Tcl_CreateObjCommand, Tcl_DeleteCommand, Tcl_DeleteCommandFromToken, Tcl_GetCommandInfo, Tcl_GetCommandInfoFromToken, Tcl_SetCommandInfo, Tcl_SetCommandInfoFromToken, Tcl_GetCommandName, Tcl_GetCommandFullName, Tcl_GetCommandFromObj Tcl_RegisterCommandTypeName, Tcl_GetCommandTypeName \- implement new commands in C .SH SYNOPSIS .nf \fB#include \fR @@ -42,6 +42,14 @@ void .sp Tcl_Command \fBTcl_GetCommandFromObj\fR(\fIinterp, objPtr\fR) +.sp +.VS "info type feature" +void +\fBTcl_RegisterCommandTypeName\fR(\fIproc, typeName\fR) +.sp +const char * +\fBTcl_GetCommandTypeName\fR(\fItoken\fR) +.VE "info type feature" .SH ARGUMENTS .AS Tcl_CmdDeleteProc *deleteProc in/out .AP Tcl_Interp *interp in @@ -65,6 +73,9 @@ Pointer to structure containing various information about a Tcl command. .AP Tcl_Obj *objPtr in Value containing the name of a Tcl command. +.AP "const char" *typeName in +Indicates the name of the type of command implementation associated +with a particular \fIproc\fR, or NULL to break the association. .BE .SH DESCRIPTION .PP @@ -296,6 +307,22 @@ is appended to the value specified by \fIobjPtr\fR. specified by the name in a \fBTcl_Obj\fR. The command name is resolved relative to the current namespace. Returns NULL if the command is not found. +.PP +.VS "info type feature" +\fBTcl_RegisterCommandTypeName\fR is used to associate a name (the +\fItypeName\fR argument) with a particular implementation function so that it +can then be looked up with \fBTcl_GetCommandTypeName\fR, which in turn is +called with a command token that information is wanted for and which returns +the name of the type that was registered for the implementation function used +for that command. (The lookup functionality is surfaced virtually directly in Tcl via +\fBinfo type\fR.) If there is no function registered for a particular +function, the result will be the string literal +.QW \fBnative\fR . +The registration of a name can be undone by registering a mapping to NULL +instead. The result from \fBTcl_GetCommandTypeName\fR will be exactly that +string which was registered, and not a copy; use of a compile-time constant +string is \fIstrongly recommended\fR. +.VE "info type feature" .SH "SEE ALSO" Tcl_CreateCommand(3), Tcl_ResetResult(3), Tcl_SetObjResult(3) .SH KEYWORDS diff --git a/doc/info.n b/doc/info.n index e65a083..59ee1a2 100644 --- a/doc/info.n +++ b/doc/info.n @@ -377,6 +377,36 @@ string is returned. Returns the value of the global variable \fBtcl_version\fR; see the \fBtclvars\fR manual entry for more information. .TP +\fBinfo type \fIcommandName\fR +.VS "info type feature" +Returns a description of the kind of command named by \fIcommandName\fR. The +supported types are: +.RS +.IP \fBalias\fR +Indicates that \fIcommandName\fR was created by \fBinterp alias\fR. +.IP \fBensemble\fR +Indicates that \fIcommandName\fR was created by \fBnamespace ensemble\fR. +.IP \fBimport\fR +Indicates that \fIcommandName\fR was created by \fBnamespace import\fR. +.IP \fBnative\fR +Indicates that \fIcommandName\fR was created by the \fBTcl_CreateObjProc\fR +interface directly without further registration of the type of command. +.IP \fBobject\fR +Indicates that \fIcommandName\fR is the public command that represents an +instance of \fBoo::object\fR or one of its subclasses. +.IP \fBprivateObject\fR +Indicates that \fIcommandName\fR is the private command (\fBmy\fR by default) +that represents an instance of \fBoo::object\fR or one of its subclasses. +.IP \fBproc\fR +Indicates that \fIcommandName\fR was created by \fBproc\fR. +.IP \fBslave\fR +Indicates that \fIcommandName\fR was created by \fBinterp create\fR. +.PP +There may be other registered types as well; this is a set that is extensible +at the implementation level with \fBTcl_RegisterCommandTypeName\fR. +.RE +.VE "info type feature" +.TP \fBinfo vars\fR ?\fIpattern\fR? . If \fIpattern\fR is not specified, -- cgit v0.12 From afd4d17b3c5167c365d4072b61c93a80aacafad1 Mon Sep 17 00:00:00 2001 From: dkf Date: Tue, 16 Jul 2013 14:12:40 +0000 Subject: Changed subcommand name following community feedback. --- doc/CrtObjCmd.3 | 10 ++++----- doc/info.n | 60 +++++++++++++++++++++++++++--------------------------- generic/tclCmdIL.c | 14 ++++++------- 3 files changed, 42 insertions(+), 42 deletions(-) diff --git a/doc/CrtObjCmd.3 b/doc/CrtObjCmd.3 index 16e7c92..149d2f6 100644 --- a/doc/CrtObjCmd.3 +++ b/doc/CrtObjCmd.3 @@ -43,13 +43,13 @@ void Tcl_Command \fBTcl_GetCommandFromObj\fR(\fIinterp, objPtr\fR) .sp -.VS "info type feature" +.VS "info cmdtype feature" void \fBTcl_RegisterCommandTypeName\fR(\fIproc, typeName\fR) .sp const char * \fBTcl_GetCommandTypeName\fR(\fItoken\fR) -.VE "info type feature" +.VE "info cmdtype feature" .SH ARGUMENTS .AS Tcl_CmdDeleteProc *deleteProc in/out .AP Tcl_Interp *interp in @@ -308,21 +308,21 @@ specified by the name in a \fBTcl_Obj\fR. The command name is resolved relative to the current namespace. Returns NULL if the command is not found. .PP -.VS "info type feature" +.VS "info cmdtype feature" \fBTcl_RegisterCommandTypeName\fR is used to associate a name (the \fItypeName\fR argument) with a particular implementation function so that it can then be looked up with \fBTcl_GetCommandTypeName\fR, which in turn is called with a command token that information is wanted for and which returns the name of the type that was registered for the implementation function used for that command. (The lookup functionality is surfaced virtually directly in Tcl via -\fBinfo type\fR.) If there is no function registered for a particular +\fBinfo cmdtype\fR.) If there is no function registered for a particular function, the result will be the string literal .QW \fBnative\fR . The registration of a name can be undone by registering a mapping to NULL instead. The result from \fBTcl_GetCommandTypeName\fR will be exactly that string which was registered, and not a copy; use of a compile-time constant string is \fIstrongly recommended\fR. -.VE "info type feature" +.VE "info cmdtype feature" .SH "SEE ALSO" Tcl_CreateCommand(3), Tcl_ResetResult(3), Tcl_SetObjResult(3) .SH KEYWORDS diff --git a/doc/info.n b/doc/info.n index 59ee1a2..42fe6c3 100644 --- a/doc/info.n +++ b/doc/info.n @@ -45,6 +45,36 @@ described in \fBCLASS INTROSPECTION\fR below. Returns a count of the total number of commands that have been invoked in this interpreter. .TP +\fBinfo cmdtype \fIcommandName\fR +.VS "info cmdtype feature" +Returns a description of the kind of command named by \fIcommandName\fR. The +supported types are: +.RS +.IP \fBalias\fR +Indicates that \fIcommandName\fR was created by \fBinterp alias\fR. +.IP \fBensemble\fR +Indicates that \fIcommandName\fR was created by \fBnamespace ensemble\fR. +.IP \fBimport\fR +Indicates that \fIcommandName\fR was created by \fBnamespace import\fR. +.IP \fBnative\fR +Indicates that \fIcommandName\fR was created by the \fBTcl_CreateObjProc\fR +interface directly without further registration of the type of command. +.IP \fBobject\fR +Indicates that \fIcommandName\fR is the public command that represents an +instance of \fBoo::object\fR or one of its subclasses. +.IP \fBprivateObject\fR +Indicates that \fIcommandName\fR is the private command (\fBmy\fR by default) +that represents an instance of \fBoo::object\fR or one of its subclasses. +.IP \fBproc\fR +Indicates that \fIcommandName\fR was created by \fBproc\fR. +.IP \fBslave\fR +Indicates that \fIcommandName\fR was created by \fBinterp create\fR. +.PP +There may be other registered types as well; this is a set that is extensible +at the implementation level with \fBTcl_RegisterCommandTypeName\fR. +.RE +.VE "info cmdtype feature" +.TP \fBinfo commands \fR?\fIpattern\fR? . If \fIpattern\fR is not specified, @@ -377,36 +407,6 @@ string is returned. Returns the value of the global variable \fBtcl_version\fR; see the \fBtclvars\fR manual entry for more information. .TP -\fBinfo type \fIcommandName\fR -.VS "info type feature" -Returns a description of the kind of command named by \fIcommandName\fR. The -supported types are: -.RS -.IP \fBalias\fR -Indicates that \fIcommandName\fR was created by \fBinterp alias\fR. -.IP \fBensemble\fR -Indicates that \fIcommandName\fR was created by \fBnamespace ensemble\fR. -.IP \fBimport\fR -Indicates that \fIcommandName\fR was created by \fBnamespace import\fR. -.IP \fBnative\fR -Indicates that \fIcommandName\fR was created by the \fBTcl_CreateObjProc\fR -interface directly without further registration of the type of command. -.IP \fBobject\fR -Indicates that \fIcommandName\fR is the public command that represents an -instance of \fBoo::object\fR or one of its subclasses. -.IP \fBprivateObject\fR -Indicates that \fIcommandName\fR is the private command (\fBmy\fR by default) -that represents an instance of \fBoo::object\fR or one of its subclasses. -.IP \fBproc\fR -Indicates that \fIcommandName\fR was created by \fBproc\fR. -.IP \fBslave\fR -Indicates that \fIcommandName\fR was created by \fBinterp create\fR. -.PP -There may be other registered types as well; this is a set that is extensible -at the implementation level with \fBTcl_RegisterCommandTypeName\fR. -.RE -.VE "info type feature" -.TP \fBinfo vars\fR ?\fIpattern\fR? . If \fIpattern\fR is not specified, diff --git a/generic/tclCmdIL.c b/generic/tclCmdIL.c index 1b6f9c1..b99b9e2 100644 --- a/generic/tclCmdIL.c +++ b/generic/tclCmdIL.c @@ -146,7 +146,7 @@ static int InfoScriptCmd(ClientData dummy, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); static int InfoSharedlibCmd(ClientData dummy, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); -static int InfoTypeCmd(ClientData dummy, Tcl_Interp *interp, +static int InfoCmdTypeCmd(ClientData dummy, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); static int InfoTclVersionCmd(ClientData dummy, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); @@ -166,6 +166,7 @@ static const EnsembleImplMap defaultInfoMap[] = { {"args", InfoArgsCmd, TclCompileBasic1ArgCmd, NULL, NULL, 0}, {"body", InfoBodyCmd, TclCompileBasic1ArgCmd, NULL, NULL, 0}, {"cmdcount", InfoCmdCountCmd, TclCompileBasic0ArgCmd, NULL, NULL, 0}, + {"cmdtype", InfoCmdTypeCmd, TclCompileBasic1ArgCmd, NULL, NULL, 0}, {"commands", InfoCommandsCmd, TclCompileInfoCommandsCmd, NULL, NULL, 0}, {"complete", InfoCompleteCmd, TclCompileBasic1ArgCmd, NULL, NULL, 0}, {"coroutine", TclInfoCoroutineCmd, TclCompileInfoCoroutineCmd, NULL, NULL, 0}, @@ -186,7 +187,6 @@ static const EnsembleImplMap defaultInfoMap[] = { {"script", InfoScriptCmd, TclCompileBasic0Or1ArgCmd, NULL, NULL, 0}, {"sharedlibextension", InfoSharedlibCmd, TclCompileBasic0ArgCmd, NULL, NULL, 0}, {"tclversion", InfoTclVersionCmd, TclCompileBasic0ArgCmd, NULL, NULL, 0}, - {"type", InfoTypeCmd, TclCompileBasic1ArgCmd, NULL, NULL, 0}, {"vars", TclInfoVarsCmd, TclCompileBasic0Or1ArgCmd, NULL, NULL, 0}, {NULL, NULL, NULL, NULL, NULL, 0} }; @@ -2144,12 +2144,12 @@ InfoTclVersionCmd( /* *---------------------------------------------------------------------- * - * InfoTypeCmd -- + * InfoCmdTypeCmd -- * - * Called to implement the "info type" command that returns the type of a - * given command. Handles the following syntax: + * Called to implement the "info cmdtype" command that returns the type + * of a given command. Handles the following syntax: * - * info type cmdName + * info cmdtype cmdName * * Results: * Returns TCL_OK if successful and TCL_ERROR if there is an error. @@ -2162,7 +2162,7 @@ InfoTclVersionCmd( */ static int -InfoTypeCmd( +InfoCmdTypeCmd( ClientData dummy, /* Not used. */ Tcl_Interp *interp, /* Current interpreter. */ int objc, /* Number of arguments. */ -- cgit v0.12 From a6c0992f472a7690735859d61d05cd042ecd43c1 Mon Sep 17 00:00:00 2001 From: dkf Date: Wed, 31 Jul 2013 20:03:43 +0000 Subject: Added tests --- tests/info.test | 95 ++++++++++++++++++++++++++++++++++++++++++++++++++++----- 1 file changed, 88 insertions(+), 7 deletions(-) diff --git a/tests/info.test b/tests/info.test index 3057dd2..ef6bba9 100644 --- a/tests/info.test +++ b/tests/info.test @@ -33,7 +33,7 @@ namespace eval test_ns_info1 { proc p {x} {return "x=$x"} proc q {{y 27} {z {}}} {return "y=$y"} } - + test info-1.1 {info args option} { proc t1 {a bbb c} {return foo} info args t1 @@ -110,7 +110,7 @@ test info-2.6 {info body option, returning list bodies} { proc testinfocmdcount {} { set x [info cmdcount] set y 12345 - set z [info cm] + set z [info cmdc] expr {$z-$x} } test info-3.1 {info cmdcount compiled} { @@ -119,7 +119,7 @@ test info-3.1 {info cmdcount compiled} { test info-3.2 {info cmdcount evaled} -body { set x [info cmdcount] set y 12345 - set z [info cm] + set z [info cmdc] expr {$z-$x} } -cleanup {unset x y z} -result 4 test info-3.3 {info cmdcount evaled} -body [info body testinfocmdcount] -cleanup {unset x y z} -result 4 @@ -678,16 +678,16 @@ test info-21.1 {miscellaneous error conditions} -returnCodes error -body { } -result {wrong # args: should be "info subcommand ?arg ...?"} test info-21.2 {miscellaneous error conditions} -returnCodes error -body { info gorp -} -result {unknown or ambiguous subcommand "gorp": must be args, body, class, cmdcount, commands, complete, coroutine, default, errorstack, exists, frame, functions, globals, hostname, level, library, loaded, locals, nameofexecutable, object, patchlevel, procs, script, sharedlibextension, tclversion, or vars} +} -result {unknown or ambiguous subcommand "gorp": must be args, body, class, cmdcount, cmdtype, commands, complete, coroutine, default, errorstack, exists, frame, functions, globals, hostname, level, library, loaded, locals, nameofexecutable, object, patchlevel, procs, script, sharedlibextension, tclversion, or vars} test info-21.3 {miscellaneous error conditions} -returnCodes error -body { info c -} -result {unknown or ambiguous subcommand "c": must be args, body, class, cmdcount, commands, complete, coroutine, default, errorstack, exists, frame, functions, globals, hostname, level, library, loaded, locals, nameofexecutable, object, patchlevel, procs, script, sharedlibextension, tclversion, or vars} +} -result {unknown or ambiguous subcommand "c": must be args, body, class, cmdcount, cmdtype, commands, complete, coroutine, default, errorstack, exists, frame, functions, globals, hostname, level, library, loaded, locals, nameofexecutable, object, patchlevel, procs, script, sharedlibextension, tclversion, or vars} test info-21.4 {miscellaneous error conditions} -returnCodes error -body { info l -} -result {unknown or ambiguous subcommand "l": must be args, body, class, cmdcount, commands, complete, coroutine, default, errorstack, exists, frame, functions, globals, hostname, level, library, loaded, locals, nameofexecutable, object, patchlevel, procs, script, sharedlibextension, tclversion, or vars} +} -result {unknown or ambiguous subcommand "l": must be args, body, class, cmdcount, cmdtype, commands, complete, coroutine, default, errorstack, exists, frame, functions, globals, hostname, level, library, loaded, locals, nameofexecutable, object, patchlevel, procs, script, sharedlibextension, tclversion, or vars} test info-21.5 {miscellaneous error conditions} -returnCodes error -body { info s -} -result {unknown or ambiguous subcommand "s": must be args, body, class, cmdcount, commands, complete, coroutine, default, errorstack, exists, frame, functions, globals, hostname, level, library, loaded, locals, nameofexecutable, object, patchlevel, procs, script, sharedlibextension, tclversion, or vars} +} -result {unknown or ambiguous subcommand "s": must be args, body, class, cmdcount, cmdtype, commands, complete, coroutine, default, errorstack, exists, frame, functions, globals, hostname, level, library, loaded, locals, nameofexecutable, object, patchlevel, procs, script, sharedlibextension, tclversion, or vars} ## # ### ### ### ######### ######### ######### @@ -2396,6 +2396,87 @@ test info-33.35 {{*}, literal, simple, bytecompiled} -body { } -result {type source line 2389 file info.test cmd {info frame 0} proc ::foo::bar level 0} # ------------------------------------------------------------------------- +namespace eval ::testinfocmdtype { + apply {cmds { + foreach c $cmds {rename $c {}} + } ::testinfocmdtype} [info commands ::testinfocmdtype::*] +} +test info-40.1 {info cmdtype: syntax} -body { + info cmdtype +} -returnCodes error -result {wrong # args: should be "info cmdtype commandName"} +test info-40.2 {info cmdtype: syntax} -body { + info cmdtype foo bar +} -returnCodes error -result {wrong # args: should be "info cmdtype commandName"} +test info-40.3 {info cmdtype: no such command} -body { + info cmdtype ::testinfocmdtype::foo +} -returnCodes error -result {unknown command "::testinfocmdtype::foo"} +test info-40.4 {info cmdtype: native commands} -body { + info cmdtype ::if +} -result native +test info-40.5 {info cmdtype: native commands} -body { + info cmdtype ::puts +} -result native +test info-40.6 {info cmdtype: native commands} -body { + info cmdtype ::yield +} -result native +test info-40.7 {info cmdtype: procedures} -setup { + proc ::testinfocmdtype::someproc {} {} +} -body { + info cmdtype ::testinfocmdtype::someproc +} -cleanup { + rename ::testinfocmdtype::someproc {} +} -result proc +test info-40.8 {info cmdtype: aliases} -setup { + interp alias {} ::testinfocmdtype::somealias {} ::puts +} -body { + info cmdtype ::testinfocmdtype::somealias +} -cleanup { + rename ::testinfocmdtype::somealias {} +} -result alias +test info-40.9 {info cmdtype: imports} -setup { + namespace eval ::testinfocmdtype { + namespace eval foo { + proc bar {} {} + namespace export bar + } + namespace import foo::bar + } +} -body { + info cmdtype ::testinfocmdtype::bar +} -cleanup { + rename ::testinfocmdtype::bar {} + namespace delete ::testinfocmdtype::foo +} -result import +test info-40.10 {info cmdtype: slaves} -setup { + apply {i { + rename $i ::testinfocmdtype::slave + variable ::testinfocmdtype::slave $i + }} [interp create] +} -body { + info cmdtype ::testinfocmdtype::slave +} -cleanup { + interp delete $::testinfocmdtype::slave +} -result slave +test info-40.11 {info cmdtype: objects} -setup { + apply {{} { + oo::object create obj + } ::testinfocmdtype} +} -body { + info cmdtype ::testinfocmdtype::obj +} -cleanup { + ::testinfocmdtype::obj destroy +} -result object +test info-40.12 {info cmdtype: objects} -setup { + apply {{} { + oo::object create obj + } ::testinfocmdtype} +} -body { + info cmdtype [info object namespace ::testinfocmdtype::obj]::my +} -cleanup { + ::testinfocmdtype::obj destroy +} -result privateObject + +# ------------------------------------------------------------------------- unset -nocomplain res # cleanup -- cgit v0.12 From f8e147cb73f34eb486c128a840ceddacdee2677b Mon Sep 17 00:00:00 2001 From: dkf Date: Thu, 1 Aug 2013 06:44:24 +0000 Subject: Improving the test suite for [info cmdtype]. --- tests/info.test | 28 ++++++++++++++++++++++++++++ 1 file changed, 28 insertions(+) diff --git a/tests/info.test b/tests/info.test index ef6bba9..f3517f9 100644 --- a/tests/info.test +++ b/tests/info.test @@ -2475,6 +2475,34 @@ test info-40.12 {info cmdtype: objects} -setup { } -cleanup { ::testinfocmdtype::obj destroy } -result privateObject +test info-40.13 {info cmdtype: ensembles} -setup { + namespace eval ::testinfocmdtype { + namespace eval ensmbl { + proc bar {} {} + namespace export * + namespace ensemble create + } + } +} -body { + info cmdtype ::testinfocmdtype::ensmbl +} -cleanup { + namespace delete ::testinfocmdtype::ensmbl +} -result ensemble +test info-40.14 {info cmdtype: dynamic behavior} -setup { + proc ::testinfocmdtype::foo {} {} +} -body { + namespace eval ::testinfocmdtype { + list [catch {info cmdtype foo}] [catch {info cmdtype bar}] \ + [namespace which foo] [rename foo bar] [namespace which bar] \ + [catch {info cmdtype foo}] [catch {info cmdtype bar}] + } +} -cleanup { + namespace eval ::testinfocmdtype { + catch {rename foo {}} + catch {rename bar {}} + } +} -result {0 1 ::testinfocmdtype::foo {} ::testinfocmdtype::bar 1 0} +namespace delete ::testinfocmdtype # ------------------------------------------------------------------------- unset -nocomplain res -- cgit v0.12 From f370c68d92b4669981b3fa2574a2e32fa1911595 Mon Sep 17 00:00:00 2001 From: dkf Date: Thu, 1 Aug 2013 13:21:04 +0000 Subject: Support type discovery in coroutines. --- generic/tclBasic.c | 8 ++++++-- generic/tclZlib.c | 6 ++++++ tests/info.test | 20 ++++++++++++++++++-- 3 files changed, 30 insertions(+), 4 deletions(-) diff --git a/generic/tclBasic.c b/generic/tclBasic.c index 3dfb639..97cdc51 100644 --- a/generic/tclBasic.c +++ b/generic/tclBasic.c @@ -533,6 +533,7 @@ Tcl_CreateInterp(void) TclRegisterCommandTypeName(TclInvokeImportedCmd, "import"); TclRegisterCommandTypeName(TclOOPublicObjectCmd, "object"); TclRegisterCommandTypeName(TclOOPrivateObjectCmd, "privateObject"); + TclRegisterCommandTypeName(TclNRInterpCoroutine, "coroutine"); } /* @@ -1068,12 +1069,15 @@ TclGetCommandTypeName( Tcl_Command command) { Command *cmdPtr = (Command *) command; + void *procPtr = cmdPtr->objProc; const char *name = "native"; + if (procPtr == NULL) { + procPtr = cmdPtr->nreProc; + } Tcl_MutexLock(&commandTypeLock); if (commandTypeInit) { - Tcl_HashEntry *hPtr = Tcl_FindHashEntry(&commandTypeTable, - (void *) cmdPtr->objProc); + Tcl_HashEntry *hPtr = Tcl_FindHashEntry(&commandTypeTable, procPtr); if (hPtr && Tcl_GetHashValue(hPtr)) { name = (const char *) Tcl_GetHashValue(hPtr); diff --git a/generic/tclZlib.c b/generic/tclZlib.c index 9bceb4c..4907b45 100644 --- a/generic/tclZlib.c +++ b/generic/tclZlib.c @@ -3868,6 +3868,12 @@ TclZlibInit( Tcl_RegisterConfig(interp, "zlib", cfg, "iso8859-1"); /* + * Allow command type introspection to do something sensible with streams. + */ + + TclRegisterCommandTypeName(ZlibStreamCmd, "zlibStream"); + + /* * Formally provide the package as a Tcl built-in. */ diff --git a/tests/info.test b/tests/info.test index f3517f9..7cd6678 100644 --- a/tests/info.test +++ b/tests/info.test @@ -19,9 +19,9 @@ if {{::tcltest} ni [namespace children]} { package require tcltest 2 namespace import -force ::tcltest::* } - ::tcltest::loadTestedCommands catch [list package require -exact Tcltest [info patchlevel]] +testConstraint zlib [llength [info commands zlib]] # Set up namespaces needed to test operation of "info args", "info body", # "info default", and "info procs" with imported procedures. @@ -2488,7 +2488,23 @@ test info-40.13 {info cmdtype: ensembles} -setup { } -cleanup { namespace delete ::testinfocmdtype::ensmbl } -result ensemble -test info-40.14 {info cmdtype: dynamic behavior} -setup { +test info-40.14 {info cmdtype: zlib streams} -constraints zlib -setup { + namespace eval ::testinfocmdtype { + rename [zlib stream gzip] zstream + } +} -body { + info cmdtype ::testinfocmdtype::zstream +} -cleanup { + ::testinfocmdtype::zstream close +} -result zlibStream +test info-40.15 {info cmdtype: coroutines} -setup { + coroutine ::testinfocmdtype::coro eval yield +} -body { + info cmdtype ::testinfocmdtype::coro +} -cleanup { + ::testinfocmdtype::coro +} -result coroutine +test info-40.16 {info cmdtype: dynamic behavior} -setup { proc ::testinfocmdtype::foo {} {} } -body { namespace eval ::testinfocmdtype { -- cgit v0.12 From f96b9f2783963a84c437d1d8abc468d88eac3396 Mon Sep 17 00:00:00 2001 From: dkf Date: Thu, 1 Aug 2013 13:27:37 +0000 Subject: And documentation --- doc/info.n | 4 ++++ 1 file changed, 4 insertions(+) diff --git a/doc/info.n b/doc/info.n index 42fe6c3..819991f 100644 --- a/doc/info.n +++ b/doc/info.n @@ -52,6 +52,8 @@ supported types are: .RS .IP \fBalias\fR Indicates that \fIcommandName\fR was created by \fBinterp alias\fR. +.IP \fBcoroutine\fR +Indicates that \fIcommandName\fR was created by \fBcoroutine\fR. .IP \fBensemble\fR Indicates that \fIcommandName\fR was created by \fBnamespace ensemble\fR. .IP \fBimport\fR @@ -69,6 +71,8 @@ that represents an instance of \fBoo::object\fR or one of its subclasses. Indicates that \fIcommandName\fR was created by \fBproc\fR. .IP \fBslave\fR Indicates that \fIcommandName\fR was created by \fBinterp create\fR. +.IP \fBzlibStream\fR +Indicates that \fIcommandName\fR was created by \fBzlib stream\fR. .PP There may be other registered types as well; this is a set that is extensible at the implementation level with \fBTcl_RegisterCommandTypeName\fR. -- cgit v0.12 From 1a73baff0989dad465da8fd91f32d537bf704367 Mon Sep 17 00:00:00 2001 From: dgp Date: Mon, 26 Mar 2018 16:27:40 +0000 Subject: Work in progress implementing TIP 505. --- generic/tclCmdIL.c | 17 +++-------------- generic/tclCompCmdsGR.c | 1 + tests/lreplace.test | 8 ++++---- 3 files changed, 8 insertions(+), 18 deletions(-) diff --git a/generic/tclCmdIL.c b/generic/tclCmdIL.c index 3b2cb19..10fbd3f 100644 --- a/generic/tclCmdIL.c +++ b/generic/tclCmdIL.c @@ -2747,21 +2747,10 @@ Tcl_LreplaceObjCmd( if (first < 0) { first = 0; } - - /* - * Complain if the user asked for a start element that is greater than the - * list length. This won't ever trigger for the "end-*" case as that will - * be properly constrained by TclGetIntForIndex because we use listLen-1 - * (to allow for replacing the last elem). - */ - - if ((first >= listLen) && (listLen > 0)) { - Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "list doesn't contain element %s", TclGetString(objv[2]))); - Tcl_SetErrorCode(interp, "TCL", "OPERATION", "LREPLACE", "BADIDX", - NULL); - return TCL_ERROR; + if (first > listLen) { + first = listLen; } + if (last >= listLen) { last = listLen - 1; } diff --git a/generic/tclCompCmdsGR.c b/generic/tclCompCmdsGR.c index 396947c..ce324c8 100644 --- a/generic/tclCompCmdsGR.c +++ b/generic/tclCompCmdsGR.c @@ -1478,6 +1478,7 @@ TclCompileLreplaceCmd( if (parsePtr->numWords < 4) { return TCL_ERROR; } +return TCL_ERROR; listTokenPtr = TokenAfter(parsePtr->tokenPtr); tokenPtr = TokenAfter(listTokenPtr); diff --git a/tests/lreplace.test b/tests/lreplace.test index 4a6b853..fd2f7f8 100644 --- a/tests/lreplace.test +++ b/tests/lreplace.test @@ -100,10 +100,10 @@ test lreplace-1.26 {lreplace command} { } {a {} {}} test lreplace-1.27 {lreplace command} -body { lreplace x 1 1 -} -returnCodes 1 -result {list doesn't contain element 1} +} -result x test lreplace-1.28 {lreplace command} -body { lreplace x 1 1 y -} -returnCodes 1 -result {list doesn't contain element 1} +} -result {x y} test lreplace-1.29 {lreplace command} -body { lreplace x 1 1 [error foo] } -returnCodes 1 -result {foo} @@ -128,10 +128,10 @@ test lreplace-2.5 {lreplace errors} { } {1 {bad index "1x": must be integer?[+-]integer? or end?[+-]integer?}} test lreplace-2.6 {lreplace errors} { list [catch {lreplace x 3 2} msg] $msg -} {1 {list doesn't contain element 3}} +} {0 x} test lreplace-2.7 {lreplace errors} { list [catch {lreplace x 2 2} msg] $msg -} {1 {list doesn't contain element 2}} +} {0 x} test lreplace-3.1 {lreplace won't modify shared argument objects} { proc p {} { -- cgit v0.12 From 843d29b4486fa92657c326b43383a8e7e860fdf3 Mon Sep 17 00:00:00 2001 From: dgp Date: Mon, 26 Mar 2018 18:59:00 +0000 Subject: Rest of TIP 505 implementation -- mostly undoing dumb things. --- generic/tclCompCmdsGR.c | 60 ++++--------------------------------------------- 1 file changed, 4 insertions(+), 56 deletions(-) diff --git a/generic/tclCompCmdsGR.c b/generic/tclCompCmdsGR.c index ce324c8..1094352 100644 --- a/generic/tclCompCmdsGR.c +++ b/generic/tclCompCmdsGR.c @@ -1472,13 +1472,12 @@ TclCompileLreplaceCmd( { Tcl_Token *tokenPtr, *listTokenPtr; DefineLineInformation; /* TIP #280 */ - int idx1, idx2, i, offset, offset2; + int idx1, idx2, i; int emptyPrefix=1, suffixStart = 0; if (parsePtr->numWords < 4) { return TCL_ERROR; } -return TCL_ERROR; listTokenPtr = TokenAfter(parsePtr->tokenPtr); tokenPtr = TokenAfter(listTokenPtr); @@ -1494,23 +1493,6 @@ return TCL_ERROR; } /* - * idx1, idx2 are the conventional encoded forms of the tokens parsed - * as all forms of index values. Values of idx1 that come before the - * list are treated the same as if they were the start of the list. - * Values of idx2 that come after the list are treated the same as if - * they were the end of the list. - */ - - if (idx1 == TCL_INDEX_AFTER) { - /* - * [lreplace] treats idx1 value end+1 differently from end+2, etc. - * The operand encoding cannot distinguish them, so we must bail - * out to direct evaluation. - */ - return TCL_ERROR; - } - - /* * General structure of the [lreplace] result is * prefix replacement suffix * In a few cases we can predict various parts will be empty and @@ -1521,7 +1503,9 @@ return TCL_ERROR; * we must defer to direct evaluation. */ - if (idx2 == TCL_INDEX_BEFORE) { + if (idx1 == TCL_INDEX_AFTER) { + suffixStart = idx1; + } else if (idx2 == TCL_INDEX_BEFORE) { suffixStart = idx1; } else if (idx2 == TCL_INDEX_END) { suffixStart = TCL_INDEX_AFTER; @@ -1553,42 +1537,6 @@ return TCL_ERROR; emptyPrefix = 0; } - /* - * [lreplace] raises an error when idx1 points after the list, but - * only when the list is not empty. This is maximum stupidity. - * - * TODO: TIP this nonsense away! - */ - if (idx1 >= TCL_INDEX_START) { - if (emptyPrefix) { - TclEmitOpcode( INST_DUP, envPtr); - } else { - TclEmitInstInt4( INST_OVER, 1, envPtr); - } - TclEmitOpcode( INST_LIST_LENGTH, envPtr); - TclEmitOpcode( INST_DUP, envPtr); - offset = CurrentOffset(envPtr); - TclEmitInstInt1( INST_JUMP_FALSE1, 0, envPtr); - - /* List is not empty */ - TclEmitPush(TclAddLiteralObj(envPtr, Tcl_NewIntObj(idx1), - NULL), envPtr); - TclEmitOpcode( INST_GT, envPtr); - offset2 = CurrentOffset(envPtr); - TclEmitInstInt1( INST_JUMP_TRUE1, 0, envPtr); - - /* Idx1 >= list length ===> raise an error */ - TclEmitPush(TclAddLiteralObj(envPtr, Tcl_ObjPrintf( - "list doesn't contain element %d", idx1), NULL), envPtr); - CompileReturnInternal(envPtr, INST_RETURN_IMM, TCL_ERROR, 0, - Tcl_ObjPrintf("-errorcode {TCL OPERATION LREPLACE BADIDX}")); - TclStoreInt1AtPtr(CurrentOffset(envPtr) - offset, - envPtr->codeStart + offset + 1); - TclEmitOpcode( INST_POP, envPtr); - TclStoreInt1AtPtr(CurrentOffset(envPtr) - offset2, - envPtr->codeStart + offset2 + 1); - } - if ((idx1 == suffixStart) && (parsePtr->numWords == 4)) { /* * This is a "no-op". Example: [lreplace {a b c} 2 0] -- cgit v0.12 -- cgit v0.12 From c2fceada6c1e45c299dacdbe6111f97c41b68c98 Mon Sep 17 00:00:00 2001 From: fbonnet Date: Sun, 13 May 2018 22:15:36 +0000 Subject: Initial implementation of TIP #508: [array default] --- generic/tclExecute.c | 5 +- generic/tclInt.h | 6 ++ generic/tclVar.c | 288 ++++++++++++++++++++++++++++++++++++++++++++++++--- 3 files changed, 278 insertions(+), 21 deletions(-) diff --git a/generic/tclExecute.c b/generic/tclExecute.c index fda50b2..7d7384f 100644 --- a/generic/tclExecute.c +++ b/generic/tclExecute.c @@ -4070,10 +4070,7 @@ TEBCresume( TRACE_ERROR(interp); goto gotError; } - TclSetVarArray(varPtr); - varPtr->value.tablePtr = ckalloc(sizeof(TclVarHashTable)); - TclInitVarHashTable(varPtr->value.tablePtr, - TclGetVarNsPtr(varPtr)); + TclInitArrayVar(varPtr); #ifdef TCL_COMPILE_DEBUG TRACE_APPEND(("done\n")); } else { diff --git a/generic/tclInt.h b/generic/tclInt.h index 8f5d8ba..c0630ef 100644 --- a/generic/tclInt.h +++ b/generic/tclInt.h @@ -4100,6 +4100,12 @@ MODULE_SCOPE TclProcessWaitStatus TclProcessWait(Tcl_Pid pid, int options, Tcl_Obj **errorObjPtr); /* + * TIP #508: [array default] + */ + +MODULE_SCOPE void TclInitArrayVar(Var *arrayPtr); + +/* * Utility routines for encoding index values as integers. Used by both * some of the command compilers and by [lsort] and [lsearch]. */ diff --git a/generic/tclVar.c b/generic/tclVar.c index d5e0fa1..78188d2 100644 --- a/generic/tclVar.c +++ b/generic/tclVar.c @@ -198,6 +198,17 @@ static void UnsetVarStruct(Var *varPtr, Var *arrayPtr, Tcl_Obj *part2Ptr, int flags, int index); /* + * TIP #508: [array default] + */ + +static int ArrayDefaultCmd(ClientData clientData, + Tcl_Interp *interp, int objc, + Tcl_Obj *const objv[]); +static void DeleteArrayVar(Var *arrayPtr); +static Tcl_Obj * GetArrayDefault(Var *arrayPtr); +static void SetArrayDefault(Var *arrayPtr, Tcl_Obj *defaultObj); + +/* * Functions defined in this file that may be exported in the future for use * by the bytecode compiler and engine or to the public interface. */ @@ -1015,8 +1026,6 @@ TclLookupArrayElement( { int isNew; Var *varPtr; - TclVarHashTable *tablePtr; - Namespace *nsPtr; /* * We're dealing with an array element. Make sure the variable is an array @@ -1049,16 +1058,7 @@ TclLookupArrayElement( return NULL; } - TclSetVarArray(arrayPtr); - tablePtr = ckalloc(sizeof(TclVarHashTable)); - arrayPtr->value.tablePtr = tablePtr; - - if (TclIsVarInHash(arrayPtr) && TclGetVarNsPtr(arrayPtr)) { - nsPtr = TclGetVarNsPtr(arrayPtr); - } else { - nsPtr = NULL; - } - TclInitVarHashTable(arrayPtr->value.tablePtr, nsPtr); + TclInitArrayVar(arrayPtr); } else if (!TclIsVarArray(arrayPtr)) { if (flags & TCL_LEAVE_ERR_MSG) { TclObjVarErrMsg(interp, arrayNamePtr, elNamePtr, msg, needArray, @@ -1408,6 +1408,13 @@ TclPtrGetVarIdx( return varPtr->value.objPtr; } + /* + * Return the array default value if any. + */ + if (arrayPtr && TclIsVarArray(arrayPtr) && GetArrayDefault(arrayPtr)) { + return GetArrayDefault(arrayPtr); + } + if (flags & TCL_LEAVE_ERR_MSG) { if (TclIsVarUndefined(varPtr) && arrayPtr && !TclIsVarUndefined(arrayPtr)) { @@ -4074,9 +4081,7 @@ ArraySetCmd( return TCL_ERROR; } } - TclSetVarArray(varPtr); - varPtr->value.tablePtr = ckalloc(sizeof(TclVarHashTable)); - TclInitVarHashTable(varPtr->value.tablePtr, TclGetVarNsPtr(varPtr)); + TclInitArrayVar(varPtr); return TCL_OK; } @@ -4356,6 +4361,7 @@ TclInitArrayCmd( { static const EnsembleImplMap arrayImplMap[] = { {"anymore", ArrayAnyMoreCmd, TclCompileBasic2ArgCmd, NULL, NULL, 0}, + {"default", ArrayDefaultCmd, TclCompileBasic2Or3ArgCmd, NULL, NULL, 0}, {"donesearch", ArrayDoneSearchCmd, TclCompileBasic2ArgCmd, NULL, NULL, 0}, {"exists", ArrayExistsCmd, TclCompileArrayExistsCmd, NULL, NULL, 0}, {"for", ArrayForObjCmd, TclCompileBasic3ArgCmd, ArrayForNRCmd, NULL, 0}, @@ -5546,8 +5552,7 @@ DeleteArray( TclClearVarNamespaceVar(elPtr); } - VarHashDeleteTable(varPtr->value.tablePtr); - ckfree(varPtr->value.tablePtr); + DeleteArrayVar(varPtr); } /* @@ -6436,6 +6441,255 @@ CompareVarKeys( } /* + * TIP #508: [array default] + */ + +/* + * The following structure extends the regular TclVarHashTable used by array + * variables to store their optional default value. + */ + +typedef struct ArrayVarHashTable { + TclVarHashTable table; + Tcl_Obj *defaultObj; +} ArrayVarHashTable; + +/*---------------------------------------------------------------------- + * + * ArrayDefaultCmd -- + * + * This function implements the 'array default' Tcl command. + * Refer to the user documentation for details on what it does. + * + * Results: + * Returns a standard Tcl result. + * + * Side effects: + * See the user documentation. + * + *---------------------------------------------------------------------- + */ + + /* ARGSUSED */ +static int +ArrayDefaultCmd( + ClientData clientData, /* Not used. */ + Tcl_Interp *interp, /* Current interpreter. */ + int objc, /* Number of arguments. */ + Tcl_Obj *const objv[]) /* Argument objects. */ +{ + static const char *const options[] = { + "get", "set", "exists", "unset", NULL + }; + enum options { OPT_GET, OPT_SET, OPT_EXISTS, OPT_UNSET }; + Tcl_Obj *arrayNameObj, *defaultValueObj; + Var *varPtr, *arrayPtr; + int isArray, option; + + /* + * Parse arguments. + */ + + if (objc != 3 && objc != 4) { + Tcl_WrongNumArgs(interp, 1, objv, "option arrayName ?value?"); + return TCL_ERROR; + } + if (Tcl_GetIndexFromObj(interp, objv[1], options, "option", + 0, &option) != TCL_OK) { + return TCL_ERROR; + } + + arrayNameObj = objv[2]; + + if (TCL_ERROR == LocateArray(interp, arrayNameObj, &varPtr, &isArray)) { + return TCL_ERROR; + } + + switch (option) { + case OPT_GET: + if (objc != 3) { + Tcl_WrongNumArgs(interp, 2, objv, "arrayName"); + return TCL_ERROR; + } + if (!varPtr || !isArray) { + return NotArrayError(interp, arrayNameObj); + } + + defaultValueObj = GetArrayDefault(varPtr); + if (!defaultValueObj) { + /* Array default must exist. */ + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "array has no default value", -1)); + Tcl_SetErrorCode(interp, "TCL", "READ", "ARRAY", "DEFAULT", NULL); + return TCL_ERROR; + } + Tcl_SetObjResult(interp, defaultValueObj); + return TCL_OK; + + case OPT_SET: + if (objc != 4) { + Tcl_WrongNumArgs(interp, 2, objv, "arrayName value"); + return TCL_ERROR; + } + + /* + * Attempt to create array if needed. + */ + varPtr = TclObjLookupVarEx(interp, arrayNameObj, NULL, + /*flags*/ TCL_LEAVE_ERR_MSG, /*msg*/ "array default set", + /*createPart1*/ 1, /*createPart2*/ 1, &arrayPtr); + if (varPtr == NULL) { + return TCL_ERROR; + } + if (arrayPtr) { + /* + * Not a valid array name. + */ + + CleanupVar(varPtr, arrayPtr); + TclObjVarErrMsg(interp, arrayNameObj, NULL, "array default set", needArray, -1); + Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "VARNAME", + TclGetString(arrayNameObj), NULL); + return TCL_ERROR; + } + if (!TclIsVarArray(varPtr) && !TclIsVarUndefined(varPtr)) { + /* + * Not an array. + */ + + TclObjVarErrMsg(interp, arrayNameObj, NULL, "array default set", + needArray, -1); + Tcl_SetErrorCode(interp, "TCL", "WRITE", "ARRAY", NULL); + return TCL_ERROR; + } + + if (!TclIsVarArray(varPtr)) { + TclInitArrayVar(varPtr); + } + defaultValueObj = objv[3]; + SetArrayDefault(varPtr, defaultValueObj); + return TCL_OK; + + case OPT_EXISTS: + if (objc != 3) { + Tcl_WrongNumArgs(interp, 2, objv, "arrayName"); + return TCL_ERROR; + } + if (varPtr && !isArray) { + return NotArrayError(interp, arrayNameObj); + } + + if (!varPtr) { + Tcl_SetObjResult(interp, Tcl_NewBooleanObj(0)); + } else { + defaultValueObj = GetArrayDefault(varPtr); + Tcl_SetObjResult(interp, Tcl_NewBooleanObj(!!defaultValueObj)); + } + return TCL_OK; + + case OPT_UNSET: + if (objc != 3) { + Tcl_WrongNumArgs(interp, 2, objv, "arrayName"); + return TCL_ERROR; + } + if (varPtr && !isArray) { + return NotArrayError(interp, arrayNameObj); + } + + if (varPtr) { + SetArrayDefault(varPtr, NULL); + } + return TCL_OK; + } + + /* Unreached */ + return TCL_ERROR; +} + +/* + * Initialize array variable. + */ + +void +TclInitArrayVar( + Var *arrayPtr) +{ + ArrayVarHashTable *tablePtr; + + TclSetVarArray(arrayPtr); + + tablePtr = ckalloc(sizeof(ArrayVarHashTable)); + + // Regular TclVarHashTable initialization. + arrayPtr->value.tablePtr = (TclVarHashTable *) tablePtr; + TclInitVarHashTable(arrayPtr->value.tablePtr, TclGetVarNsPtr(arrayPtr)); + + // Default value initialization. + tablePtr->defaultObj = NULL; +} + +/* + * Cleanup array variable. + */ + +static void +DeleteArrayVar( + Var *arrayPtr) +{ + ArrayVarHashTable *tablePtr = (ArrayVarHashTable *) arrayPtr->value.tablePtr; + + // Default value cleanup. + SetArrayDefault(arrayPtr, NULL); + + // Regular TclVarHashTable cleanup. + VarHashDeleteTable(arrayPtr->value.tablePtr); + + ckfree(tablePtr); +} + +/* + * Get array default value if any. + */ + +static Tcl_Obj * +GetArrayDefault( + Var *arrayPtr) +{ + ArrayVarHashTable *tablePtr = (ArrayVarHashTable *) arrayPtr->value.tablePtr; + return tablePtr->defaultObj; +} + +/* + * Set/replace/unset array default value. + */ + +static void +SetArrayDefault( + Var *arrayPtr, + Tcl_Obj *defaultObj) +{ + ArrayVarHashTable *tablePtr = (ArrayVarHashTable *) arrayPtr->value.tablePtr; + + /* + * Increment/decrement refcount twice to ensure that the object is shared, + * so that it doesn't get modified accidentally by the folling code: + * + * array default set v 1 + * lappend v(a) 2; # returns a new object {1 2} + * set v(b); # returns the original default object "1" + */ + if (tablePtr->defaultObj) { + Tcl_DecrRefCount(tablePtr->defaultObj); + Tcl_DecrRefCount(tablePtr->defaultObj); + } + tablePtr->defaultObj = defaultObj; + if (tablePtr->defaultObj) { + Tcl_IncrRefCount(tablePtr->defaultObj); + Tcl_IncrRefCount(tablePtr->defaultObj); + } +} + +/* * Local Variables: * mode: c * c-basic-offset: 4 -- cgit v0.12 From 833b02bc83665b70d5af4696ad54b3d83c51d11b Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Fri, 7 Sep 2018 09:53:17 +0000 Subject: TIP #515 implementation: Level Value Reform --- doc/uplevel.n | 4 +-- generic/tclProc.c | 90 +++++++++++++++++++----------------------------------- tests/uplevel.test | 26 ++++++++-------- 3 files changed, 46 insertions(+), 74 deletions(-) diff --git a/doc/uplevel.n b/doc/uplevel.n index 4decc6d..cda1652 100644 --- a/doc/uplevel.n +++ b/doc/uplevel.n @@ -24,9 +24,9 @@ the result of that evaluation. If \fIlevel\fR is an integer then it gives a distance (up the procedure calling stack) to move before executing the command. If \fIlevel\fR consists of \fB#\fR followed by -a number then the number gives an absolute level number. If \fIlevel\fR +a integer then the level gives an absolute level. If \fIlevel\fR is omitted then it defaults to \fB1\fR. \fILevel\fR cannot be -defaulted if the first \fIcommand\fR argument starts with a digit or \fB#\fR. +defaulted if the first \fIcommand\fR argument is an integer or starts with \fB#\fR. .PP For example, suppose that procedure \fBa\fR was invoked from top-level, and that it called \fBb\fR, and that \fBb\fR called \fBc\fR. diff --git a/generic/tclProc.c b/generic/tclProc.c index 212b680..b9d309f 100644 --- a/generic/tclProc.c +++ b/generic/tclProc.c @@ -688,51 +688,15 @@ TclGetFrame( CallFrame **framePtrPtr) /* Store pointer to frame here (or NULL if * global frame indicated). */ { - register Interp *iPtr = (Interp *) interp; - int curLevel, level, result; - CallFrame *framePtr; - - /* - * Parse string to figure out which level number to go to. - */ - - result = 1; - curLevel = iPtr->varFramePtr->level; - if (*name== '#') { - if (Tcl_GetInt(interp, name+1, &level) != TCL_OK || level < 0) { - goto levelError; - } - } else if (isdigit(UCHAR(*name))) { /* INTL: digit */ - if (Tcl_GetInt(interp, name, &level) != TCL_OK) { - goto levelError; - } - level = curLevel - level; - } else { - level = curLevel - 1; - result = 0; - } - - /* - * Figure out which frame to use, and return it to the caller. - */ - - for (framePtr = iPtr->varFramePtr; framePtr != NULL; - framePtr = framePtr->callerVarPtr) { - if (framePtr->level == level) { - break; - } - } - if (framePtr == NULL) { - goto levelError; - } - - *framePtrPtr = framePtr; - return result; - - levelError: - Tcl_SetObjResult(interp, Tcl_ObjPrintf("bad level \"%s\"", name)); - Tcl_SetErrorCode(interp, "TCL", "VALUE", "STACKLEVEL", NULL); - return -1; + int result; + Tcl_Obj obj; + + obj.bytes = (char *) name; + obj.length = strlen(name); + obj.typePtr = NULL; + result = TclObjGetFrame(interp, &obj, framePtrPtr); + TclFreeIntRep(&obj); + return result; } /* @@ -770,6 +734,7 @@ TclObjGetFrame( register Interp *iPtr = (Interp *) interp; int curLevel, level, result; const char *name = NULL; + Tcl_WideInt w; /* * Parse object to figure out which level number to go to. @@ -785,25 +750,33 @@ TclObjGetFrame( if (objPtr == NULL) { /* Do nothing */ - } else if (TCL_OK == Tcl_GetIntFromObj(NULL, objPtr, &level) - && (level >= 0)) { - level = curLevel - level; - result = 1; + } else if (TCL_OK == Tcl_GetIntFromObj(NULL, objPtr, &level)) { + Tcl_GetWideIntFromObj(NULL, objPtr, &w); + if (w < 0 || w > INT_MAX || curLevel > w + INT_MAX) { + result = -1; + } else { + level = curLevel - level; + result = 1; + } } else if (objPtr->typePtr == &levelReferenceType) { level = (int) objPtr->internalRep.wideValue; result = 1; } else { name = TclGetString(objPtr); if (name[0] == '#') { - if (TCL_OK == Tcl_GetInt(NULL, name+1, &level) && level >= 0) { - TclFreeIntRep(objPtr); - objPtr->typePtr = &levelReferenceType; - objPtr->internalRep.wideValue = level; - result = 1; + if (TCL_OK == Tcl_GetInt(NULL, name+1, &level)) { + if (level < 0 || (level > 0 && name[1] == '-')) { + result = -1; + } else { + TclFreeIntRep(objPtr); + objPtr->typePtr = &levelReferenceType; + objPtr->internalRep.wideValue = level; + result = 1; + } } else { result = -1; } - } else if (isdigit(UCHAR(name[0]))) { /* INTL: digit */ + } else if (TclGetWideBitsFromObj(interp, objPtr, &w) == TCL_OK) { /* * If this were an integer, we'd have succeeded already. * Docs say we have to treat this as a 'bad level' error. @@ -814,7 +787,6 @@ TclObjGetFrame( if (result == 0) { level = curLevel - 1; - name = "1"; } if (result != -1) { if (level >= 0) { @@ -827,11 +799,11 @@ TclObjGetFrame( } } } - if (name == NULL) { - name = TclGetString(objPtr); - } } + if (name == NULL) { + name = TclGetString(objPtr); + } Tcl_SetObjResult(interp, Tcl_ObjPrintf("bad level \"%s\"", name)); Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "LEVEL", name, NULL); return -1; diff --git a/tests/uplevel.test b/tests/uplevel.test index 737c571..be2268a 100644 --- a/tests/uplevel.test +++ b/tests/uplevel.test @@ -137,27 +137,27 @@ test uplevel-4.15 {level parsing} { test uplevel-4.16 {level parsing} { apply {{} {uplevel #[expr 1] {}}} } {} -test uplevel-4.17 {level parsing} { +test uplevel-4.17 {level parsing} -returnCodes error -body { apply {{} {uplevel -0xffffffff {}}} -} {} -test uplevel-4.18 {level parsing} { +} -result {bad level "-0xffffffff"} +test uplevel-4.18 {level parsing} -returnCodes error -body { apply {{} {uplevel #-0xffffffff {}}} -} {} -test uplevel-4.19 {level parsing} { +} -result {bad level "#-0xffffffff"} +test uplevel-4.19 {level parsing} -returnCodes error -body { apply {{} {uplevel [expr -0xffffffff] {}}} -} {} -test uplevel-4.20 {level parsing} { +} -result {bad level "-4294967295"} +test uplevel-4.20 {level parsing} -returnCodes error -body { apply {{} {uplevel #[expr -0xffffffff] {}}} -} {} +} -result {bad level "#-4294967295"} test uplevel-4.21 {level parsing} -body { apply {{} {uplevel -1 {}}} -} -returnCodes error -result {invalid command name "-1"} +} -returnCodes error -result {bad level "-1"} test uplevel-4.22 {level parsing} -body { apply {{} {uplevel #-1 {}}} } -returnCodes error -result {bad level "#-1"} test uplevel-4.23 {level parsing} -body { apply {{} {uplevel [expr -1] {}}} -} -returnCodes error -result {invalid command name "-1"} +} -returnCodes error -result {bad level "-1"} test uplevel-4.24 {level parsing} -body { apply {{} {uplevel #[expr -1] {}}} } -returnCodes error -result {bad level "#-1"} @@ -175,13 +175,13 @@ test uplevel-4.28 {level parsing} -body { } -returnCodes error -result {bad level "#4294967295"} test uplevel-4.29 {level parsing} -body { apply {{} {uplevel 0.2 {}}} -} -returnCodes error -result {bad level "0.2"} +} -returnCodes error -result {invalid command name "0.2"} test uplevel-4.30 {level parsing} -body { apply {{} {uplevel #0.2 {}}} } -returnCodes error -result {bad level "#0.2"} test uplevel-4.31 {level parsing} -body { apply {{} {uplevel [expr 0.2] {}}} -} -returnCodes error -result {bad level "0.2"} +} -returnCodes error -result {invalid command name "0.2"} test uplevel-4.32 {level parsing} -body { apply {{} {uplevel #[expr 0.2] {}}} } -returnCodes error -result {bad level "#0.2"} @@ -193,7 +193,7 @@ test uplevel-4.34 {level parsing} -body { } -returnCodes error -result {bad level "#.2"} test uplevel-4.35 {level parsing} -body { apply {{} {uplevel [expr .2] {}}} -} -returnCodes error -result {bad level "0.2"} +} -returnCodes error -result {invalid command name "0.2"} test uplevel-4.36 {level parsing} -body { apply {{} {uplevel #[expr .2] {}}} } -returnCodes error -result {bad level "#0.2"} -- cgit v0.12 From 0d73b8a7c0c6e90b6c3ed7fcde7b69916b23bedd Mon Sep 17 00:00:00 2001 From: dkf Date: Sat, 8 Sep 2018 12:52:06 +0000 Subject: Implementation of TIP 516 --- generic/tclOODefineCmds.c | 86 +++++++++++++++++++++++++++++++++++++++++------ generic/tclOOScript.h | 28 +++++++++++++-- generic/tclOOScript.tcl | 39 +++++++++++++++++++-- tests/oo.test | 16 ++++----- 4 files changed, 144 insertions(+), 25 deletions(-) diff --git a/generic/tclOODefineCmds.c b/generic/tclOODefineCmds.c index 3c27236..e4a30bb 100644 --- a/generic/tclOODefineCmds.c +++ b/generic/tclOODefineCmds.c @@ -37,14 +37,17 @@ struct DeclaredSlot { const char *name; const Tcl_MethodType getterType; const Tcl_MethodType setterType; + const Tcl_MethodType resolverType; }; -#define SLOT(name,getter,setter) \ +#define SLOT(name,getter,setter,resolver) \ {"::oo::" name, \ {TCL_OO_METHOD_VERSION_CURRENT, "core method: " name " Getter", \ getter, NULL, NULL}, \ {TCL_OO_METHOD_VERSION_CURRENT, "core method: " name " Setter", \ - setter, NULL, NULL}} + setter, NULL, NULL}, \ + {TCL_OO_METHOD_VERSION_CURRENT, "core method: " name " Setter", \ + resolver, NULL, NULL}} /* * Forward declarations. @@ -109,20 +112,23 @@ static int ObjVarsGet(ClientData clientData, static int ObjVarsSet(ClientData clientData, Tcl_Interp *interp, Tcl_ObjectContext context, int objc, Tcl_Obj *const *objv); +static int ResolveClasses(ClientData clientData, + Tcl_Interp *interp, Tcl_ObjectContext context, + int objc, Tcl_Obj *const *objv); /* * Now define the slots used in declarations. */ static const struct DeclaredSlot slots[] = { - SLOT("define::filter", ClassFilterGet, ClassFilterSet), - SLOT("define::mixin", ClassMixinGet, ClassMixinSet), - SLOT("define::superclass", ClassSuperGet, ClassSuperSet), - SLOT("define::variable", ClassVarsGet, ClassVarsSet), - SLOT("objdefine::filter", ObjFilterGet, ObjFilterSet), - SLOT("objdefine::mixin", ObjMixinGet, ObjMixinSet), - SLOT("objdefine::variable", ObjVarsGet, ObjVarsSet), - {NULL, {0, 0, 0, 0, 0}, {0, 0, 0, 0, 0}} + SLOT("define::filter", ClassFilterGet, ClassFilterSet, NULL), + SLOT("define::mixin", ClassMixinGet, ClassMixinSet, ResolveClasses), + SLOT("define::superclass", ClassSuperGet, ClassSuperSet, ResolveClasses), + SLOT("define::variable", ClassVarsGet, ClassVarsSet, NULL), + SLOT("objdefine::filter", ObjFilterGet, ObjFilterSet, NULL), + SLOT("objdefine::mixin", ObjMixinGet, ObjMixinSet, ResolveClasses), + SLOT("objdefine::variable", ObjVarsGet, ObjVarsSet, NULL), + {NULL, {0, 0, 0, 0, 0}, {0, 0, 0, 0, 0}, {0, 0, 0, 0, 0}} }; /* @@ -2063,6 +2069,7 @@ TclOODefineSlots( const struct DeclaredSlot *slotInfoPtr; Tcl_Obj *getName = Tcl_NewStringObj("Get", -1); Tcl_Obj *setName = Tcl_NewStringObj("Set", -1); + Tcl_Obj *resolveName = Tcl_NewStringObj("Resolve", -1); Class *slotCls; slotCls = ((Object *) Tcl_NewObjectInstance(fPtr->interp, (Tcl_Class) @@ -2072,9 +2079,10 @@ TclOODefineSlots( } Tcl_IncrRefCount(getName); Tcl_IncrRefCount(setName); + Tcl_IncrRefCount(resolveName); for (slotInfoPtr = slots ; slotInfoPtr->name ; slotInfoPtr++) { Tcl_Object slotObject = Tcl_NewObjectInstance(fPtr->interp, - (Tcl_Class) slotCls, slotInfoPtr->name, NULL,-1,NULL,0); + (Tcl_Class) slotCls, slotInfoPtr->name, NULL, -1, NULL, 0); if (slotObject == NULL) { continue; @@ -2083,9 +2091,14 @@ TclOODefineSlots( &slotInfoPtr->getterType, NULL); Tcl_NewInstanceMethod(fPtr->interp, slotObject, setName, 0, &slotInfoPtr->setterType, NULL); + if (slotInfoPtr->resolverType.callProc) { + Tcl_NewInstanceMethod(fPtr->interp, slotObject, resolveName, 0, + &slotInfoPtr->resolverType, NULL); + } } Tcl_DecrRefCount(getName); Tcl_DecrRefCount(setName); + Tcl_DecrRefCount(resolveName); return TCL_OK; } @@ -2814,6 +2827,57 @@ ObjVarsSet( return TCL_OK; } + +static int +ResolveClasses( + ClientData clientData, + Tcl_Interp *interp, + Tcl_ObjectContext context, + int objc, + Tcl_Obj *const *objv) +{ + Object *oPtr = (Object *) TclOOGetDefineCmdContext(interp); + int cmdc, i, mustReset = 0; + Tcl_Obj **cmdv, **cmdv2; + + if (Tcl_ObjectContextSkippedArgs(context)+1 != objc) { + Tcl_WrongNumArgs(interp, Tcl_ObjectContextSkippedArgs(context), objv, + "list"); + return TCL_ERROR; + } else if (oPtr == NULL) { + return TCL_ERROR; + } + objv += Tcl_ObjectContextSkippedArgs(context); + if (Tcl_ListObjGetElements(interp, objv[0], &cmdc, + &cmdv) != TCL_OK) { + return TCL_ERROR; + } + + cmdv2 = TclStackAlloc(interp, sizeof(Tcl_Obj *) * cmdc); + + /* + * Resolve each o + */ + + for (i=0 ; ithisPtr); + } + } + + if (mustReset) { + Tcl_ResetResult(interp); + } + Tcl_SetObjResult(interp, Tcl_NewListObj(cmdc, cmdv2)); + TclStackFree(interp, cmdv2); + return TCL_OK; +} + /* * Local Variables: * mode: c diff --git a/generic/tclOOScript.h b/generic/tclOOScript.h index e63bd86..5627bf8 100644 --- a/generic/tclOOScript.h +++ b/generic/tclOOScript.h @@ -147,12 +147,34 @@ static const char *tclOOSetupScript = "\t\tmethod Set list {\n" "\t\t\treturn -code error -errorcode {TCLOO ABSTRACT_SLOT} \"unimplemented\"\n" "\t\t}\n" -"\t\tmethod -set args {tailcall my Set $args}\n" +"\t\tmethod Resolve list {\n" +"\t\t\treturn $list\n" +"\t\t}\n" +"\t\tmethod -set args {\n" +"\t\t\tset args [uplevel 1 [list [namespace which my] Resolve $args]]\n" +"\t\t\ttailcall my Set $args\n" +"\t\t}\n" "\t\tmethod -append args {\n" -"\t\t\tset current [uplevel 1 [list [namespace which my] Get]]\n" +"\t\t\tset my [namespace which my]\n" +"\t\t\tset args [uplevel 1 [list $my Resolve $args]]\n" +"\t\t\tset current [uplevel 1 [list $my Get]]\n" "\t\t\ttailcall my Set [list {*}$current {*}$args]\n" "\t\t}\n" "\t\tmethod -clear {} {tailcall my Set {}}\n" +"\t\tmethod -prepend args {\n" +"\t\t\tset my [namespace which my]\n" +"\t\t\tset args [uplevel 1 [list $my Resolve $args]]\n" +"\t\t\tset current [uplevel 1 [list $my Get]]\n" +"\t\t\ttailcall my Set [list {*}$args {*}$current]\n" +"\t\t}\n" +"\t\tmethod -remove args {\n" +"\t\t\tset my [namespace which my]\n" +"\t\t\tset args [uplevel 1 [list $my Resolve $args]]\n" +"\t\t\tset current [uplevel 1 [list $my Get]]\n" +"\t\t\ttailcall my Set [lmap val $current {\n" +"\t\t\t\tif {$val in $args} continue else {set val}\n" +"\t\t\t}]\n" +"\t\t}\n" "\t\tforward --default-operation my -append\n" "\t\tmethod unknown {args} {\n" "\t\t\tset def --default-operation\n" @@ -163,7 +185,7 @@ static const char *tclOOSetupScript = "\t\t\t}\n" "\t\t\tnext {*}$args\n" "\t\t}\n" -"\t\texport -set -append -clear\n" +"\t\texport -set -append -clear -prepend -remove\n" "\t\tunexport unknown destroy\n" "\t}\n" "\tobjdefine define::superclass forward --default-operation my -set\n" diff --git a/generic/tclOOScript.tcl b/generic/tclOOScript.tcl index d3706ce..30af82a 100644 --- a/generic/tclOOScript.tcl +++ b/generic/tclOOScript.tcl @@ -276,6 +276,20 @@ # ------------------------------------------------------------------ # + # Slot Resolve -- + # + # Helper that lets a slot convert a list of arguments of a + # particular type to their canonical forms. Defaults to doing + # nothing (suitable for simple strings). + # + # ------------------------------------------------------------------ + + method Resolve list { + return $list + } + + # ------------------------------------------------------------------ + # # Slot -set, -append, -clear, --default-operation -- # # Standard public slot operations. If a slot can't figure out @@ -283,12 +297,31 @@ # # ------------------------------------------------------------------ - method -set args {tailcall my Set $args} + method -set args { + set args [uplevel 1 [list [namespace which my] Resolve $args]] + tailcall my Set $args + } method -append args { - set current [uplevel 1 [list [namespace which my] Get]] + set my [namespace which my] + set args [uplevel 1 [list $my Resolve $args]] + set current [uplevel 1 [list $my Get]] tailcall my Set [list {*}$current {*}$args] } method -clear {} {tailcall my Set {}} + method -prepend args { + set my [namespace which my] + set args [uplevel 1 [list $my Resolve $args]] + set current [uplevel 1 [list $my Get]] + tailcall my Set [list {*}$args {*}$current] + } + method -remove args { + set my [namespace which my] + set args [uplevel 1 [list $my Resolve $args]] + set current [uplevel 1 [list $my Get]] + tailcall my Set [lmap val $current { + if {$val in $args} continue else {set val} + }] + } # Default handling forward --default-operation my -append @@ -303,7 +336,7 @@ } # Set up what is exported and what isn't - export -set -append -clear + export -set -append -clear -prepend -remove unexport unknown destroy } diff --git a/tests/oo.test b/tests/oo.test index a303309..2dc9e2a 100644 --- a/tests/oo.test +++ b/tests/oo.test @@ -3920,7 +3920,7 @@ test oo-33.4 {TIP 380: slots - errors} -setup [SampleSlotSetup { } -returnCodes error -cleanup [SampleSlotCleanup { rename $s {} }] -result \ - {unknown method "-grill": must be -append, -clear, -set, contents or ops} + {unknown method "-grill": must be -append, -clear, -prepend, -remove, -set, contents or ops} test oo-34.1 {TIP 380: slots - presence} -setup { set obj [oo::object new] @@ -3950,25 +3950,25 @@ proc getMethods obj { } test oo-34.3 {TIP 380: slots - presence} { getMethods oo::define::filter -} {{-append -clear -set} {Get Set}} +} {{-append -clear -prepend -remove -set} {Get Set}} test oo-34.4 {TIP 380: slots - presence} { getMethods oo::define::mixin -} {{-append -clear -set} {--default-operation Get Set}} +} {{-append -clear -prepend -remove -set} {--default-operation Get Resolve Set}} test oo-34.5 {TIP 380: slots - presence} { getMethods oo::define::superclass -} {{-append -clear -set} {--default-operation Get Set}} +} {{-append -clear -prepend -remove -set} {--default-operation Get Resolve Set}} test oo-34.6 {TIP 380: slots - presence} { getMethods oo::define::variable -} {{-append -clear -set} {Get Set}} +} {{-append -clear -prepend -remove -set} {Get Set}} test oo-34.7 {TIP 380: slots - presence} { getMethods oo::objdefine::filter -} {{-append -clear -set} {Get Set}} +} {{-append -clear -prepend -remove -set} {Get Set}} test oo-34.8 {TIP 380: slots - presence} { getMethods oo::objdefine::mixin -} {{-append -clear -set} {--default-operation Get Set}} +} {{-append -clear -prepend -remove -set} {--default-operation Get Resolve Set}} test oo-34.9 {TIP 380: slots - presence} { getMethods oo::objdefine::variable -} {{-append -clear -set} {Get Set}} +} {{-append -clear -prepend -remove -set} {Get Set}} test oo-35.1 {Bug 9d61624b3d: Empty superclass must not cause crash} -setup { oo::class create fruit { -- cgit v0.12 From 4f178616784e701a7b93586556ffbf292dd173aa Mon Sep 17 00:00:00 2001 From: dkf Date: Mon, 10 Sep 2018 08:33:11 +0000 Subject: Tests and docs --- doc/define.n | 64 +++++++++++++++++++++++++++++++++++++++++++++++---- tests/oo.test | 74 ++++++++++++++++++++++++++++++++++++++++++++++++++++++----- 2 files changed, 128 insertions(+), 10 deletions(-) diff --git a/doc/define.n b/doc/define.n index 6353d00..1030096 100644 --- a/doc/define.n +++ b/doc/define.n @@ -426,7 +426,7 @@ Some of the configurable definitions of a class or object are \fIslotted definitions\fR. This means that the configuration is implemented by a slot object, that is an instance of the class \fBoo::Slot\fR, which manages a list of values (class names, variable names, etc.) that comprises the contents of -the slot. The class defines three operations (as methods) that may be done on +the slot. The class defines five operations (as methods) that may be done on the slot: .TP \fIslot\fR \fB\-append\fR ?\fImember ...\fR? @@ -437,6 +437,16 @@ This appends the given \fImember\fR elements to the slot definition. . This sets the slot definition to the empty list. .TP +\fIslot\fR \fB\-prepend\fR ?\fImember ...\fR? +.VS TIP516 +This prepends the given \fImember\fR elements to the slot definition. +.VE TIP516 +.TP +\fIslot\fR \fB\-remove\fR ?\fImember ...\fR? +.VS TIP516 +This removes the given \fImember\fR elements from the slot definition. +.VE TIP516 +.TP \fIslot\fR \fB\-set\fR ?\fImember ...\fR? . This replaces the slot definition with the given \fImember\fR elements. @@ -454,15 +464,53 @@ and these methods which provide the implementation interface: .TP \fIslot\fR \fBGet\fR . -Returns a list that is the current contents of the slot. This method must +Returns a list that is the current contents of the slot, but does not modify +the slot. This method must always be called from a stack frame created by a +call to \fBoo::define\fR or \fBoo::objdefine\fR. This method \fIshould not\fR +return an error unless it is called from outside a definition context or with +the wrong number of arguments. +.RS +.PP +.VS TIP516 +The elements of the list should be fully resolved, if that is a meaningful +concept to the slot. +.VE TIP516 +.RE +.TP +\fIslot\fR \fBResolve\fR \fIelementList\fR +.VS TIP516 +Returns a list that is the elements of \fIelementList\fR with a resolution +operation applied to each of them, but does not modify the slot. For slots of +simple strings, this is an operation that does nothing. For slots of classes, +this maps each class name to its fully qualified class name. This method must always be called from a stack frame created by a call to \fBoo::define\fR or -\fBoo::objdefine\fR. +\fBoo::objdefine\fR. This method \fIshould not\fR return an error unless it +is called from outside a definition context or with the wrong number of +arguments. +.RS +.PP +Implementations \fIshould not\fR reorder or filter elements in this operation; +uniqueness and ordering constraints should be enforced in the \fBSet\fR +method. This is because this method is not normally presented with the full +contents of the slot (except via the \fB\-set\fR slot operation). +.RE +.VE TIP516 .TP \fIslot\fR \fBSet \fIelementList\fR . Sets the contents of the slot to the list \fIelementList\fR and returns the empty string. This method must always be called from a stack frame created by -a call to \fBoo::define\fR or \fBoo::objdefine\fR. +a call to \fBoo::define\fR or \fBoo::objdefine\fR. This method may return an +error if it rejects the change to the slot contents (e.g., because of invalid +values) as well as if it is called from outside a definition context or with +the wrong number of arguments. +.RS +.PP +This method \fImay\fR reorder and filter the elements if this is necessary in +order to satisfy the underlying constraints of the slot. (For example, slots +of classes enforce a uniqueness constraint that places each element in the +earliest location in the slot that it can.) +.RE .PP The implementation of these methods is slot-dependent (and responsible for accessing the correct part of the class or object definition). Slots also have @@ -470,6 +518,14 @@ an unknown method handler to tie all these pieces together, and they hide their \fBdestroy\fR method so that it is not invoked inadvertently. It is \fIrecommended\fR that any user changes to the slot mechanism be restricted to defining new operations whose names start with a hyphen. +.PP +.VS TIP516 +Most slot operations will initially \fBResolve\fR their argument list, combine +it with the results of the \fBGet\fR method, and then \fBSet\fR the result. +Some operations omit one or both of the first two steps; omitting the third +would result in an idempotent read-only operation (but the standard mechanism +for reading from slots is via \fBinfo class\fR and \fBinfo object\fR). +.VE TIP516 .SH EXAMPLES This example demonstrates how to use both forms of the \fBoo::define\fR and \fBoo::objdefine\fR commands (they work in the same way), as well as diff --git a/tests/oo.test b/tests/oo.test index 2dc9e2a..1093f8d 100644 --- a/tests/oo.test +++ b/tests/oo.test @@ -13,13 +13,11 @@ if {"::tcltest" in [namespace children]} { namespace import -force ::tcltest::* } - # The foundational objects oo::object and oo::class are sensitive to reference # counting errors and are deallocated only when an interp is deleted, so in # this test suite, interp creation and interp deletion are often used in # leaktests in order to leverage this sensitivity. - testConstraint memory [llength [info commands memory]] if {[testConstraint memory]} { proc getbytes {} { @@ -3838,6 +3836,11 @@ proc SampleSlotSetup script { lappend ops [info level] Set $lst return } + method Resolve {lst} { + variable ops + lappend ops [info level] Resolve $lst + return $lst + } } } append script0 \n$script @@ -3872,7 +3875,7 @@ test oo-32.3 {TIP 380: slots - class test} -setup [SampleSlotSetup { [sampleSlot contents] [sampleSlot ops] } -cleanup [SampleSlotCleanup { rename sampleSlot {} -}] -result {0 {} {a b c g h i} {1 Get 1 Set {a b c g h i}}} +}] -result {0 {} {a b c g h i} {1 Resolve {g h i} 1 Get 1 Set {a b c g h i}}} test oo-32.4 {TIP 380: slots - class test} -setup [SampleSlotSetup { SampleSlot create sampleSlot }] -body { @@ -3880,7 +3883,7 @@ test oo-32.4 {TIP 380: slots - class test} -setup [SampleSlotSetup { [sampleSlot contents] [sampleSlot ops] } -cleanup [SampleSlotCleanup { rename sampleSlot {} -}] -result {0 {} {d e f} {1 Set {d e f}}} +}] -result {0 {} {d e f} {1 Resolve {d e f} 1 Set {d e f}}} test oo-32.5 {TIP 380: slots - class test} -setup [SampleSlotSetup { SampleSlot create sampleSlot }] -body { @@ -3888,7 +3891,23 @@ test oo-32.5 {TIP 380: slots - class test} -setup [SampleSlotSetup { [sampleSlot contents] [sampleSlot ops] } -cleanup [SampleSlotCleanup { rename sampleSlot {} -}] -result {0 {} {} {d e f g h i} {1 Set {d e f} 1 Get 1 Set {d e f g h i}}} +}] -result {0 {} {} {d e f g h i} {1 Resolve {d e f} 1 Set {d e f} 1 Resolve {g h i} 1 Get 1 Set {d e f g h i}}} +test oo-32.6 {TIP 516: slots - class test} -setup [SampleSlotSetup { + SampleSlot create sampleSlot +}] -body { + list [info level] [sampleSlot -prepend g h i] \ + [sampleSlot contents] [sampleSlot ops] +} -cleanup [SampleSlotCleanup { + rename sampleSlot {} +}] -result {0 {} {g h i a b c} {1 Resolve {g h i} 1 Get 1 Set {g h i a b c}}} +test oo-32.6 {TIP 516: slots - class test} -setup [SampleSlotSetup { + SampleSlot create sampleSlot +}] -body { + list [info level] [sampleSlot -remove c a] \ + [sampleSlot contents] [sampleSlot ops] +} -cleanup [SampleSlotCleanup { + rename sampleSlot {} +}] -result {0 {} b {1 Resolve {c a} 1 Get 1 Set b}} test oo-33.1 {TIP 380: slots - defaulting} -setup [SampleSlotSetup { set s [SampleSlot new] @@ -3911,7 +3930,7 @@ test oo-33.3 {TIP 380: slots - defaulting} -setup [SampleSlotSetup { list [$s destroy; $s unknown] [$s contents] [$s ops] } -cleanup [SampleSlotCleanup { rename $s {} -}] -result {{} unknown {1 Set destroy 1 Set unknown}} +}] -result {{} unknown {1 Resolve destroy 1 Set destroy 1 Resolve unknown 1 Set unknown}} test oo-33.4 {TIP 380: slots - errors} -setup [SampleSlotSetup { set s [SampleSlot new] }] -body { @@ -3969,6 +3988,49 @@ test oo-34.8 {TIP 380: slots - presence} { test oo-34.9 {TIP 380: slots - presence} { getMethods oo::objdefine::variable } {{-append -clear -prepend -remove -set} {Get Set}} +test oo-34.10 {TIP 516: slots - resolution} -setup { + oo::class create parent + set result {} + oo::class create 516a { superclass parent } + oo::class create 516b { superclass parent } + oo::class create 516c { superclass parent } + namespace eval 516test { + oo::class create 516a { superclass parent } + oo::class create 516b { superclass parent } + oo::class create 516c { superclass parent } + } +} -body { + # Must find the right classes when making the mixin + namespace eval 516test { + oo::define 516a { + mixin 516b 516c + } + } + lappend result [info class mixin 516test::516a] + # Must not remove class with just simple name match + oo::define 516test::516a { + mixin -remove 516b + } + lappend result [info class mixin 516test::516a] + # Must remove class with resolved name match + oo::define 516test::516a { + mixin -remove 516test::516c + } + lappend result [info class mixin 516test::516a] + # Must remove class with resolved name match even after renaming, but only + # with the renamed name; it is a slot of classes, not strings! + rename 516test::516b 516test::516d + oo::define 516test::516a { + mixin -remove 516test::516b + } + lappend result [info class mixin 516test::516a] + oo::define 516test::516a { + mixin -remove 516test::516d + } + lappend result [info class mixin 516test::516a] +} -cleanup { + parent destroy +} -result {{::516test::516b ::516test::516c} {::516test::516b ::516test::516c} ::516test::516b ::516test::516d {}} test oo-35.1 {Bug 9d61624b3d: Empty superclass must not cause crash} -setup { oo::class create fruit { -- cgit v0.12 From 90e3bdc291f94c2e3ff1c4e5b0edb6e203966147 Mon Sep 17 00:00:00 2001 From: dkf Date: Tue, 11 Sep 2018 07:44:04 +0000 Subject: Simplify the slot resolution protocol --- doc/define.n | 25 +++++++++-------- generic/tclOODefineCmds.c | 68 ++++++++++++++++++++++++----------------------- generic/tclOOScript.h | 9 ++++--- generic/tclOOScript.tcl | 9 ++++--- tests/oo.test | 10 +++---- 5 files changed, 62 insertions(+), 59 deletions(-) diff --git a/doc/define.n b/doc/define.n index 1030096..883d5fa 100644 --- a/doc/define.n +++ b/doc/define.n @@ -477,22 +477,21 @@ concept to the slot. .VE TIP516 .RE .TP -\fIslot\fR \fBResolve\fR \fIelementList\fR +\fIslot\fR \fBResolve\fR \fIslotElement\fR .VS TIP516 -Returns a list that is the elements of \fIelementList\fR with a resolution -operation applied to each of them, but does not modify the slot. For slots of -simple strings, this is an operation that does nothing. For slots of classes, -this maps each class name to its fully qualified class name. This method must -always be called from a stack frame created by a call to \fBoo::define\fR or -\fBoo::objdefine\fR. This method \fIshould not\fR return an error unless it -is called from outside a definition context or with the wrong number of -arguments. +Returns \fIslotElement\fR with a resolution operation applied to it, but does +not modify the slot. For slots of simple strings, this is an operation that +does nothing, whereas for slots of classes, this maps a class name to its +fully-qualified class name. This method must always be called from a stack +frame created by a call to \fBoo::define\fR or \fBoo::objdefine\fR. This +method \fIshould not\fR return an error unless it is called from outside a +definition context or with the wrong number of arguments; unresolvable +arguments should be returned as is (as not all slot operations strictly +require that values are resolvable to work). .RS .PP -Implementations \fIshould not\fR reorder or filter elements in this operation; -uniqueness and ordering constraints should be enforced in the \fBSet\fR -method. This is because this method is not normally presented with the full -contents of the slot (except via the \fB\-set\fR slot operation). +Implementations \fIshould not\fR enforce uniqueness and ordering constraints +in this method; that is the responsibility of the \fBSet\fR method. .RE .VE TIP516 .TP diff --git a/generic/tclOODefineCmds.c b/generic/tclOODefineCmds.c index e4a30bb..b68cb0c 100644 --- a/generic/tclOODefineCmds.c +++ b/generic/tclOODefineCmds.c @@ -112,7 +112,7 @@ static int ObjVarsGet(ClientData clientData, static int ObjVarsSet(ClientData clientData, Tcl_Interp *interp, Tcl_ObjectContext context, int objc, Tcl_Obj *const *objv); -static int ResolveClasses(ClientData clientData, +static int ResolveClass(ClientData clientData, Tcl_Interp *interp, Tcl_ObjectContext context, int objc, Tcl_Obj *const *objv); @@ -122,11 +122,11 @@ static int ResolveClasses(ClientData clientData, static const struct DeclaredSlot slots[] = { SLOT("define::filter", ClassFilterGet, ClassFilterSet, NULL), - SLOT("define::mixin", ClassMixinGet, ClassMixinSet, ResolveClasses), - SLOT("define::superclass", ClassSuperGet, ClassSuperSet, ResolveClasses), + SLOT("define::mixin", ClassMixinGet, ClassMixinSet, ResolveClass), + SLOT("define::superclass", ClassSuperGet, ClassSuperSet, ResolveClass), SLOT("define::variable", ClassVarsGet, ClassVarsSet, NULL), SLOT("objdefine::filter", ObjFilterGet, ObjFilterSet, NULL), - SLOT("objdefine::mixin", ObjMixinGet, ObjMixinSet, ResolveClasses), + SLOT("objdefine::mixin", ObjMixinGet, ObjMixinSet, ResolveClass), SLOT("objdefine::variable", ObjVarsGet, ObjVarsSet, NULL), {NULL, {0, 0, 0, 0, 0}, {0, 0, 0, 0, 0}, {0, 0, 0, 0, 0}} }; @@ -2827,54 +2827,56 @@ ObjVarsSet( return TCL_OK; } +/* + * ---------------------------------------------------------------------- + * + * ResolveClass -- + * + * Implementation of the "Resolve" support method for some slots (those + * that are slots around a list of classes). This resolves possible class + * names to their fully-qualified names if possible. + * + * ---------------------------------------------------------------------- + */ static int -ResolveClasses( +ResolveClass( ClientData clientData, Tcl_Interp *interp, Tcl_ObjectContext context, int objc, Tcl_Obj *const *objv) { + int idx = Tcl_ObjectContextSkippedArgs(context); Object *oPtr = (Object *) TclOOGetDefineCmdContext(interp); - int cmdc, i, mustReset = 0; - Tcl_Obj **cmdv, **cmdv2; + Class *clsPtr; - if (Tcl_ObjectContextSkippedArgs(context)+1 != objc) { - Tcl_WrongNumArgs(interp, Tcl_ObjectContextSkippedArgs(context), objv, - "list"); - return TCL_ERROR; - } else if (oPtr == NULL) { + /* + * Check if were called wrongly. The definition context isn't used... + * except that GetClassInOuterContext() assumes that it is there. + */ + + if (oPtr == NULL) { return TCL_ERROR; - } - objv += Tcl_ObjectContextSkippedArgs(context); - if (Tcl_ListObjGetElements(interp, objv[0], &cmdc, - &cmdv) != TCL_OK) { + } else if (objc != idx + 1) { + Tcl_WrongNumArgs(interp, idx, objv, "slotElement"); return TCL_ERROR; } - cmdv2 = TclStackAlloc(interp, sizeof(Tcl_Obj *) * cmdc); - /* - * Resolve each o + * Resolve the class if possible. If not, remove any resolution error and + * return what we've got anyway as the failure might not be fatal overall. */ - for (i=0 ; ithisPtr); - } - } - - if (mustReset) { + clsPtr = GetClassInOuterContext(interp, objv[idx], + "USER SHOULD NOT SEE THIS MESSAGE"); + if (clsPtr == NULL) { Tcl_ResetResult(interp); + Tcl_SetObjResult(interp, objv[idx]); + } else { + Tcl_SetObjResult(interp, TclOOObjectName(interp, clsPtr->thisPtr)); } - Tcl_SetObjResult(interp, Tcl_NewListObj(cmdc, cmdv2)); - TclStackFree(interp, cmdv2); + return TCL_OK; } diff --git a/generic/tclOOScript.h b/generic/tclOOScript.h index 5627bf8..2213ce3 100644 --- a/generic/tclOOScript.h +++ b/generic/tclOOScript.h @@ -151,25 +151,26 @@ static const char *tclOOSetupScript = "\t\t\treturn $list\n" "\t\t}\n" "\t\tmethod -set args {\n" -"\t\t\tset args [uplevel 1 [list [namespace which my] Resolve $args]]\n" +"\t\t\tset my [namespace which my]\n" +"\t\t\tset args [lmap a $args {uplevel 1 [list $my Resolve $a]}]\n" "\t\t\ttailcall my Set $args\n" "\t\t}\n" "\t\tmethod -append args {\n" "\t\t\tset my [namespace which my]\n" -"\t\t\tset args [uplevel 1 [list $my Resolve $args]]\n" +"\t\t\tset args [lmap a $args {uplevel 1 [list $my Resolve $a]}]\n" "\t\t\tset current [uplevel 1 [list $my Get]]\n" "\t\t\ttailcall my Set [list {*}$current {*}$args]\n" "\t\t}\n" "\t\tmethod -clear {} {tailcall my Set {}}\n" "\t\tmethod -prepend args {\n" "\t\t\tset my [namespace which my]\n" -"\t\t\tset args [uplevel 1 [list $my Resolve $args]]\n" +"\t\t\tset args [lmap a $args {uplevel 1 [list $my Resolve $a]}]\n" "\t\t\tset current [uplevel 1 [list $my Get]]\n" "\t\t\ttailcall my Set [list {*}$args {*}$current]\n" "\t\t}\n" "\t\tmethod -remove args {\n" "\t\t\tset my [namespace which my]\n" -"\t\t\tset args [uplevel 1 [list $my Resolve $args]]\n" +"\t\t\tset args [lmap a $args {uplevel 1 [list $my Resolve $a]}]\n" "\t\t\tset current [uplevel 1 [list $my Get]]\n" "\t\t\ttailcall my Set [lmap val $current {\n" "\t\t\t\tif {$val in $args} continue else {set val}\n" diff --git a/generic/tclOOScript.tcl b/generic/tclOOScript.tcl index 30af82a..a48eab5 100644 --- a/generic/tclOOScript.tcl +++ b/generic/tclOOScript.tcl @@ -298,25 +298,26 @@ # ------------------------------------------------------------------ method -set args { - set args [uplevel 1 [list [namespace which my] Resolve $args]] + set my [namespace which my] + set args [lmap a $args {uplevel 1 [list $my Resolve $a]}] tailcall my Set $args } method -append args { set my [namespace which my] - set args [uplevel 1 [list $my Resolve $args]] + set args [lmap a $args {uplevel 1 [list $my Resolve $a]}] set current [uplevel 1 [list $my Get]] tailcall my Set [list {*}$current {*}$args] } method -clear {} {tailcall my Set {}} method -prepend args { set my [namespace which my] - set args [uplevel 1 [list $my Resolve $args]] + set args [lmap a $args {uplevel 1 [list $my Resolve $a]}] set current [uplevel 1 [list $my Get]] tailcall my Set [list {*}$args {*}$current] } method -remove args { set my [namespace which my] - set args [uplevel 1 [list $my Resolve $args]] + set args [lmap a $args {uplevel 1 [list $my Resolve $a]}] set current [uplevel 1 [list $my Get]] tailcall my Set [lmap val $current { if {$val in $args} continue else {set val} diff --git a/tests/oo.test b/tests/oo.test index 1093f8d..033daf5 100644 --- a/tests/oo.test +++ b/tests/oo.test @@ -3875,7 +3875,7 @@ test oo-32.3 {TIP 380: slots - class test} -setup [SampleSlotSetup { [sampleSlot contents] [sampleSlot ops] } -cleanup [SampleSlotCleanup { rename sampleSlot {} -}] -result {0 {} {a b c g h i} {1 Resolve {g h i} 1 Get 1 Set {a b c g h i}}} +}] -result {0 {} {a b c g h i} {1 Resolve g 1 Resolve h 1 Resolve i 1 Get 1 Set {a b c g h i}}} test oo-32.4 {TIP 380: slots - class test} -setup [SampleSlotSetup { SampleSlot create sampleSlot }] -body { @@ -3883,7 +3883,7 @@ test oo-32.4 {TIP 380: slots - class test} -setup [SampleSlotSetup { [sampleSlot contents] [sampleSlot ops] } -cleanup [SampleSlotCleanup { rename sampleSlot {} -}] -result {0 {} {d e f} {1 Resolve {d e f} 1 Set {d e f}}} +}] -result {0 {} {d e f} {1 Resolve d 1 Resolve e 1 Resolve f 1 Set {d e f}}} test oo-32.5 {TIP 380: slots - class test} -setup [SampleSlotSetup { SampleSlot create sampleSlot }] -body { @@ -3891,7 +3891,7 @@ test oo-32.5 {TIP 380: slots - class test} -setup [SampleSlotSetup { [sampleSlot contents] [sampleSlot ops] } -cleanup [SampleSlotCleanup { rename sampleSlot {} -}] -result {0 {} {} {d e f g h i} {1 Resolve {d e f} 1 Set {d e f} 1 Resolve {g h i} 1 Get 1 Set {d e f g h i}}} +}] -result {0 {} {} {d e f g h i} {1 Resolve d 1 Resolve e 1 Resolve f 1 Set {d e f} 1 Resolve g 1 Resolve h 1 Resolve i 1 Get 1 Set {d e f g h i}}} test oo-32.6 {TIP 516: slots - class test} -setup [SampleSlotSetup { SampleSlot create sampleSlot }] -body { @@ -3899,7 +3899,7 @@ test oo-32.6 {TIP 516: slots - class test} -setup [SampleSlotSetup { [sampleSlot contents] [sampleSlot ops] } -cleanup [SampleSlotCleanup { rename sampleSlot {} -}] -result {0 {} {g h i a b c} {1 Resolve {g h i} 1 Get 1 Set {g h i a b c}}} +}] -result {0 {} {g h i a b c} {1 Resolve g 1 Resolve h 1 Resolve i 1 Get 1 Set {g h i a b c}}} test oo-32.6 {TIP 516: slots - class test} -setup [SampleSlotSetup { SampleSlot create sampleSlot }] -body { @@ -3907,7 +3907,7 @@ test oo-32.6 {TIP 516: slots - class test} -setup [SampleSlotSetup { [sampleSlot contents] [sampleSlot ops] } -cleanup [SampleSlotCleanup { rename sampleSlot {} -}] -result {0 {} b {1 Resolve {c a} 1 Get 1 Set b}} +}] -result {0 {} b {1 Resolve c 1 Resolve a 1 Get 1 Set b}} test oo-33.1 {TIP 380: slots - defaulting} -setup [SampleSlotSetup { set s [SampleSlot new] -- cgit v0.12 From be629669a54f0106c40f0bcb78f4493b481d61c6 Mon Sep 17 00:00:00 2001 From: dkf Date: Sun, 23 Sep 2018 17:29:46 +0000 Subject: Added docs --- doc/append.n | 12 +++++++++--- doc/array.n | 53 ++++++++++++++++++++++++++++++++++++++++++++++++++++- doc/dict.n | 35 +++++++++++++++++++++++++++++++++++ doc/incr.n | 9 +++++++++ doc/lappend.n | 10 ++++++++++ 5 files changed, 115 insertions(+), 4 deletions(-) diff --git a/doc/append.n b/doc/append.n index e3bf224..99b4ece 100644 --- a/doc/append.n +++ b/doc/append.n @@ -20,6 +20,11 @@ Append all of the \fIvalue\fR arguments to the current value of variable \fIvarName\fR. If \fIvarName\fR does not exist, it is given a value equal to the concatenation of all the \fIvalue\fR arguments. +.VS TIP508 +If \fIvarName\fR indicate an element that does not exist of an array that has +a default value set, the concatenation of the default value and all the +\fIvalue\fR arguments will be stored in the array element. +.VE TIP508 The result of this command is the new value stored in variable \fIvarName\fR. This command provides an efficient way to build up long @@ -44,6 +49,7 @@ puts $var concat(n), lappend(n) .SH KEYWORDS append, variable -'\" Local Variables: -'\" mode: nroff -'\" End: +.\" Local variables: +.\" mode: nroff +.\" fill-column: 78 +.\" End: diff --git a/doc/array.n b/doc/array.n index d6d4dff..bbfcd9f 100644 --- a/doc/array.n +++ b/doc/array.n @@ -5,7 +5,7 @@ '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" -.TH array n 8.3 Tcl "Tcl Built-In Commands" +.TH array n 8.7 Tcl "Tcl Built-In Commands" .so man.macros .BS '\" Note: do not modify the .SH NAME line immediately below! @@ -36,6 +36,53 @@ with an empty name, since the return value from \fBarray nextelement\fR will not indicate whether the search has been completed. .TP +\fBarray default \fIsubcommand arrayName args...\fR +.VS TIP508 +Manages the default value of the array. Arrays initially have no default +value, but this command allows you to set one; the default value will be +returned when reading from an element of the array \farrayName\fR if the read +would otherwise result in an error. Note that this may cause the \fBappend\fR, +\fBdict\fR, \fBincr\fR and \fBlappend\fR commands to change their behavior in +relation to non-existing array elements. +.RS +.PP +The \fIsubcommand\fR argument controls what exact operation will be performed +on the default value of \fIarrayName\fR. Supported \fIsubcommand\fRs are: +.VE TIP508 +.TP +\fBarray default exists \fIarrayName\fR +.VS TIP508 +This returns a boolean value indicating whether a default value has been set +for the array \fIarrayName\fR. Returns a false value if \fIarrayName\fR does +not exist. Raises an error if \fIarrayName\fR is an existing variable that is +not an array. +.VE TIP508 +.TP +\fBarray default get \fIarrayName\fR +.VS TIP508 +This returns the current default value for the array \fIarrayName\fR. Raises +an error if \fIarrayName\fR is an existing variable that is not an array, or +if \fIarrayName\fR is an array without a default value. +.VE TIP508 +.TP +\fBarray default set \fIarrayName value\fR +.VS TIP508 +This sets the default value for the array \fIarrayName\fR to \fIvalue\fR. +Returns the empty string. Raises an error if \fIarrayName\fR is an existing +variable that is not an array, or if \fIarrayName\fR is an illegal name for an +array. If \fIarrayName\fR does not currently exist, it is created as an empty +array as well as having its default value set. +.VE TIP508 +.TP +\fBarray default unset \fIarrayName\fR +.VS TIP508 +This removes the default value for the array \fIarrayName\fR and returns the +empty string. Does nothing if \fIarrayName\fR does not have a default +value. Raises an error if \fIarrayName\fR is an existing variable that is not +an array. +.VE TIP508 +.RE +.TP \fBarray donesearch \fIarrayName searchId\fR This command terminates an array search and destroys all the state associated with that search. \fISearchId\fR indicates @@ -194,3 +241,7 @@ foreach color [lsort [\fBarray names\fR colorcount]] { list(n), string(n), variable(n), trace(n), foreach(n) .SH KEYWORDS array, element names, search +.\" Local variables: +.\" mode: nroff +.\" fill-column: 78 +.\" End: diff --git a/doc/dict.n b/doc/dict.n index cd7e94c..1829768 100644 --- a/doc/dict.n +++ b/doc/dict.n @@ -27,6 +27,11 @@ key maps to in the dictionary value contained in the given variable, writing the resulting dictionary value back to that variable. Non-existent keys are treated as if they map to an empty string. The updated dictionary value is returned. +.VS TIP508 +If \fIdictionaryVarable\fR indicates an element that does not exist of an +array that has a default value set, the default value and will be used as the +value of the dictionary prior to the appending operation. +.VE TIP508 .TP \fBdict create \fR?\fIkey value ...\fR? . @@ -124,6 +129,11 @@ resulting dictionary value back to that variable. Non-existent keys are treated as if they map to 0. It is an error to increment a value for an existing key if that value is not an integer. The updated dictionary value is returned. +.VS TIP508 +If \fIdictionaryVarable\fR indicates an element that does not exist of an +array that has a default value set, the default value and will be used as the +value of the dictionary prior to the incrementing operation. +.VE TIP508 .TP \fBdict info \fIdictionaryValue\fR . @@ -149,6 +159,11 @@ keys are treated as if they map to an empty list, and it is legal for there to be no items to append to the list. It is an error for the value that the key maps to to not be representable as a list. The updated dictionary value is returned. +.VS TIP508 +If \fIdictionaryVarable\fR indicates an element that does not exist of an +array that has a default value set, the default value and will be used as the +value of the dictionary prior to the list-appending operation. +.VE TIP508 .TP \fBdict map \fR{\fIkeyVariable valueVariable\fR} \fIdictionaryValue body\fR . @@ -206,6 +221,11 @@ value and places an updated dictionary value in that variable containing a mapping from the given key to the given value. When multiple keys are present, this operation creates or updates a chain of nested dictionaries. The updated dictionary value is returned. +.VS TIP508 +If \fIdictionaryVarable\fR indicates an element that does not exist of an +array that has a default value set, the default value and will be used as the +value of the dictionary prior to the value insert/update operation. +.VE TIP508 .TP \fBdict size \fIdictionaryValue\fR . @@ -221,6 +241,11 @@ through nested dictionaries to the mapping to remove. At least one key must be specified, but the last key on the key-path need not exist. All other components on the path must exist. The updated dictionary value is returned. +.VS TIP508 +If \fIdictionaryVarable\fR indicates an element that does not exist of an +array that has a default value set, the default value and will be used as the +value of the dictionary prior to the value remove operation. +.VE TIP508 .TP \fBdict update \fIdictionaryVariable key varName \fR?\fIkey varName ...\fR? \fIbody\fR . @@ -236,6 +261,11 @@ are silently discarded), even if the result of \fIbody\fR is an error or some other kind of exceptional exit. The result of \fBdict update\fR is (unless some kind of error occurs) the result of the evaluation of \fIbody\fR. +.VS TIP508 +If \fIdictionaryVarable\fR indicates an element that does not exist of an +array that has a default value set, the default value and will be used as the +value of the dictionary prior to the update operation. +.VE TIP508 .RS .PP Each \fIvarName\fR is mapped in the scope enclosing the \fBdict update\fR; @@ -270,6 +300,11 @@ dictionary be discarded, and this also happens if the contents of dictionaries no longer exists. The result of \fBdict with\fR is (unless some kind of error occurs) the result of the evaluation of \fIbody\fR. +.VS TIP508 +If \fIdictionaryVarable\fR indicates an element that does not exist of an +array that has a default value set, the default value and will be used as the +value of the dictionary prior to the updating operation. +.VE TIP508 .RS .PP The variables are mapped in the scope enclosing the \fBdict with\fR; diff --git a/doc/incr.n b/doc/incr.n index b4be95c..f491903 100644 --- a/doc/incr.n +++ b/doc/incr.n @@ -27,6 +27,11 @@ and also returned as result. Starting with the Tcl 8.5 release, the variable \fIvarName\fR passed to \fBincr\fR may be unset, and in that case, it will be set to the value \fIincrement\fR or to the default increment value of \fB1\fR. +.VS TIP508 +If \fIvarName\fR indicate an element that does not exist of an array that has +a default value set, the sum of the default value and the \fIincrement\fR (or +1) will be stored in the array element. +.VE TIP508 .SH EXAMPLES .PP Add one to the contents of the variable \fIx\fR: @@ -59,3 +64,7 @@ an error if it is not): expr(n), set(n) .SH KEYWORDS add, increment, variable, value +.\" Local variables: +.\" mode: nroff +.\" fill-column: 78 +.\" End: diff --git a/doc/lappend.n b/doc/lappend.n index 80d075a..66bea5f 100644 --- a/doc/lappend.n +++ b/doc/lappend.n @@ -22,6 +22,12 @@ and appends each of the \fIvalue\fR arguments to that list as a separate element, with spaces between elements. If \fIvarName\fR does not exist, it is created as a list with elements given by the \fIvalue\fR arguments. +.VS TIP508 +If \fIvarName\fR indicate an element that does not exist of an array that has +a default value set, list that is comprised of the default value with all the +\fIvalue\fR arguments appended as elements will be stored in the array +element. +.VE TIP508 \fBLappend\fR is similar to \fBappend\fR except that the \fIvalue\fRs are appended as list elements rather than raw text. This command provides a relatively efficient way to build up @@ -47,3 +53,7 @@ list(n), lindex(n), linsert(n), llength(n), lset(n), lsort(n), lrange(n) .SH KEYWORDS append, element, list, variable +.\" Local variables: +.\" mode: nroff +.\" fill-column: 78 +.\" End: -- cgit v0.12 From 4719e1f68dfa2eefb9988043ea2baa81dbe7ebe5 Mon Sep 17 00:00:00 2001 From: dkf Date: Mon, 24 Sep 2018 08:21:36 +0000 Subject: Add tests. Exposes quite a few bugs in the implementation... --- tests/var.test | 190 ++++++++++++++++++++++++++++++++++++++++++++++++++++++++- 1 file changed, 189 insertions(+), 1 deletion(-) diff --git a/tests/var.test b/tests/var.test index 7b7fc25..a05106f 100644 --- a/tests/var.test +++ b/tests/var.test @@ -1046,7 +1046,7 @@ test var-22.2 {leak in parsedVarName} -constraints memory -body { } -cleanup { unset -nocomplain i x } -result 0 - + unset -nocomplain a k v test var-23.1 {array command, for loop, too many args} -returnCodes error -body { array for {k v} c d e {} @@ -1202,6 +1202,194 @@ test var-23.14 {array for, shared arguments} -setup { } -cleanup { unset -nocomplain $vn vn } -result {} + +test var-24.1 {array default set and get: interpreted} -setup { + unset -nocomplain ary +} -body { + array set ary {a 3} + array default set ary 7 + list $ary(a) $ary(b) [info exist ary(a)] [info exist ary(b)] \ + [array default get ary] +} -cleanup { + unset -nocomplain ary +} -result {3 7 1 0 7} +test var-24.2 {array default set and get: compiled} { + apply {{} { + array set ary {a 3} + array default set ary 7 + list $ary(a) $ary(b) [info exist ary(a)] [info exist ary(b)] \ + [array default get ary] + }} +} {3 7 1 0 7} +test var-24.3 {array default unset: interpreted} -setup { + unset -nocomplain ary +} -body { + array set ary {a 3} + array default set ary 7 + list $ary(a) $ary(b) [array default unset ary] $ary(a) [catch {set ary(b)}] +} -cleanup { + unset -nocomplain ary +} -result {3 7 {} 3 1} +test var-24.4 {array default unset: compiled} { + apply {{} { + array set ary {a 3} + array default set ary 7 + list $ary(a) $ary(b) [array default unset ary] $ary(a) \ + [catch {set ary(b)}] + }} +} {3 7 {} 3 1} +test var-24.5 {array default exists: interpreted} -setup { + unset -nocomplain ary result + set result {} +} -body { + array set ary {a 3} + lappend result [info exists ary],[array exists ary],[array default exists ary] + array default set ary 7 + lappend result [info exists ary],[array exists ary],[array default exists ary] + array default unset ary + lappend result [info exists ary],[array exists ary],[array default exists ary] + unset ary + lappend result [info exists ary],[array exists ary],[array default exists ary] + array default set ary 11 + lappend result [info exists ary],[array exists ary],[array default exists ary] +} -cleanup { + unset -nocomplain ary result +} -result {1,1,0 1,1,1 1,1,0 0,0,0 1,1,1} +test var-24.6 {array default exists: compiled} { + apply {{} { + array set ary {a 3} + lappend result [info exists ary],[array exists ary],[array default exists ary] + array default set ary 7 + lappend result [info exists ary],[array exists ary],[array default exists ary] + array default unset ary + lappend result [info exists ary],[array exists ary],[array default exists ary] + unset ary + lappend result [info exists ary],[array exists ary],[array default exists ary] + array default set ary 11 + lappend result [info exists ary],[array exists ary],[array default exists ary] + }} +} {1,1,0 1,1,1 1,1,0 0,0,0 1,1,1} +test var-24.7 {array default and append: interpreted} -setup { + unset -nocomplain ary result + set result {} +} -body { + array default set ary grill + lappend result [array size ary] [info exist ary(x)] + append ary(x) abc + lappend result [array size ary] $ary(x) + array default unset ary + append ary(x) def + append ary(y) ghi + lappend result [array size ary] $ary(x) $ary(y) +} -cleanup { + unset -nocomplain ary result +} -result {0 0 1 grillabc 2 grillabcdef ghi} +test var-24.8 {array default and append: compiled} { + apply {{} { + array default set ary grill + lappend result [array size ary] [info exist ary(x)] + append ary(x) abc + lappend result [array size ary] $ary(x) + array default unset ary + append ary(x) def + append ary(y) ghi + lappend result [array size ary] $ary(x) $ary(y) + }} +} {0 0 1 grillabc 2 grillabcdef ghi} +test var-24.9 {array default and lappend: interpreted} -setup { + unset -nocomplain ary result + set result {} +} -body { + array default set ary grill + lappend result [array size ary] [info exist ary(x)] + lappend ary(x) abc + lappend result [array size ary] $ary(x) + array default unset ary + lappend ary(x) def + lappend ary(y) ghi + lappend result [array size ary] $ary(x) $ary(y) +} -cleanup { + unset -nocomplain ary result +} -result {0 0 1 {grill abc} 2 {grill abc def} ghi} +test var-24.10 {array default and lappend: compiled} { + apply {{} { + array default set ary grill + lappend result [array size ary] [info exist ary(x)] + lappend ary(x) abc + lappend result [array size ary] $ary(x) + array default unset ary + lappend ary(x) def + lappend ary(y) ghi + lappend result [array size ary] $ary(x) $ary(y) + }} +} {0 0 1 {grill abc} 2 {grill abc def} ghi} +test var-24.11 {array default and incr: interpreted} -setup { + unset -nocomplain ary result + set result {} +} -body { + array default set ary 7 + lappend result [array size ary] [info exist ary(x)] + incr ary(x) 11 + lappend result [array size ary] $ary(x) + array default unset ary + incr ary(x) + incr ary(y) + lappend result [array size ary] $ary(x) $ary(y) +} -cleanup { + unset -nocomplain ary result +} -result {0 0 1 18 2 19 1} +test var-24.12 {array default and incr: compiled} { + apply {{} { + array default set ary 7 + lappend result [array size ary] [info exist ary(x)] + incr ary(x) 11 + lappend result [array size ary] $ary(x) + array default unset ary + incr ary(x) + incr ary(y) + lappend result [array size ary] $ary(x) $ary(y) + }} +} {0 0 1 18 2 19 1} +test var-24.13 {array default and dict: interpreted} -setup { + unset -nocomplain ary x y z +} -body { + array default set ary {x y} + dict lappend ary(p) x z + dict update ary(q) x y { + set y z + } + dict with ary(r) { + set x 123 + } + lsort -stride 2 -index 0 [array get ary] +} -cleanup { + unset -nocomplain ary x y z +} -result {p {x {y z}} q {x z} r {x 123}} +test var-24.14 {array default and dict: compiled} { + lsort -stride 2 -index 0 [apply {{} { + array default set ary {x y} + dict lappend ary(p) x z + dict update ary(q) x y { + set y z + } + dict with ary(r) { + set x 123 + } + array get ary + }}] +} {p {x {y z}} q {x z} r {x 123}} +test var-24.15 {array default set and get: two-level} { + apply {{} { + array set ary {a 3} + array default set ary 7 + apply {{} { + upvar 1 ary ary ary(c) c + lappend result $ary(a) $ary(b) $c + lappend result [info exist ary(a)] [info exist ary(b)] [info exist c] + lappend result [array default get ary] + }} + }} +} {3 7 7 1 0 0 7} catch {namespace delete ns} catch {unset arr} -- cgit v0.12 From 76e2e078e32be366597a31936f3661b3ab42d93e Mon Sep 17 00:00:00 2001 From: dkf Date: Tue, 25 Sep 2018 07:24:44 +0000 Subject: Correct variable existence check in [array default exists] --- generic/tclVar.c | 16 ++++++++++------ 1 file changed, 10 insertions(+), 6 deletions(-) diff --git a/generic/tclVar.c b/generic/tclVar.c index 092d902..6bcd8d8 100644 --- a/generic/tclVar.c +++ b/generic/tclVar.c @@ -247,7 +247,6 @@ static const Tcl_ObjType tclParsedVarNameType = { "parsedVarName", FreeParsedVarName, DupParsedVarName, NULL, NULL }; - Var * TclVarHashCreateVar( @@ -6572,7 +6571,8 @@ ArrayDefaultCmd( */ CleanupVar(varPtr, arrayPtr); - TclObjVarErrMsg(interp, arrayNameObj, NULL, "array default set", needArray, -1); + TclObjVarErrMsg(interp, arrayNameObj, NULL, "array default set", + needArray, -1); Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "VARNAME", TclGetString(arrayNameObj), NULL); return TCL_ERROR; @@ -6600,12 +6600,16 @@ ArrayDefaultCmd( Tcl_WrongNumArgs(interp, 2, objv, "arrayName"); return TCL_ERROR; } - if (varPtr && !isArray) { - return NotArrayError(interp, arrayNameObj); - } - if (!varPtr) { + /* + * Undefined variables (whether or not they have storage allocated) do + * not have defaults, and this is not an error case. + */ + + if (!varPtr || TclIsVarUndefined(varPtr)) { Tcl_SetObjResult(interp, Tcl_NewBooleanObj(0)); + } else if (!isArray) { + return NotArrayError(interp, arrayNameObj); } else { defaultValueObj = GetArrayDefault(varPtr); Tcl_SetObjResult(interp, Tcl_NewBooleanObj(!!defaultValueObj)); -- cgit v0.12 From 7b0e9cef6051f9c59269659da34e1744d074080e Mon Sep 17 00:00:00 2001 From: dkf Date: Tue, 25 Sep 2018 07:27:31 +0000 Subject: More correct variable existence checks --- generic/tclVar.c | 12 ++++++------ 1 file changed, 6 insertions(+), 6 deletions(-) diff --git a/generic/tclVar.c b/generic/tclVar.c index 6bcd8d8..fbe43ac 100644 --- a/generic/tclVar.c +++ b/generic/tclVar.c @@ -6535,7 +6535,7 @@ ArrayDefaultCmd( Tcl_WrongNumArgs(interp, 2, objv, "arrayName"); return TCL_ERROR; } - if (!varPtr || !isArray) { + if (!varPtr || TclIsVarUndefined(varPtr) || !isArray) { return NotArrayError(interp, arrayNameObj); } @@ -6621,11 +6621,11 @@ ArrayDefaultCmd( Tcl_WrongNumArgs(interp, 2, objv, "arrayName"); return TCL_ERROR; } - if (varPtr && !isArray) { - return NotArrayError(interp, arrayNameObj); - } - - if (varPtr) { + + if (varPtr && !TclIsVarUndefined(varPtr)) { + if (!isArray) { + return NotArrayError(interp, arrayNameObj); + } SetArrayDefault(varPtr, NULL); } return TCL_OK; -- cgit v0.12 From beac2287a9fc876159823c0ca79d713b7851ddae Mon Sep 17 00:00:00 2001 From: dkf Date: Tue, 25 Sep 2018 07:36:09 +0000 Subject: Corrected the semantics of [append] with defaults --- generic/tclVar.c | 23 +++++++++++++++++++++-- 1 file changed, 21 insertions(+), 2 deletions(-) diff --git a/generic/tclVar.c b/generic/tclVar.c index fbe43ac..ec48984 100644 --- a/generic/tclVar.c +++ b/generic/tclVar.c @@ -1907,8 +1907,27 @@ TclPtrSetVarIdx( */ if (oldValuePtr == NULL) { - varPtr->value.objPtr = newValuePtr; - Tcl_IncrRefCount(newValuePtr); + if (arrayPtr) { + Tcl_Obj *defValuePtr = GetArrayDefault(arrayPtr); + + if (defValuePtr) { + Tcl_Obj *valuePtr = Tcl_DuplicateObj(defValuePtr); + + varPtr->value.objPtr = valuePtr; + TclContinuationsCopy(valuePtr, defValuePtr); + Tcl_IncrRefCount(valuePtr); + Tcl_AppendObjToObj(valuePtr, newValuePtr); + if (newValuePtr->refCount == 0) { + Tcl_DecrRefCount(newValuePtr); + } + } else { + varPtr->value.objPtr = newValuePtr; + Tcl_IncrRefCount(newValuePtr); + } + } else { + varPtr->value.objPtr = newValuePtr; + Tcl_IncrRefCount(newValuePtr); + } } else { if (Tcl_IsShared(oldValuePtr)) { /* Append to copy. */ varPtr->value.objPtr = Tcl_DuplicateObj(oldValuePtr); -- cgit v0.12 From b1f92f488848d8c4cba71716ecd0264bb976d00b Mon Sep 17 00:00:00 2001 From: dkf Date: Tue, 25 Sep 2018 10:18:32 +0000 Subject: Added test cases for errors --- tests/var.test | 67 ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 67 insertions(+) diff --git a/tests/var.test b/tests/var.test index a05106f..36beb3a 100644 --- a/tests/var.test +++ b/tests/var.test @@ -1390,6 +1390,73 @@ test var-24.15 {array default set and get: two-level} { }} }} } {3 7 7 1 0 0 7} +test var-24.16 {array default set: errors} -setup { + unset -nocomplain ary +} -body { + set ary not-an-array + array default set ary 7 +} -returnCodes error -cleanup { + unset -nocomplain ary +} -result {can't array default set "ary": variable isn't array} +test var-24.17 {array default set: errors} -setup { + unset -nocomplain ary +} -body { + array default set ary +} -returnCodes error -cleanup { + unset -nocomplain ary +} -result * -match glob +test var-24.18 {array default set: errors} -setup { + unset -nocomplain ary +} -body { + array default set ary x y +} -returnCodes error -cleanup { + unset -nocomplain ary +} -result * -match glob +test var-24.19 {array default get: errors} -setup { + unset -nocomplain ary +} -body { + set ary not-an-array + array default get ary +} -returnCodes error -cleanup { + unset -nocomplain ary +} -result {"ary" isn't an array} +test var-24.20 {array default get: errors} -setup { + unset -nocomplain ary +} -body { + array default get ary x y +} -returnCodes error -cleanup { + unset -nocomplain ary +} -result * -match glob +test var-24.21 {array default exists: errors} -setup { + unset -nocomplain ary +} -body { + set ary not-an-array + array default exists ary +} -returnCodes error -cleanup { + unset -nocomplain ary +} -result {"ary" isn't an array} +test var-24.22 {array default exists: errors} -setup { + unset -nocomplain ary +} -body { + array default exists ary x +} -returnCodes error -cleanup { + unset -nocomplain ary +} -result * -match glob +test var-24.23 {array default unset: errors} -setup { + unset -nocomplain ary +} -body { + set ary not-an-array + array default unset ary +} -returnCodes error -cleanup { + unset -nocomplain ary +} -result {"ary" isn't an array} +test var-24.24 {array default unset: errors} -setup { + unset -nocomplain ary +} -body { + array default unset ary x +} -returnCodes error -cleanup { + unset -nocomplain ary +} -result * -match glob catch {namespace delete ns} catch {unset arr} -- cgit v0.12 From 3b77852126dd89aeae123f069e9e8b850b574f21 Mon Sep 17 00:00:00 2001 From: dkf Date: Wed, 26 Sep 2018 08:12:34 +0000 Subject: Fix semantics of [lappend] with defaults in a procedure. --- generic/tclVar.c | 178 +++++++++++++++++++++++++++++++++++++++---------------- 1 file changed, 126 insertions(+), 52 deletions(-) diff --git a/generic/tclVar.c b/generic/tclVar.c index ec48984..6676c6c 100644 --- a/generic/tclVar.c +++ b/generic/tclVar.c @@ -1774,6 +1774,130 @@ TclPtrSetVar( /* *---------------------------------------------------------------------- * + * ListAppendInVar, StringAppendInVar -- + * + * Support functions for TclPtrSetVarIdx that implement various types of + * appending operations. + * + * Results: + * ListAppendInVar returns a Tcl result code (from the core list append + * operation). StringAppendInVar has no return value. + * + * Side effects: + * The variable or element of the array is updated. This may make the + * variable/element exist. Reference counts of values may be updated. + * + *---------------------------------------------------------------------- + */ + +static inline int +ListAppendInVar( + Tcl_Interp *interp, + Var *varPtr, + Var *arrayPtr, + Tcl_Obj *oldValuePtr, + Tcl_Obj *newValuePtr) +{ + if (oldValuePtr == NULL) { + /* + * No previous value. Check for defaults if there's an array we can + * ask this of. + */ + + if (arrayPtr) { + Tcl_Obj *defValuePtr = GetArrayDefault(arrayPtr); + + if (defValuePtr) { + oldValuePtr = Tcl_DuplicateObj(defValuePtr); + } + } + + if (oldValuePtr == NULL) { + /* + * No default. [lappend] semantics say this is like being an empty + * string. + */ + + TclNewObj(oldValuePtr); + } + varPtr->value.objPtr = oldValuePtr; + Tcl_IncrRefCount(oldValuePtr); /* Since var is referenced. */ + } else if (Tcl_IsShared(oldValuePtr)) { + varPtr->value.objPtr = Tcl_DuplicateObj(oldValuePtr); + TclDecrRefCount(oldValuePtr); + oldValuePtr = varPtr->value.objPtr; + Tcl_IncrRefCount(oldValuePtr); /* Since var is referenced. */ + } + + return Tcl_ListObjAppendElement(interp, oldValuePtr, newValuePtr); +} + +static inline void +StringAppendInVar( + Var *varPtr, + Var *arrayPtr, + Tcl_Obj *oldValuePtr, + Tcl_Obj *newValuePtr) +{ + /* + * If there was no previous value, either we use the array's default (if + * this is an array with a default at all) or we treat this as a simple + * set. + */ + + if (oldValuePtr == NULL) { + if (arrayPtr) { + Tcl_Obj *defValuePtr = GetArrayDefault(arrayPtr); + + if (defValuePtr) { + /* + * This is *almost* the same as the shared path below, except + * that the original value reference in defValuePtr is not + * decremented. + */ + + Tcl_Obj *valuePtr = Tcl_DuplicateObj(defValuePtr); + + varPtr->value.objPtr = valuePtr; + TclContinuationsCopy(valuePtr, defValuePtr); + Tcl_IncrRefCount(valuePtr); + Tcl_AppendObjToObj(valuePtr, newValuePtr); + if (newValuePtr->refCount == 0) { + Tcl_DecrRefCount(newValuePtr); + } + return; + } + } + varPtr->value.objPtr = newValuePtr; + Tcl_IncrRefCount(newValuePtr); + return; + } + + /* + * We append newValuePtr's bytes but don't change its ref count. Unless + * the reference is shared, when we have to duplicate in order to be safe + * to modify at all. + */ + + if (Tcl_IsShared(oldValuePtr)) { /* Append to copy. */ + varPtr->value.objPtr = Tcl_DuplicateObj(oldValuePtr); + + TclContinuationsCopy(varPtr->value.objPtr, oldValuePtr); + + TclDecrRefCount(oldValuePtr); + oldValuePtr = varPtr->value.objPtr; + Tcl_IncrRefCount(oldValuePtr); /* Since var is ref */ + } + + Tcl_AppendObjToObj(oldValuePtr, newValuePtr); + if (newValuePtr->refCount == 0) { + Tcl_DecrRefCount(newValuePtr); + } +} + +/* + *---------------------------------------------------------------------- + * * TclPtrSetVarIdx -- * * This function is the same as Tcl_SetVar2Ex above, except that it @@ -1886,63 +2010,13 @@ TclPtrSetVarIdx( } if (flags & (TCL_APPEND_VALUE|TCL_LIST_ELEMENT)) { if (flags & TCL_LIST_ELEMENT) { /* Append list element. */ - if (oldValuePtr == NULL) { - TclNewObj(oldValuePtr); - varPtr->value.objPtr = oldValuePtr; - Tcl_IncrRefCount(oldValuePtr); /* Since var is referenced. */ - } else if (Tcl_IsShared(oldValuePtr)) { - varPtr->value.objPtr = Tcl_DuplicateObj(oldValuePtr); - TclDecrRefCount(oldValuePtr); - oldValuePtr = varPtr->value.objPtr; - Tcl_IncrRefCount(oldValuePtr); /* Since var is referenced. */ - } - result = Tcl_ListObjAppendElement(interp, oldValuePtr, + result = ListAppendInVar(interp, varPtr, arrayPtr, oldValuePtr, newValuePtr); if (result != TCL_OK) { goto earlyError; } } else { /* Append string. */ - /* - * We append newValuePtr's bytes but don't change its ref count. - */ - - if (oldValuePtr == NULL) { - if (arrayPtr) { - Tcl_Obj *defValuePtr = GetArrayDefault(arrayPtr); - - if (defValuePtr) { - Tcl_Obj *valuePtr = Tcl_DuplicateObj(defValuePtr); - - varPtr->value.objPtr = valuePtr; - TclContinuationsCopy(valuePtr, defValuePtr); - Tcl_IncrRefCount(valuePtr); - Tcl_AppendObjToObj(valuePtr, newValuePtr); - if (newValuePtr->refCount == 0) { - Tcl_DecrRefCount(newValuePtr); - } - } else { - varPtr->value.objPtr = newValuePtr; - Tcl_IncrRefCount(newValuePtr); - } - } else { - varPtr->value.objPtr = newValuePtr; - Tcl_IncrRefCount(newValuePtr); - } - } else { - if (Tcl_IsShared(oldValuePtr)) { /* Append to copy. */ - varPtr->value.objPtr = Tcl_DuplicateObj(oldValuePtr); - - TclContinuationsCopy(varPtr->value.objPtr, oldValuePtr); - - TclDecrRefCount(oldValuePtr); - oldValuePtr = varPtr->value.objPtr; - Tcl_IncrRefCount(oldValuePtr); /* Since var is ref */ - } - Tcl_AppendObjToObj(oldValuePtr, newValuePtr); - if (newValuePtr->refCount == 0) { - Tcl_DecrRefCount(newValuePtr); - } - } + StringAppendInVar(varPtr, arrayPtr, oldValuePtr, newValuePtr); } } else if (newValuePtr != oldValuePtr) { /* -- cgit v0.12 From 761a7867d59650fe2a632e377c216fc8b39beaf3 Mon Sep 17 00:00:00 2001 From: dkf Date: Wed, 26 Sep 2018 13:08:46 +0000 Subject: Make defaults work even when [upvar]ed to just a non-existent element. --- generic/tclInt.h | 1 + generic/tclVar.c | 104 +++++++++++++++++++++++++++++++++-------------------- tests/set-old.test | 4 +-- 3 files changed, 69 insertions(+), 40 deletions(-) diff --git a/generic/tclInt.h b/generic/tclInt.h index 40fae04..d4992dc 100644 --- a/generic/tclInt.h +++ b/generic/tclInt.h @@ -4142,6 +4142,7 @@ MODULE_SCOPE TclProcessWaitStatus TclProcessWait(Tcl_Pid pid, int options, */ MODULE_SCOPE void TclInitArrayVar(Var *arrayPtr); +MODULE_SCOPE Tcl_Obj * TclGetArrayDefault(Var *arrayPtr); /* * Utility routines for encoding index values as integers. Used by both diff --git a/generic/tclVar.c b/generic/tclVar.c index b2cbebe..8860df5 100644 --- a/generic/tclVar.c +++ b/generic/tclVar.c @@ -165,6 +165,18 @@ typedef struct ArraySearch { } ArraySearch; /* + * TIP #508: [array default] + * + * The following structure extends the regular TclVarHashTable used by array + * variables to store their optional default value. + */ + +typedef struct ArrayVarHashTable { + TclVarHashTable table; + Tcl_Obj *defaultObj; +} ArrayVarHashTable; + +/* * Forward references to functions defined later in this file: */ @@ -205,7 +217,6 @@ static int ArrayDefaultCmd(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); static void DeleteArrayVar(Var *arrayPtr); -static Tcl_Obj * GetArrayDefault(Var *arrayPtr); static void SetArrayDefault(Var *arrayPtr, Tcl_Obj *defaultObj); /* @@ -1414,8 +1425,21 @@ TclPtrGetVarIdx( /* * Return the array default value if any. */ - if (arrayPtr && TclIsVarArray(arrayPtr) && GetArrayDefault(arrayPtr)) { - return GetArrayDefault(arrayPtr); + + if (arrayPtr && TclIsVarArray(arrayPtr) && TclGetArrayDefault(arrayPtr)) { + return TclGetArrayDefault(arrayPtr); + } + if (TclIsVarArrayElement(varPtr) && !arrayPtr) { + /* + * UGLY! Peek inside the implementation of things. + */ + + ArrayVarHashTable *avhtPtr = (ArrayVarHashTable *) + ((VarInHash *) varPtr)->entry.tablePtr; + + if (avhtPtr->defaultObj) { + return avhtPtr->defaultObj; + } } if (flags & TCL_LEAVE_ERR_MSG) { @@ -1809,7 +1833,7 @@ ListAppendInVar( */ if (arrayPtr) { - Tcl_Obj *defValuePtr = GetArrayDefault(arrayPtr); + Tcl_Obj *defValuePtr = TclGetArrayDefault(arrayPtr); if (defValuePtr) { oldValuePtr = Tcl_DuplicateObj(defValuePtr); @@ -1851,7 +1875,7 @@ StringAppendInVar( if (oldValuePtr == NULL) { if (arrayPtr) { - Tcl_Obj *defValuePtr = GetArrayDefault(arrayPtr); + Tcl_Obj *defValuePtr = TclGetArrayDefault(arrayPtr); if (defValuePtr) { /* @@ -6564,25 +6588,11 @@ CompareVarKeys( return ((l1 == l2) && !memcmp(p1, p2, l1)); } -/* - * TIP #508: [array default] - */ - -/* - * The following structure extends the regular TclVarHashTable used by array - * variables to store their optional default value. - */ - -typedef struct ArrayVarHashTable { - TclVarHashTable table; - Tcl_Obj *defaultObj; -} ArrayVarHashTable; - /*---------------------------------------------------------------------- * * ArrayDefaultCmd -- * - * This function implements the 'array default' Tcl command. + * This function implements the 'array default' Tcl command. * Refer to the user documentation for details on what it does. * * Results: @@ -6639,7 +6649,7 @@ ArrayDefaultCmd( return NotArrayError(interp, arrayNameObj); } - defaultValueObj = GetArrayDefault(varPtr); + defaultValueObj = TclGetArrayDefault(varPtr); if (!defaultValueObj) { /* Array default must exist. */ Tcl_SetObjResult(interp, Tcl_NewStringObj( @@ -6660,7 +6670,7 @@ ArrayDefaultCmd( * Attempt to create array if needed. */ varPtr = TclObjLookupVarEx(interp, arrayNameObj, NULL, - /*flags*/ TCL_LEAVE_ERR_MSG, /*msg*/ "array default set", + /*flags*/ TCL_LEAVE_ERR_MSG, /*msg*/ "array default set", /*createPart1*/ 1, /*createPart2*/ 1, &arrayPtr); if (varPtr == NULL) { return TCL_ERROR; @@ -6669,7 +6679,7 @@ ArrayDefaultCmd( /* * Not a valid array name. */ - + CleanupVar(varPtr, arrayPtr); TclObjVarErrMsg(interp, arrayNameObj, NULL, "array default set", needArray, -1); @@ -6711,7 +6721,7 @@ ArrayDefaultCmd( } else if (!isArray) { return NotArrayError(interp, arrayNameObj); } else { - defaultValueObj = GetArrayDefault(varPtr); + defaultValueObj = TclGetArrayDefault(varPtr); Tcl_SetObjResult(interp, Tcl_NewBooleanObj(!!defaultValueObj)); } return TCL_OK; @@ -6743,17 +6753,25 @@ void TclInitArrayVar( Var *arrayPtr) { - ArrayVarHashTable *tablePtr; + ArrayVarHashTable *tablePtr = ckalloc(sizeof(ArrayVarHashTable)); + + /* + * Mark the variable as an array. + */ TclSetVarArray(arrayPtr); - tablePtr = ckalloc(sizeof(ArrayVarHashTable)); + /* + * Regular TclVarHashTable initialization. + */ - // Regular TclVarHashTable initialization. arrayPtr->value.tablePtr = (TclVarHashTable *) tablePtr; TclInitVarHashTable(arrayPtr->value.tablePtr, TclGetVarNsPtr(arrayPtr)); - // Default value initialization. + /* + * Default value initialization. + */ + tablePtr->defaultObj = NULL; } @@ -6765,14 +6783,20 @@ static void DeleteArrayVar( Var *arrayPtr) { - ArrayVarHashTable *tablePtr = (ArrayVarHashTable *) arrayPtr->value.tablePtr; + ArrayVarHashTable *tablePtr = (ArrayVarHashTable *) + arrayPtr->value.tablePtr; + + /* + * Default value cleanup. + */ - // Default value cleanup. SetArrayDefault(arrayPtr, NULL); - // Regular TclVarHashTable cleanup. - VarHashDeleteTable(arrayPtr->value.tablePtr); + /* + * Regular TclVarHashTable cleanup. + */ + VarHashDeleteTable(arrayPtr->value.tablePtr); ckfree(tablePtr); } @@ -6780,11 +6804,13 @@ DeleteArrayVar( * Get array default value if any. */ -static Tcl_Obj * -GetArrayDefault( +Tcl_Obj * +TclGetArrayDefault( Var *arrayPtr) { - ArrayVarHashTable *tablePtr = (ArrayVarHashTable *) arrayPtr->value.tablePtr; + ArrayVarHashTable *tablePtr = (ArrayVarHashTable *) + arrayPtr->value.tablePtr; + return tablePtr->defaultObj; } @@ -6797,16 +6823,18 @@ SetArrayDefault( Var *arrayPtr, Tcl_Obj *defaultObj) { - ArrayVarHashTable *tablePtr = (ArrayVarHashTable *) arrayPtr->value.tablePtr; - + ArrayVarHashTable *tablePtr = (ArrayVarHashTable *) + arrayPtr->value.tablePtr; + /* * Increment/decrement refcount twice to ensure that the object is shared, * so that it doesn't get modified accidentally by the folling code: - * + * * array default set v 1 * lappend v(a) 2; # returns a new object {1 2} * set v(b); # returns the original default object "1" */ + if (tablePtr->defaultObj) { Tcl_DecrRefCount(tablePtr->defaultObj); Tcl_DecrRefCount(tablePtr->defaultObj); diff --git a/tests/set-old.test b/tests/set-old.test index b2e7aa6..ea5155b 100644 --- a/tests/set-old.test +++ b/tests/set-old.test @@ -340,7 +340,7 @@ test set-old-8.6 {array command} { catch {unset a} set a(22) 3 list [catch {array gorp a} msg] $msg -} {1 {unknown or ambiguous subcommand "gorp": must be anymore, donesearch, exists, for, get, names, nextelement, set, size, startsearch, statistics, or unset}} +} {1 {unknown or ambiguous subcommand "gorp": must be anymore, default, donesearch, exists, for, get, names, nextelement, set, size, startsearch, statistics, or unset}} test set-old-8.7 {array command, anymore option} { catch {unset a} list [catch {array anymore a x} msg] $msg @@ -700,7 +700,7 @@ test set-old-9.1 {ids for array enumeration} { catch {unset a} set a(a) 1 list [array star a] [array star a] [array done a s-1-a; array star a] \ - [array done a s-2-a; array d a s-3-a; array start a] + [array done a s-2-a; array do a s-3-a; array start a] } {s-1-a s-2-a s-3-a s-1-a} test set-old-9.2 {array enumeration} { catch {unset a} -- cgit v0.12 From 9aa47b2cfa64ee148cbc6dace75fbab5a48209b8 Mon Sep 17 00:00:00 2001 From: dkf Date: Wed, 26 Sep 2018 13:09:20 +0000 Subject: Improved comment. --- generic/tclVar.c | 4 +++- 1 file changed, 3 insertions(+), 1 deletion(-) diff --git a/generic/tclVar.c b/generic/tclVar.c index 8860df5..cafa6a3 100644 --- a/generic/tclVar.c +++ b/generic/tclVar.c @@ -1431,7 +1431,9 @@ TclPtrGetVarIdx( } if (TclIsVarArrayElement(varPtr) && !arrayPtr) { /* - * UGLY! Peek inside the implementation of things. + * UGLY! Peek inside the implementation of things. This lets us get + * the default of an array even when we've been [upvar]ed to just an + * element of the array. */ ArrayVarHashTable *avhtPtr = (ArrayVarHashTable *) -- cgit v0.12 From bf46b6a1dac0ded399af13fb18a2cfa7cec8caea Mon Sep 17 00:00:00 2001 From: dkf Date: Thu, 27 Sep 2018 07:44:50 +0000 Subject: Updated documentation --- doc/lreplace.n | 34 ++++++++++++++++++++++++++++++++-- 1 file changed, 32 insertions(+), 2 deletions(-) diff --git a/doc/lreplace.n b/doc/lreplace.n index d19f0cd..35a9130 100644 --- a/doc/lreplace.n +++ b/doc/lreplace.n @@ -30,13 +30,26 @@ list, and \fBend\fR refers to the last element of the list. If \fIlist\fR is empty, then \fIfirst\fR and \fIlast\fR are ignored. .PP If \fIfirst\fR is less than zero, it is considered to refer to before the -first element of the list. For non-empty lists, the element indicated -by \fIfirst\fR must exist or \fIfirst\fR must indicate before the +first element of the list. +.VS TIP505 +If \fIfirst\fR indicates a position greater than the index of the last element +of the list, it is treated as if it is an index one greater than the last +element. This allows this command to append elements to the list. +.VE TIP505 +For non-empty lists, the element indicated +by \fIfirst\fR must exist, or \fIfirst\fR must indicate before the start of the list. .PP If \fIlast\fR is less than \fIfirst\fR, then any specified elements will be inserted into the list before the point specified by \fIfirst\fR with no elements being deleted. +.VS TIP505 +If \fIlast\fR is greater than the index of the last item of the list, it is +treated as if it is an index one greater than the last element. This means +that if it is also greater than than \fIfirst\fR, all elements from +\fIfirst\fR to the end of the list will be replaced, and otherwise the +elements will be appended. +.VE TIP505 .PP The \fIelement\fR arguments specify zero or more new arguments to be added to the list in place of those that were deleted. @@ -78,9 +91,26 @@ proc lremove {listVariable value} { set var [\fBlreplace\fR $var $idx $idx] } .CE +.PP +.VS TIP505 +Adding elements to the end of the list; note that \fBend+2\fR will initially +be treated as if it is \fB6\fR here, but both that and \fB12345\fR are greater +than the index of the final item so they behave identically: +.PP +.CS +% set var {a b c d e} +a b c d e +% set var [\fBlreplace\fR $var 12345 end+2 f g h i] +a b c d e f g h i +.CE +.VE TIP505 .SH "SEE ALSO" list(n), lappend(n), lindex(n), linsert(n), llength(n), lsearch(n), lset(n), lrange(n), lsort(n), string(n) .SH KEYWORDS element, list, replace +.\" Local variables: +.\" mode: nroff +.\" fill-column: 78 +.\" End: -- cgit v0.12 From 6ec7c04557d86c9e5ddec92b3594634dba89e007 Mon Sep 17 00:00:00 2001 From: dkf Date: Thu, 27 Sep 2018 11:06:59 +0000 Subject: Restricted the information made available to safe interpreters a bit. --- doc/info.n | 8 +++-- generic/tclBasic.c | 1 + generic/tclCmdIL.c | 16 ++++++++-- generic/tclInt.h | 1 + generic/tclInterp.c | 84 +++++++++++++++++++++++++++++++++++++++++++++++++---- tests/info.test | 43 +++++++++++++++++++++++++++ 6 files changed, 142 insertions(+), 11 deletions(-) diff --git a/doc/info.n b/doc/info.n index 99d11d5..5732a13 100644 --- a/doc/info.n +++ b/doc/info.n @@ -45,12 +45,14 @@ Returns a count of the total number of commands that have been invoked in this interpreter. .TP \fBinfo cmdtype \fIcommandName\fR -.VS "info cmdtype feature" +.VS TIP426 Returns a description of the kind of command named by \fIcommandName\fR. The supported types are: .RS .IP \fBalias\fR -Indicates that \fIcommandName\fR was created by \fBinterp alias\fR. +Indicates that \fIcommandName\fR was created by \fBinterp alias\fR. Note that +safe interpreters can only see a subset of aliases (specifically those between +two commands within themselves). .IP \fBcoroutine\fR Indicates that \fIcommandName\fR was created by \fBcoroutine\fR. .IP \fBensemble\fR @@ -76,7 +78,7 @@ Indicates that \fIcommandName\fR was created by \fBzlib stream\fR. There may be other registered types as well; this is a set that is extensible at the implementation level with \fBTcl_RegisterCommandTypeName\fR. .RE -.VE "info cmdtype feature" +.VE TIP426 .TP \fBinfo commands \fR?\fIpattern\fR? . diff --git a/generic/tclBasic.c b/generic/tclBasic.c index 37f0560..da43a5d 100644 --- a/generic/tclBasic.c +++ b/generic/tclBasic.c @@ -530,6 +530,7 @@ Tcl_CreateInterp(void) TclRegisterCommandTypeName(TclObjInterpProc, "proc"); TclRegisterCommandTypeName(TclEnsembleImplementationCmd, "ensemble"); TclRegisterCommandTypeName(TclAliasObjCmd, "alias"); + TclRegisterCommandTypeName(TclLocalAliasObjCmd, "alias"); TclRegisterCommandTypeName(TclSlaveObjCmd, "slave"); TclRegisterCommandTypeName(TclInvokeImportedCmd, "import"); TclRegisterCommandTypeName(TclOOPublicObjectCmd, "object"); diff --git a/generic/tclCmdIL.c b/generic/tclCmdIL.c index 8454db1..1dae740 100644 --- a/generic/tclCmdIL.c +++ b/generic/tclCmdIL.c @@ -158,7 +158,7 @@ static const EnsembleImplMap defaultInfoMap[] = { {"args", InfoArgsCmd, TclCompileBasic1ArgCmd, NULL, NULL, 0}, {"body", InfoBodyCmd, TclCompileBasic1ArgCmd, NULL, NULL, 0}, {"cmdcount", InfoCmdCountCmd, TclCompileBasic0ArgCmd, NULL, NULL, 0}, - {"cmdtype", InfoCmdTypeCmd, TclCompileBasic1ArgCmd, NULL, NULL, 0}, + {"cmdtype", InfoCmdTypeCmd, TclCompileBasic1ArgCmd, NULL, NULL, 1}, {"commands", InfoCommandsCmd, TclCompileInfoCommandsCmd, NULL, NULL, 0}, {"complete", InfoCompleteCmd, TclCompileBasic1ArgCmd, NULL, NULL, 0}, {"coroutine", TclInfoCoroutineCmd, TclCompileInfoCoroutineCmd, NULL, NULL, 0}, @@ -2171,8 +2171,18 @@ InfoCmdTypeCmd( return TCL_ERROR; } - Tcl_SetObjResult(interp, - Tcl_NewStringObj(TclGetCommandTypeName(command), -1)); + /* + * There's one special case: safe slave interpreters can't see aliases as + * aliases as they're part of the security mechanisms. + */ + + if (Tcl_IsSafe(interp) + && (((Command *) command)->objProc == TclAliasObjCmd)) { + Tcl_AppendResult(interp, "native", NULL); + } else { + Tcl_SetObjResult(interp, + Tcl_NewStringObj(TclGetCommandTypeName(command), -1)); + } return TCL_OK; } diff --git a/generic/tclInt.h b/generic/tclInt.h index 19f9d0e..4a1b459 100644 --- a/generic/tclInt.h +++ b/generic/tclInt.h @@ -4123,6 +4123,7 @@ MODULE_SCOPE int TclFullFinalizationRequested(void); MODULE_SCOPE Tcl_ObjCmdProc TclEnsembleImplementationCmd; MODULE_SCOPE Tcl_ObjCmdProc TclAliasObjCmd; +MODULE_SCOPE Tcl_ObjCmdProc TclLocalAliasObjCmd; MODULE_SCOPE Tcl_ObjCmdProc TclSlaveObjCmd; MODULE_SCOPE Tcl_ObjCmdProc TclInvokeImportedCmd; MODULE_SCOPE Tcl_ObjCmdProc TclOOPublicObjectCmd; diff --git a/generic/tclInterp.c b/generic/tclInterp.c index 08cbef8..550e2fe 100644 --- a/generic/tclInterp.c +++ b/generic/tclInterp.c @@ -1414,7 +1414,8 @@ TclPreventAliasLoop( * create or rename the command. */ - if (cmdPtr->objProc != TclAliasObjCmd) { + if (cmdPtr->objProc != TclAliasObjCmd + && cmdPtr->objProc != TclLocalAliasObjCmd) { return TCL_OK; } @@ -1469,7 +1470,8 @@ TclPreventAliasLoop( * Otherwise we do not have a loop. */ - if (aliasCmdPtr->objProc != TclAliasObjCmd) { + if (aliasCmdPtr->objProc != TclAliasObjCmd + && aliasCmdPtr->objProc != TclLocalAliasObjCmd) { return TCL_OK; } nextAliasPtr = aliasCmdPtr->objClientData; @@ -1535,8 +1537,8 @@ AliasCreate( if (slaveInterp == masterInterp) { aliasPtr->slaveCmd = Tcl_NRCreateCommand(slaveInterp, - TclGetString(namePtr), TclAliasObjCmd, AliasNRCmd, aliasPtr, - AliasObjCmdDeleteProc); + TclGetString(namePtr), TclLocalAliasObjCmd, AliasNRCmd, + aliasPtr, AliasObjCmdDeleteProc); } else { aliasPtr->slaveCmd = Tcl_CreateObjCommand(slaveInterp, TclGetString(namePtr), TclAliasObjCmd, aliasPtr, @@ -1776,7 +1778,7 @@ AliasList( /* *---------------------------------------------------------------------- * - * TclAliasObjCmd -- + * TclAliasObjCmd, TclLocalAliasObjCmd -- * * This is the function that services invocations of aliases in a slave * interpreter. One such command exists for each alias. When invoked, @@ -1784,6 +1786,11 @@ AliasList( * master interpreter as designated by the Alias record associated with * this command. * + * TclLocalAliasObjCmd is a stripped down version used when the source + * and target interpreters of the alias are the same. That lets a number + * of safety precautions be avoided: the state is much more precisely + * known. + * * Results: * A standard Tcl result. * @@ -1933,6 +1940,73 @@ TclAliasObjCmd( return result; #undef ALIAS_CMDV_PREALLOC } + +int +TclLocalAliasObjCmd( + ClientData clientData, /* Alias record. */ + Tcl_Interp *interp, /* Current interpreter. */ + int objc, /* Number of arguments. */ + Tcl_Obj *const objv[]) /* Argument vector. */ +{ +#define ALIAS_CMDV_PREALLOC 10 + Alias *aliasPtr = clientData; + int result, prefc, cmdc, i; + Tcl_Obj **prefv, **cmdv; + Tcl_Obj *cmdArr[ALIAS_CMDV_PREALLOC]; + Interp *iPtr = (Interp *) interp; + int isRootEnsemble; + + /* + * Append the arguments to the command prefix and invoke the command in + * the global namespace. + */ + + prefc = aliasPtr->objc; + prefv = &aliasPtr->objPtr; + cmdc = prefc + objc - 1; + if (cmdc <= ALIAS_CMDV_PREALLOC) { + cmdv = cmdArr; + } else { + cmdv = TclStackAlloc(interp, cmdc * sizeof(Tcl_Obj *)); + } + + memcpy(cmdv, prefv, (size_t) (prefc * sizeof(Tcl_Obj *))); + memcpy(cmdv+prefc, objv+1, (size_t) ((objc-1) * sizeof(Tcl_Obj *))); + + for (i=0; i