Index: generic/tclArithSeries.c ================================================================== --- generic/tclArithSeries.c +++ generic/tclArithSeries.c @@ -512,15 +512,15 @@ void *clientData; int tcl_number_type; if (Tcl_GetNumberFromObj(interp, numberObj, &clientData, &tcl_number_type) != TCL_OK) { - return TCL_ERROR; + return TCL_ERROR; } if (tcl_number_type == TCL_NUMBER_BIG) { - /* bignum is not supported yet. */ - Tcl_WideInt w; + /* bignum is not supported yet. */ + Tcl_WideInt w; (void)Tcl_GetWideIntFromObj(interp, numberObj, &w); return TCL_ERROR; } if (useDoubles) { if (tcl_number_type != TCL_NUMBER_INT) { Index: generic/tclAssembly.c ================================================================== --- generic/tclAssembly.c +++ generic/tclAssembly.c @@ -790,12 +790,10 @@ Tcl_Interp *interp, /* Current interpreter. */ int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ { ByteCode *codePtr; /* Pointer to the bytecode to execute */ - Tcl_Obj* backtrace; /* Object where extra error information is - * constructed. */ if (objc != 2) { Tcl_WrongNumArgs(interp, 1, objv, "bytecodeList"); return TCL_ERROR; } @@ -809,16 +807,13 @@ /* * On failure, report error line. */ if (codePtr == NULL) { - Tcl_AddErrorInfo(interp, "\n (\""); - Tcl_AppendObjToErrorInfo(interp, objv[0]); - Tcl_AddErrorInfo(interp, "\" body, line "); - TclNewIntObj(backtrace, Tcl_GetErrorLine(interp)); - Tcl_AppendObjToErrorInfo(interp, backtrace); - Tcl_AddErrorInfo(interp, ")"); + Tcl_AppendObjToErrorInfo(interp, Tcl_ObjPrintf( + "\n (\"%s\" body, line %d)", + TclGetString(objv[0]), Tcl_GetErrorLine(interp))); return TCL_ERROR; } /* * Use NRE to evaluate the bytecode from the trampoline. Index: generic/tclEncoding.c ================================================================== --- generic/tclEncoding.c +++ generic/tclEncoding.c @@ -2451,11 +2451,11 @@ int ch; int profile; if (flags & TCL_ENCODING_START) { /* *statePtr will hold high surrogate in a split surrogate pair */ - *statePtr = 0; + *statePtr = 0; } result = TCL_OK; srcStart = src; srcEnd = src + srcLen; Index: generic/tclEnsemble.c ================================================================== --- generic/tclEnsemble.c +++ generic/tclEnsemble.c @@ -589,11 +589,11 @@ Tcl_Obj *const objv[]) /* Option-related arguments. */ { Tcl_Size len; int allocatedMapFlag = 0; Tcl_Obj *subcmdObj = NULL, *mapObj = NULL, *paramObj = NULL, - *unknownObj = NULL; /* Defaults, silence gcc 4 warnings */ + *unknownObj = NULL; /* Defaults, silence gcc 4 warnings */ Tcl_Obj *listObj; Tcl_DictSearch search; int permitPrefix, flags = 0; /* silence gcc 4 warning */ enum EnsConfigOpts index; int done; Index: generic/tclIOUtil.c ================================================================== --- generic/tclIOUtil.c +++ generic/tclIOUtil.c @@ -1522,14 +1522,13 @@ */ if (Tcl_SplitList(interp, modeString, &modeArgc, &modeArgv) != TCL_OK) { invAccessMode: if (interp != NULL) { - Tcl_AddErrorInfo(interp, - "\n while processing open access modes \""); - Tcl_AddErrorInfo(interp, modeString); - Tcl_AddErrorInfo(interp, "\""); + Tcl_AppendObjToErrorInfo(interp, Tcl_ObjPrintf( + "\n while processing open access modes \"%s\"", + modeString)); Tcl_SetErrorCode(interp, "TCL", "OPENMODE", "INVALID", (char *)NULL); } if (modeArgv) { Tcl_Free((void *)modeArgv); } @@ -1543,12 +1542,12 @@ if ((c == 'R') && (strcmp(flag, "RDONLY") == 0)) { if (gotRW) { invRW: if (interp != NULL) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "invalid access mode \"%s\": modes RDONLY, " - "RDWR, and WRONLY cannot be combined", flag)); + "invalid access mode \"%s\": modes RDONLY, " + "RDWR, and WRONLY cannot be combined", flag)); } goto invAccessMode; } mode = (mode & ~O_ACCMODE) | O_RDONLY; gotRW = 1; Index: generic/tclIcu.c ================================================================== --- generic/tclIcu.c +++ generic/tclIcu.c @@ -1,9 +1,9 @@ /* * tclIcu.c -- * - * tclIcu.c implements various Tcl commands that make use of + * tclIcu.c implements various Tcl commands that make use of * the ICU library if present on the system. * (Adapted from tkIcu.c) * * Copyright © 2021 Jan Nijtmans * Copyright © 2024 Ashok P. Nadkarni Index: generic/tclOO.c ================================================================== --- generic/tclOO.c +++ generic/tclOO.c @@ -18,38 +18,44 @@ /* * Commands in oo::define and oo::objdefine. */ -static const struct { - const char *name; - Tcl_ObjCmdProc *objProc; - int flag; +enum { + ON_CLASS = 0, // Implementation works on class + ON_INSTANCE = 1, // Implementation works on instance + IGNORED = 0 // Value ignored by implementation +}; + +static const struct DefinitionCommandDescriptor { + const char *name; // Definition name (NULL in last record) + Tcl_ObjCmdProc *objProc; // Definition implementation + int flag; // "Is instance" flag; passed as clientData } defineCmds[] = { - {"constructor", TclOODefineConstructorObjCmd, 0}, - {"definitionnamespace", TclOODefineDefnNsObjCmd, 0}, - {"deletemethod", TclOODefineDeleteMethodObjCmd, 0}, - {"destructor", TclOODefineDestructorObjCmd, 0}, - {"export", TclOODefineExportObjCmd, 0}, - {"forward", TclOODefineForwardObjCmd, 0}, - {"method", TclOODefineMethodObjCmd, 0}, - {"private", TclOODefinePrivateObjCmd, 0}, - {"renamemethod", TclOODefineRenameMethodObjCmd, 0}, - {"self", TclOODefineSelfObjCmd, 0}, - {"unexport", TclOODefineUnexportObjCmd, 0}, - {NULL, NULL, 0} + {"constructor", TclOODefineConstructorObjCmd, IGNORED}, + {"definitionnamespace", TclOODefineDefnNsObjCmd, IGNORED}, + {"deletemethod", TclOODefineDeleteMethodObjCmd, ON_CLASS}, + {"destructor", TclOODefineDestructorObjCmd, IGNORED}, + {"export", TclOODefineExportObjCmd, ON_CLASS}, + {"forward", TclOODefineForwardObjCmd, ON_CLASS}, + {"method", TclOODefineMethodObjCmd, ON_CLASS}, + {"private", TclOODefinePrivateObjCmd, ON_CLASS}, + {"renamemethod", TclOODefineRenameMethodObjCmd, ON_CLASS}, + {"self", TclOODefineSelfObjCmd, IGNORED}, + {"unexport", TclOODefineUnexportObjCmd, ON_CLASS}, + {NULL, NULL, IGNORED} }, objdefCmds[] = { - {"class", TclOODefineClassObjCmd, 1}, - {"deletemethod", TclOODefineDeleteMethodObjCmd, 1}, - {"export", TclOODefineExportObjCmd, 1}, - {"forward", TclOODefineForwardObjCmd, 1}, - {"method", TclOODefineMethodObjCmd, 1}, - {"private", TclOODefinePrivateObjCmd, 1}, - {"renamemethod", TclOODefineRenameMethodObjCmd, 1}, - {"self", TclOODefineObjSelfObjCmd, 0}, - {"unexport", TclOODefineUnexportObjCmd, 1}, - {NULL, NULL, 0} + {"class", TclOODefineClassObjCmd, IGNORED}, + {"deletemethod", TclOODefineDeleteMethodObjCmd, ON_INSTANCE}, + {"export", TclOODefineExportObjCmd, ON_INSTANCE}, + {"forward", TclOODefineForwardObjCmd, ON_INSTANCE}, + {"method", TclOODefineMethodObjCmd, ON_INSTANCE}, + {"private", TclOODefinePrivateObjCmd, ON_INSTANCE}, + {"renamemethod", TclOODefineRenameMethodObjCmd, ON_INSTANCE}, + {"self", TclOODefineObjSelfObjCmd, IGNORED}, + {"unexport", TclOODefineUnexportObjCmd, ON_INSTANCE}, + {NULL, NULL, IGNORED} }; /* * What sort of size of things we like to allocate. */ @@ -158,17 +164,10 @@ * The actual definition of the variable holding the TclOO stub table. */ MODULE_SCOPE const TclOOStubs tclOOStubs; -/* - * Convenience macro for getting the foundation from an interpreter. - */ - -#define GetFoundation(interp) \ - ((Foundation *)((Interp *)(interp))->objectFoundation) - /* * Macros to make inspecting into the guts of an object cleaner. * * The ocPtr parameter (only in these macros) is assumed to work fine with * either an oPtr or a classPtr. Note that the roots oo::object and oo::class @@ -306,11 +305,11 @@ Tcl_ObjCmdProc *nreProc, CompileProc *compileProc) { Command *cmdPtr; - if (cmdProc == NULL && nreProc == NULL) { + if (!cmdProc && !nreProc) { Tcl_Panic("must supply at least one implementation function"); } cmdPtr = (Command *) TclCreateObjCommandInNs(interp, name, namespacePtr, cmdProc, NULL, NULL); cmdPtr->nreProc = nreProc; @@ -455,11 +454,12 @@ * Make the configurable class and install its standard defined method. */ Tcl_Object cfgCls = Tcl_NewObjectInstance(interp, (Tcl_Class) fPtr->classCls, - "::oo::configuresupport::configurable", NULL, -1, NULL, 0); + "::oo::configuresupport::configurable", NULL, TCL_INDEX_NONE, NULL, + TCL_INDEX_NONE); for (i = 0 ; cfgMethods[i].name ; i++) { TclOONewBasicMethod(((Object *) cfgCls)->classPtr, &cfgMethods[i]); } /* @@ -666,29 +666,30 @@ Foundation *fPtr = GetFoundation(interp); Object *oPtr; Command *cmdPtr; CommandTrace *tracePtr; size_t creationEpoch; + int errorInNsManufacture; oPtr = (Object *) Tcl_Alloc(sizeof(Object)); memset(oPtr, 0, sizeof(Object)); /* - * Every object has a namespace; make one. Note that this also normally - * computes the creation epoch value for the object, a sequence number - * that is unique to the object (and which allows us to manage method - * caching without comparing pointers). + * Every object has a namespace; make one. Note that this also computes the + * creation epoch value for the object, a sequence number that is unique to + * the object (and which allows us to manage method caching without + * comparing pointers). * * When creating a namespace, we first check to see if the caller * specified the name for the namespace. If not, we generate namespace * names using the epoch until such time as a new namespace is actually * created. */ - if (nsNameStr != NULL) { + if (nsNameStr) { oPtr->namespacePtr = Tcl_CreateNamespace(interp, nsNameStr, oPtr, NULL); - if (oPtr->namespacePtr == NULL) { + if (!oPtr->namespacePtr) { /* * Couldn't make the specific namespace. Report as an error. * [Bug 154f0982f2] */ Tcl_Free(oPtr); @@ -696,39 +697,39 @@ } creationEpoch = ++fPtr->tsdPtr->nsCount; goto configNamespace; } - while (1) { + errorInNsManufacture = 0; + do { char objName[10 + TCL_INTEGER_SPACE]; snprintf(objName, sizeof(objName), "::oo::Obj%" TCL_Z_MODIFIER "u", ++fPtr->tsdPtr->nsCount); oPtr->namespacePtr = Tcl_CreateNamespace(interp, objName, oPtr, NULL); - if (oPtr->namespacePtr != NULL) { - creationEpoch = fPtr->tsdPtr->nsCount; - break; - } - + errorInNsManufacture |= !oPtr->namespacePtr; + } while (!oPtr->namespacePtr); + if (errorInNsManufacture) { /* - * Could not make that namespace, so we make another. But first we - * have to get rid of the error message from Tcl_CreateNamespace, - * since that's something that should not be exposed to the user. + * We have to get rid of error messages from failed calls to + * Tcl_CreateNamespace, since that's something that should not be + * exposed to the user. */ Tcl_ResetResult(interp); } + creationEpoch = fPtr->tsdPtr->nsCount; configNamespace: ((Namespace *) oPtr->namespacePtr)->refCount++; /* * Make the namespace know about the helper commands. This grants access * to the [self] and [next] commands. */ - if (fPtr->helpersNs != NULL) { + if (fPtr->helpersNs) { TclSetNsPath((Namespace *) oPtr->namespacePtr, 1, &fPtr->helpersNs); } TclOOSetupVariableResolver(oPtr->namespacePtr); /* @@ -770,16 +771,16 @@ */ if (!nameStr) { nameStr = oPtr->namespacePtr->name; nsPtr = (Namespace *) oPtr->namespacePtr; - if (nsPtr->parentPtr != NULL) { + if (nsPtr->parentPtr) { nsPtr = nsPtr->parentPtr; } } oPtr->command = TclCreateObjCommandInNs(interp, nameStr, - (Tcl_Namespace *) nsPtr, TclOOPublicObjectCmd, oPtr, NULL); + (Tcl_Namespace *) nsPtr, TclOOPublicObjectCmd, oPtr, NULL); /* * Add the NRE command and trace directly. While this breaks a number of * abstractions, it is faster and we're inside Tcl here so we're allowed. */ @@ -788,11 +789,11 @@ cmdPtr->nreProc = PublicNRObjectCmd; cmdPtr->tracePtr = tracePtr = (CommandTrace *) Tcl_Alloc(sizeof(CommandTrace)); tracePtr->traceProc = ObjectRenamedTrace; tracePtr->clientData = oPtr; - tracePtr->flags = TCL_TRACE_RENAME|TCL_TRACE_DELETE; + tracePtr->flags = TCL_TRACE_RENAME | TCL_TRACE_DELETE; tracePtr->nextPtr = NULL; tracePtr->refCount = 1; oPtr->myCommand = TclNRCreateCommandInNs(interp, "my", oPtr->namespacePtr, TclOOPrivateObjectCmd, PrivateNRObjectCmd, oPtr, MyDeleted); @@ -1089,11 +1090,11 @@ /* * Squelch our metadata. */ - if (clsPtr->metadataPtr != NULL) { + if (clsPtr->metadataPtr) { Tcl_ObjectMetadataType *metadataTypePtr; void *value; FOREACH_HASH(metadataTypePtr, value, clsPtr->metadataPtr) { metadataTypePtr->deleteProc(value); @@ -1173,11 +1174,11 @@ FOREACH_HASH_DECLS; Class *mixinPtr; Method *mPtr; Tcl_Obj *filterObj, *variableObj; PrivateVariableMapping *privateVariable; - Tcl_Interp *interp = oPtr->fPtr->interp; + Tcl_Interp *interp = fPtr->interp; Tcl_Size i; if (Destructing(oPtr)) { /* * TODO: Can ObjectNamespaceDeleted ever be called twice? If not, @@ -1216,11 +1217,11 @@ int result; Tcl_InterpState state; oPtr->flags |= DESTRUCTOR_CALLED; - if (contextPtr != NULL) { + if (contextPtr) { contextPtr->callPtr->flags |= DESTRUCTOR; contextPtr->skip = 0; state = Tcl_SaveInterpState(interp, TCL_OK); result = Tcl_NRCallObjProc(interp, TclOOInvokeContext, contextPtr, 0, NULL); @@ -1271,11 +1272,11 @@ if (oPtr->mixins.num > 0) { FOREACH(mixinPtr, oPtr->mixins) { TclOORemoveFromInstances(oPtr, mixinPtr); TclOODecrRefCount(mixinPtr->thisPtr); } - if (oPtr->mixins.list != NULL) { + if (oPtr->mixins.list) { Tcl_Free(oPtr->mixins.list); } } FOREACH(filterObj, oPtr->filters) { @@ -1312,11 +1313,11 @@ TclOODeleteChainCache(oPtr->chainCache); } SquelchCachedName(oPtr); - if (oPtr->metadataPtr != NULL) { + if (oPtr->metadataPtr) { Tcl_ObjectMetadataType *metadataTypePtr; void *value; FOREACH_HASH(metadataTypePtr, value, oPtr->metadataPtr) { metadataTypePtr->deleteProc(value); @@ -1347,11 +1348,11 @@ if (IsRootObject(oPtr) && !Destructing(fPtr->classCls->thisPtr) && !Tcl_InterpDeleted(interp)) { Tcl_DeleteCommandFromToken(interp, fPtr->classCls->thisPtr->command); } - if (oPtr->classPtr != NULL) { + if (oPtr->classPtr) { TclOOReleaseClassContents(interp, oPtr); } /* * Delete the object structure itself. @@ -1379,19 +1380,19 @@ int TclOODecrRefCount( Object *oPtr) { - if (oPtr->refCount-- <= 1) { - - if (oPtr->classPtr != NULL) { - Tcl_Free(oPtr->classPtr); - } - Tcl_Free(oPtr); - return 1; - } - return 0; + if (oPtr->refCount-- > 1) { + return 0; + } + + if (oPtr->classPtr) { + Tcl_Free(oPtr->classPtr); + } + Tcl_Free(oPtr); + return 1; } /* * ---------------------------------------------------------------------- * @@ -1404,11 +1405,11 @@ */ int TclOOObjectDestroyed( Object *oPtr) { - return (oPtr->namespacePtr == NULL); + return !oPtr->namespacePtr; } /* * ---------------------------------------------------------------------- * @@ -1661,11 +1662,11 @@ Tcl_Interp *interp, Class *clsPtr) { Foundation *fPtr = GetFoundation(interp); - if (fPtr->helpersNs != NULL) { + if (fPtr->helpersNs) { Tcl_Namespace *path[2]; path[0] = fPtr->helpersNs; path[1] = fPtr->ooNs; TclSetNsPath((Namespace *) clsPtr->thisPtr->namespacePtr, 2, path); @@ -1746,11 +1747,11 @@ Class *classPtr = (Class *) cls; Object *oPtr; void *clientData[4]; oPtr = TclNewObjectInstanceCommon(interp, classPtr, nameStr, nsNameStr); - if (oPtr == NULL) { + if (!oPtr) { return NULL; } /* * Run constructors, except when objc < 0, which is a special flag case @@ -1759,11 +1760,11 @@ if (objc != TCL_INDEX_NONE) { CallContext *contextPtr = TclOOGetCallContext(oPtr, NULL, CONSTRUCTOR, NULL, NULL, NULL); - if (contextPtr != NULL) { + if (contextPtr) { int isRoot, result; Tcl_InterpState state; state = Tcl_SaveInterpState(interp, TCL_OK); contextPtr->callPtr->flags |= CONSTRUCTOR; @@ -1817,25 +1818,26 @@ CallContext *contextPtr; Tcl_InterpState state; Object *oPtr; oPtr = TclNewObjectInstanceCommon(interp, classPtr, nameStr, nsNameStr); - if (oPtr == NULL) { + if (!oPtr) { return TCL_ERROR; } /* - * Run constructors, except when objc == TCL_INDEX_NONE (a special flag case used for - * object cloning only). If there aren't any constructors, we do nothing. + * Run constructors, except when objc == TCL_INDEX_NONE (a special flag + * case used for object cloning only). If there aren't any constructors, + * we do nothing. */ if (objc < 0) { *objectPtr = (Tcl_Object) oPtr; return TCL_OK; } contextPtr = TclOOGetCallContext(oPtr, NULL, CONSTRUCTOR, NULL, NULL, NULL); - if (contextPtr == NULL) { + if (!contextPtr) { *objectPtr = (Tcl_Object) oPtr; return TCL_OK; } state = Tcl_SaveInterpState(interp, TCL_OK); @@ -1895,11 +1897,11 @@ /* * Create the object. */ oPtr = AllocObject(interp, simpleName, nsPtr, nsNameStr); - if (oPtr == NULL) { + if (!oPtr) { return NULL; } oPtr->selfCls = classPtr; AddRef(classPtr->thisPtr); TclOOAddToInstances(oPtr, classPtr); @@ -1941,11 +1943,11 @@ * want to lose errors by accident. [Bug 2903011] */ if (result != TCL_ERROR && Destructing(oPtr)) { Tcl_SetObjResult(interp, Tcl_NewStringObj( - "object deleted in constructor", -1)); + "object deleted in constructor", TCL_AUTO_LENGTH)); Tcl_SetErrorCode(interp, "TCL", "OO", "STILLBORN", (char *)NULL); result = TCL_ERROR; } if (result != TCL_OK) { Tcl_DiscardInterpState(state); @@ -1997,10 +1999,11 @@ Tcl_Object sourceObject, const char *targetName, const char *targetNamespaceName) { Object *oPtr = (Object *) sourceObject, *o2Ptr; + Foundation *fPtr = GetFoundation(interp); FOREACH_HASH_DECLS; Method *mPtr; Class *mixinPtr; CallContext *contextPtr; Tcl_Obj *keyPtr, *filterObj, *variableObj, *args[3]; @@ -2012,23 +2015,23 @@ * Sanity check. */ if (IsRootClass(oPtr)) { Tcl_SetObjResult(interp, Tcl_NewStringObj( - "may not clone the class of classes", -1)); + "may not clone the class of classes", TCL_AUTO_LENGTH)); Tcl_SetErrorCode(interp, "TCL", "OO", "CLONING_CLASS", (char *)NULL); return NULL; } /* * Build the instance. Note that this does not run any constructors. */ o2Ptr = (Object *) Tcl_NewObjectInstance(interp, - (Tcl_Class) oPtr->selfCls, targetName, targetNamespaceName, TCL_INDEX_NONE, - NULL, -1); - if (o2Ptr == NULL) { + (Tcl_Class) oPtr->selfCls, targetName, targetNamespaceName, + TCL_INDEX_NONE, NULL, TCL_INDEX_NONE); + if (!o2Ptr) { return NULL; } /* * Copy the object-local methods to the new object. @@ -2106,25 +2109,25 @@ /* * Copy the object's metadata. */ - if (oPtr->metadataPtr != NULL) { + if (oPtr->metadataPtr) { Tcl_ObjectMetadataType *metadataTypePtr; void *value, *duplicate; FOREACH_HASH(metadataTypePtr, value, oPtr->metadataPtr) { - if (metadataTypePtr->cloneProc == NULL) { + if (!metadataTypePtr->cloneProc) { duplicate = value; } else { if (metadataTypePtr->cloneProc(interp, value, &duplicate) != TCL_OK) { Tcl_DeleteCommandFromToken(interp, o2Ptr->command); return NULL; } } - if (duplicate != NULL) { + if (duplicate) { Tcl_ObjectSetMetadata((Tcl_Object) o2Ptr, metadataTypePtr, duplicate); } } } @@ -2132,11 +2135,11 @@ /* * Copy the class, if present. Note that if there is a class present in * the source object, there must also be one in the copy. */ - if (oPtr->classPtr != NULL) { + if (oPtr->classPtr) { Class *clsPtr = oPtr->classPtr; Class *cls2Ptr = o2Ptr->classPtr; Class *superPtr; /* @@ -2252,38 +2255,38 @@ /* * Duplicate the class's metadata. */ - if (clsPtr->metadataPtr != NULL) { + if (clsPtr->metadataPtr) { Tcl_ObjectMetadataType *metadataTypePtr; void *value, *duplicate; FOREACH_HASH(metadataTypePtr, value, clsPtr->metadataPtr) { - if (metadataTypePtr->cloneProc == NULL) { + if (!metadataTypePtr->cloneProc) { duplicate = value; } else { if (metadataTypePtr->cloneProc(interp, value, &duplicate) != TCL_OK) { Tcl_DeleteCommandFromToken(interp, o2Ptr->command); return NULL; } } - if (duplicate != NULL) { + if (duplicate) { Tcl_ClassSetMetadata((Tcl_Class) cls2Ptr, metadataTypePtr, duplicate); } } } } TclResetRewriteEnsemble(interp, 1); - contextPtr = TclOOGetCallContext(o2Ptr, oPtr->fPtr->clonedName, 0, NULL, + contextPtr = TclOOGetCallContext(o2Ptr, fPtr->clonedName, 0, NULL, NULL, NULL); if (contextPtr) { args[0] = TclOOObjectName(interp, o2Ptr); - args[1] = oPtr->fPtr->clonedName; + args[1] = fPtr->clonedName; args[2] = TclOOObjectName(interp, oPtr); Tcl_IncrRefCount(args[0]); Tcl_IncrRefCount(args[1]); Tcl_IncrRefCount(args[2]); result = Tcl_NRCallObjProc(interp, TclOOInvokeContext, contextPtr, 3, @@ -2322,11 +2325,11 @@ Tcl_Interp *interp, Object *oPtr, Method *mPtr, Tcl_Obj *namePtr) { - if (mPtr->typePtr == NULL) { + if (!mPtr->typePtr) { TclNewInstanceMethod(interp, (Tcl_Object) oPtr, namePtr, mPtr->flags & PUBLIC_METHOD, NULL, NULL); } else if (mPtr->typePtr->cloneProc) { void *newClientData; @@ -2351,11 +2354,11 @@ Tcl_Obj *namePtr, Method **m2PtrPtr) { Method *m2Ptr; - if (mPtr->typePtr == NULL) { + if (!mPtr->typePtr) { m2Ptr = (Method *) TclNewMethod((Tcl_Class) clsPtr, namePtr, mPtr->flags & PUBLIC_METHOD, NULL, NULL); } else if (mPtr->typePtr->cloneProc) { void *newClientData; @@ -2369,11 +2372,11 @@ } else { m2Ptr = (Method *) TclNewMethod((Tcl_Class) clsPtr, namePtr, mPtr->flags & PUBLIC_METHOD, mPtr->typePtr, mPtr->clientData); } - if (m2PtrPtr != NULL) { + if (m2PtrPtr) { *m2PtrPtr = m2Ptr; } return TCL_OK; } @@ -2414,11 +2417,11 @@ /* * If there's no metadata store attached, the type in question has * definitely not been attached either! */ - if (clsPtr->metadataPtr == NULL) { + if (!clsPtr->metadataPtr) { return NULL; } /* * There is a metadata store, so look in it for the given type. @@ -2428,11 +2431,11 @@ /* * Return the metadata value if we found it, otherwise NULL. */ - if (hPtr == NULL) { + if (!hPtr) { return NULL; } return Tcl_GetHashValue(hPtr); } @@ -2448,12 +2451,12 @@ /* * Attach the metadata store if not done already. */ - if (clsPtr->metadataPtr == NULL) { - if (metadata == NULL) { + if (!clsPtr->metadataPtr) { + if (!metadata) { return; } clsPtr->metadataPtr = (Tcl_HashTable *) Tcl_Alloc(sizeof(Tcl_HashTable)); Tcl_InitHashTable(clsPtr->metadataPtr, TCL_ONE_WORD_KEYS); @@ -2461,13 +2464,13 @@ /* * If the metadata is NULL, we're deleting the metadata for the type. */ - if (metadata == NULL) { + if (!metadata) { hPtr = Tcl_FindHashEntry(clsPtr->metadataPtr, typePtr); - if (hPtr != NULL) { + if (hPtr) { typePtr->deleteProc(Tcl_GetHashValue(hPtr)); Tcl_DeleteHashEntry(hPtr); } return; } @@ -2495,11 +2498,11 @@ /* * If there's no metadata store attached, the type in question has * definitely not been attached either! */ - if (oPtr->metadataPtr == NULL) { + if (!oPtr->metadataPtr) { return NULL; } /* * There is a metadata store, so look in it for the given type. @@ -2509,11 +2512,11 @@ /* * Return the metadata value if we found it, otherwise NULL. */ - if (hPtr == NULL) { + if (!hPtr) { return NULL; } return Tcl_GetHashValue(hPtr); } @@ -2529,12 +2532,12 @@ /* * Attach the metadata store if not done already. */ - if (oPtr->metadataPtr == NULL) { - if (metadata == NULL) { + if (!oPtr->metadataPtr) { + if (!metadata) { return; } oPtr->metadataPtr = (Tcl_HashTable *) Tcl_Alloc(sizeof(Tcl_HashTable)); Tcl_InitHashTable(oPtr->metadataPtr, TCL_ONE_WORD_KEYS); } @@ -2541,13 +2544,13 @@ /* * If the metadata is NULL, we're deleting the metadata for the type. */ - if (metadata == NULL) { + if (!metadata) { hPtr = Tcl_FindHashEntry(oPtr->metadataPtr, typePtr); - if (hPtr != NULL) { + if (hPtr) { typePtr->deleteProc(Tcl_GetHashValue(hPtr)); Tcl_DeleteHashEntry(hPtr); } return; } @@ -2750,11 +2753,11 @@ /* * Give plugged in code a chance to remap the method name. */ methodNamePtr = objv[1]; - if (oPtr->mapMethodNameProc != NULL) { + if (oPtr->mapMethodNameProc) { Class **startClsPtr = &startCls; Tcl_Obj *mappedMethodName = Tcl_DuplicateObj(methodNamePtr); result = oPtr->mapMethodNameProc(interp, (Tcl_Object) oPtr, (Tcl_Class *) startClsPtr, mappedMethodName); @@ -2775,11 +2778,11 @@ Tcl_IncrRefCount(mappedMethodName); contextPtr = TclOOGetCallContext(oPtr, mappedMethodName, flags | (oPtr->flags & FILTER_HANDLING), callerObjPtr, callerClsPtr, methodNamePtr); TclDecrRefCount(mappedMethodName); - if (contextPtr == NULL) { + if (!contextPtr) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( "impossible to invoke method \"%s\": no defined method or" " unknown method", TclGetString(methodNamePtr))); Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "METHOD_MAPPED", TclGetString(methodNamePtr), (char *)NULL); @@ -2792,11 +2795,11 @@ noMapping: contextPtr = TclOOGetCallContext(oPtr, methodNamePtr, flags | (oPtr->flags & FILTER_HANDLING), callerObjPtr, callerClsPtr, NULL); - if (contextPtr == NULL) { + if (!contextPtr) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( "impossible to invoke method \"%s\": no defined method or" " unknown method", TclGetString(methodNamePtr))); Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "METHOD", TclGetString(methodNamePtr), (char *)NULL); @@ -2807,11 +2810,11 @@ /* * Check to see if we need to apply magical tricks to start part way * through the call chain. */ - if (startCls != NULL) { + if (startCls) { for (; contextPtr->index < contextPtr->callPtr->numChain; contextPtr->index++) { MInvoke *miPtr = &contextPtr->callPtr->chain[contextPtr->index]; if (miPtr->isFilter) { @@ -2821,11 +2824,11 @@ break; } } if (contextPtr->index >= contextPtr->callPtr->numChain) { Tcl_SetObjResult(interp, Tcl_NewStringObj( - "no valid method implementation", -1)); + "no valid method implementation", TCL_AUTO_LENGTH)); Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "METHOD", TclGetString(methodNamePtr), (char *)NULL); TclOODeleteContext(contextPtr); return TCL_ERROR; } @@ -3037,16 +3040,16 @@ Tcl_Obj *objPtr) /* The name of the object to look up, which is * exactly the name of its public command. */ { Command *cmdPtr = (Command *) Tcl_GetCommandFromObj(interp, objPtr); - if (cmdPtr == NULL) { + if (!cmdPtr) { goto notAnObject; } if (cmdPtr->objProc != TclOOPublicObjectCmd) { cmdPtr = (Command *) TclGetOriginalCommand((Tcl_Command) cmdPtr); - if (cmdPtr == NULL || cmdPtr->objProc != TclOOPublicObjectCmd) { + if (!cmdPtr || cmdPtr->objProc != TclOOPublicObjectCmd) { goto notAnObject; } } return (Tcl_Object) cmdPtr->objClientData; @@ -3236,11 +3239,11 @@ Tcl_Interp *interp, Tcl_Object object) { Tcl_Object classObj = (Tcl_Object) (((Object *) object)->selfCls)->thisPtr; - if (classObj == NULL) { + if (!classObj) { return NULL; } return Tcl_GetObjectName(interp, classObj); } Index: generic/tclOOBasic.c ================================================================== --- generic/tclOOBasic.c +++ generic/tclOOBasic.c @@ -82,10 +82,11 @@ Tcl_ObjectContext context, int objc, Tcl_Obj *const *objv) { Object *oPtr = (Object *) Tcl_ObjectContextObject(context); + Foundation *fPtr = GetFoundation(interp); Tcl_Obj **invoke, *nameObj; size_t skip = Tcl_ObjectContextSkippedArgs(context); if ((size_t) objc > skip + 1) { Tcl_WrongNumArgs(interp, skip, objv, @@ -100,22 +101,22 @@ * here (and the class definition delegate doesn't run any constructors). */ nameObj = Tcl_ObjPrintf("%s:: oo ::delegate", oPtr->namespacePtr->fullName); - Tcl_NewObjectInstance(interp, (Tcl_Class) oPtr->fPtr->classCls, - TclGetString(nameObj), NULL, -1, NULL, -1); + Tcl_NewObjectInstance(interp, (Tcl_Class) fPtr->classCls, + TclGetString(nameObj), NULL, TCL_INDEX_NONE, NULL, TCL_INDEX_NONE); Tcl_BounceRefCount(nameObj); /* * Delegate to [oo::define] to do the work. */ invoke = (Tcl_Obj **) TclStackAlloc(interp, 3 * sizeof(Tcl_Obj *)); - invoke[0] = oPtr->fPtr->defineName; + invoke[0] = fPtr->defineName; invoke[1] = TclOOObjectName(interp, oPtr); - invoke[2] = objv[objc-1]; + invoke[2] = objv[objc - 1]; /* * Must add references or errors in configuration script will cause * trouble. */ @@ -146,11 +147,11 @@ int code; TclDecrRefCount(invoke[0]); TclDecrRefCount(invoke[1]); TclDecrRefCount(invoke[2]); - invoke[0] = Tcl_NewStringObj("::oo::MixinClassDelegates", -1); + invoke[0] = Tcl_NewStringObj("::oo::MixinClassDelegates", TCL_AUTO_LENGTH); invoke[1] = TclOOObjectName(interp, oPtr); Tcl_IncrRefCount(invoke[0]); Tcl_IncrRefCount(invoke[1]); saved = Tcl_SaveInterpState(interp, result); code = Tcl_EvalObjv(interp, 2, invoke, 0); @@ -190,11 +191,11 @@ /* * Sanity check; should not be possible to invoke this method on a * non-class. */ - if (oPtr->classPtr == NULL) { + if (!oPtr->classPtr) { Tcl_Obj *cmdnameObj = TclOOObjectName(interp, oPtr); Tcl_SetObjResult(interp, Tcl_ObjPrintf( "object \"%s\" is not a class", TclGetString(cmdnameObj))); Tcl_SetErrorCode(interp, "TCL", "OO", "INSTANTIATE_NONCLASS", (char *)NULL); @@ -212,11 +213,11 @@ } objName = Tcl_GetStringFromObj( objv[Tcl_ObjectContextSkippedArgs(context)], &len); if (len == 0) { Tcl_SetObjResult(interp, Tcl_NewStringObj( - "object name must not be empty", -1)); + "object name must not be empty", TCL_AUTO_LENGTH)); Tcl_SetErrorCode(interp, "TCL", "OO", "EMPTY_NAME", (char *)NULL); return TCL_ERROR; } /* @@ -255,11 +256,11 @@ /* * Sanity check; should not be possible to invoke this method on a * non-class. */ - if (oPtr->classPtr == NULL) { + if (!oPtr->classPtr) { Tcl_Obj *cmdnameObj = TclOOObjectName(interp, oPtr); Tcl_SetObjResult(interp, Tcl_ObjPrintf( "object \"%s\" is not a class", TclGetString(cmdnameObj))); Tcl_SetErrorCode(interp, "TCL", "OO", "INSTANTIATE_NONCLASS", (char *)NULL); @@ -277,19 +278,19 @@ } objName = Tcl_GetStringFromObj( objv[Tcl_ObjectContextSkippedArgs(context)], &len); if (len == 0) { Tcl_SetObjResult(interp, Tcl_NewStringObj( - "object name must not be empty", -1)); + "object name must not be empty", TCL_AUTO_LENGTH)); Tcl_SetErrorCode(interp, "TCL", "OO", "EMPTY_NAME", (char *)NULL); return TCL_ERROR; } nsName = Tcl_GetStringFromObj( objv[Tcl_ObjectContextSkippedArgs(context)+1], &len); if (len == 0) { Tcl_SetObjResult(interp, Tcl_NewStringObj( - "namespace name must not be empty", -1)); + "namespace name must not be empty", TCL_AUTO_LENGTH)); Tcl_SetErrorCode(interp, "TCL", "OO", "EMPTY_NAME", (char *)NULL); return TCL_ERROR; } /* @@ -326,11 +327,11 @@ /* * Sanity check; should not be possible to invoke this method on a * non-class. */ - if (oPtr->classPtr == NULL) { + if (!oPtr->classPtr) { Tcl_Obj *cmdnameObj = TclOOObjectName(interp, oPtr); Tcl_SetObjResult(interp, Tcl_ObjPrintf( "object \"%s\" is not a class", TclGetString(cmdnameObj))); Tcl_SetErrorCode(interp, "TCL", "OO", "INSTANTIATE_NONCLASS", (char *)NULL); @@ -375,11 +376,11 @@ } if (!(oPtr->flags & DESTRUCTOR_CALLED)) { oPtr->flags |= DESTRUCTOR_CALLED; contextPtr = TclOOGetCallContext(oPtr, NULL, DESTRUCTOR, NULL, NULL, NULL); - if (contextPtr != NULL) { + if (contextPtr) { contextPtr->callPtr->flags |= DESTRUCTOR; contextPtr->skip = 0; TclNRAddCallback(interp, AfterNRDestructor, contextPtr, NULL, NULL, NULL); TclPushTailcallPoint(interp); @@ -597,20 +598,20 @@ return TCL_ERROR; } errorMsg = Tcl_ObjPrintf("unknown method \"%s\": must be ", TclGetString(objv[skip])); - for (i=0 ; ivarFramePtr == NULL) { + if (!iPtr->varFramePtr) { return TCL_OK; } for (i = Tcl_ObjectContextSkippedArgs(context) ; i < objc ; i++) { Var *varPtr, *aryPtr; @@ -663,11 +664,11 @@ /* * The variable name must not contain a '::' since that's illegal in * local names. */ - if (strstr(varName, "::") != NULL) { + if (strstr(varName, "::")) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( "variable name \"%s\" illegal: must not contain namespace" " separator", varName)); Tcl_SetErrorCode(interp, "TCL", "UPVAR", "INVERTED", (char *)NULL); return TCL_ERROR; @@ -688,11 +689,11 @@ Tcl_GetObjectNamespace(object); varPtr = TclObjLookupVar(interp, objv[i], NULL, TCL_NAMESPACE_ONLY, "define", 1, 0, &aryPtr); iPtr->varFramePtr->nsPtr = savedNsPtr; - if (varPtr == NULL || aryPtr != NULL) { + if (!varPtr || aryPtr) { /* * Variable cannot be an element in an array. If aryPtr is not * NULL, it is an element, so throw up an error and return. */ @@ -817,13 +818,13 @@ Tcl_IncrRefCount(varNamePtr); Tcl_Var var = (Tcl_Var) TclObjLookupVar(interp, varNamePtr, NULL, TCL_NAMESPACE_ONLY|TCL_LEAVE_ERR_MSG, "refer to", 1, 1, (Var **) aryPtr); Tcl_DecrRefCount(varNamePtr); - if (var == NULL) { + if (!var) { Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "VARIABLE", arg, (void *) NULL); - } else if (*aryPtr == NULL && TclIsVarArrayElement((Var *) var)) { + } else if (!*aryPtr && TclIsVarArrayElement((Var *) var)) { /* * If the varPtr points to an element of an array but we don't already * have the array, find it now. Note that this can't be easily * backported; the arrayPtr field is new in Tcl 9.0. [Bug 2da1cb0c80] */ @@ -861,11 +862,11 @@ return TCL_ERROR; } varPtr = TclOOLookupObjectVar(interp, Tcl_ObjectContextObject(context), objv[objc - 1], &aryVar); - if (varPtr == NULL) { + if (!varPtr) { return TCL_ERROR; } /* * The variable reference must not disappear too soon. [Bug 74b6110204] @@ -879,11 +880,11 @@ * (including traversing variable links), convert back to a name. */ TclNewObj(varNamePtr); - if (aryVar != NULL) { + if (aryVar) { Tcl_GetVariableFullName(interp, aryVar, varNamePtr); Tcl_AppendPrintfToObj(varNamePtr, "(%s)", Tcl_GetString( VarHashGetKey(varPtr))); } else { Tcl_GetVariableFullName(interp, varPtr, varNamePtr); @@ -919,11 +920,11 @@ * Start with sanity checks on the calling context to make sure that we * are invoked from a suitable method context. If so, we can safely * retrieve the handle to the object call context. */ - if (framePtr == NULL || !(framePtr->isProcCallFrame & FRAME_IS_METHOD)) { + if (!framePtr || !(framePtr->isProcCallFrame & FRAME_IS_METHOD)) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( "%s may only be called from inside a method", TclGetString(objv[0]))); Tcl_SetErrorCode(interp, "TCL", "OO", "CONTEXT_REQUIRED", (char *)NULL); return TCL_ERROR; @@ -959,11 +960,11 @@ * Start with sanity checks on the calling context to make sure that we * are invoked from a suitable method context. If so, we can safely * retrieve the handle to the object call context. */ - if (framePtr == NULL || !(framePtr->isProcCallFrame & FRAME_IS_METHOD)) { + if (!framePtr || !(framePtr->isProcCallFrame & FRAME_IS_METHOD)) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( "%s may only be called from inside a method", TclGetString(objv[0]))); Tcl_SetErrorCode(interp, "TCL", "OO", "CONTEXT_REQUIRED", (char *)NULL); return TCL_ERROR; @@ -977,15 +978,15 @@ if (objc < 2) { Tcl_WrongNumArgs(interp, 1, objv, "class ?arg...?"); return TCL_ERROR; } object = Tcl_GetObjectFromObj(interp, objv[1]); - if (object == NULL) { + if (!object) { return TCL_ERROR; } classPtr = ((Object *) object)->classPtr; - if (classPtr == NULL) { + if (!classPtr) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( "\"%s\" is not a class", TclGetString(objv[1]))); Tcl_SetErrorCode(interp, "TCL", "OO", "CLASS_REQUIRED", (char *)NULL); return TCL_ERROR; } @@ -1005,11 +1006,11 @@ * context. Note that this is like [uplevel 1] and not [eval]. */ TclNRAddCallback(interp, NextRestoreFrame, framePtr, contextPtr, INT2PTR(contextPtr->index), NULL); - contextPtr->index = i-1; + contextPtr->index = i - 1; iPtr->varFramePtr = framePtr->callerVarPtr; return TclNRObjectContextInvokeNext(interp, (Tcl_ObjectContext) contextPtr, objc, objv, 2); } } @@ -1054,11 +1055,11 @@ { Interp *iPtr = (Interp *) interp; CallContext *contextPtr = (CallContext *) data[1]; iPtr->varFramePtr = (CallFrame *) data[0]; - if (contextPtr != NULL) { + if (contextPtr) { contextPtr->index = PTR2UINT(data[2]); } return result; } @@ -1087,10 +1088,11 @@ enum SelfCmds { SELF_CALL, SELF_CALLER, SELF_CLASS, SELF_FILTER, SELF_METHOD, SELF_NS, SELF_NEXT, SELF_OBJECT, SELF_TARGET } index; Interp *iPtr = (Interp *) interp; + Foundation *fPtr = GetFoundation(interp); CallFrame *framePtr = iPtr->varFramePtr; CallContext *contextPtr; Tcl_Obj *result[3]; #define CurrentlyInvoked(contextPtr) \ @@ -1098,11 +1100,11 @@ /* * Start with sanity checks on the calling context and the method context. */ - if (framePtr == NULL || !(framePtr->isProcCallFrame & FRAME_IS_METHOD)) { + if (!framePtr || !(framePtr->isProcCallFrame & FRAME_IS_METHOD)) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( "%s may only be called from inside a method", TclGetString(objv[0]))); Tcl_SetErrorCode(interp, "TCL", "OO", "CONTEXT_REQUIRED", (char *)NULL); return TCL_ERROR; @@ -1134,129 +1136,129 @@ TclNewNamespaceObj(contextPtr->oPtr->namespacePtr)); return TCL_OK; case SELF_CLASS: { Class *clsPtr = CurrentlyInvoked(contextPtr).mPtr->declaringClassPtr; - if (clsPtr == NULL) { + if (!clsPtr) { Tcl_SetObjResult(interp, Tcl_NewStringObj( - "method not defined by a class", -1)); + "method not defined by a class", TCL_AUTO_LENGTH)); Tcl_SetErrorCode(interp, "TCL", "OO", "UNMATCHED_CONTEXT", (char *)NULL); return TCL_ERROR; } Tcl_SetObjResult(interp, TclOOObjectName(interp, clsPtr->thisPtr)); return TCL_OK; } case SELF_METHOD: if (contextPtr->callPtr->flags & CONSTRUCTOR) { - Tcl_SetObjResult(interp, contextPtr->oPtr->fPtr->constructorName); + Tcl_SetObjResult(interp, fPtr->constructorName); } else if (contextPtr->callPtr->flags & DESTRUCTOR) { - Tcl_SetObjResult(interp, contextPtr->oPtr->fPtr->destructorName); + Tcl_SetObjResult(interp, fPtr->destructorName); } else { Tcl_SetObjResult(interp, CurrentlyInvoked(contextPtr).mPtr->namePtr); } return TCL_OK; case SELF_FILTER: if (!CurrentlyInvoked(contextPtr).isFilter) { Tcl_SetObjResult(interp, Tcl_NewStringObj( - "not inside a filtering context", -1)); + "not inside a filtering context", TCL_AUTO_LENGTH)); Tcl_SetErrorCode(interp, "TCL", "OO", "UNMATCHED_CONTEXT", (char *)NULL); return TCL_ERROR; } else { MInvoke *miPtr = &CurrentlyInvoked(contextPtr); Object *oPtr; const char *type; - if (miPtr->filterDeclarer != NULL) { + if (miPtr->filterDeclarer) { oPtr = miPtr->filterDeclarer->thisPtr; type = "class"; } else { oPtr = contextPtr->oPtr; type = "object"; } result[0] = TclOOObjectName(interp, oPtr); - result[1] = Tcl_NewStringObj(type, -1); + result[1] = Tcl_NewStringObj(type, TCL_AUTO_LENGTH); result[2] = miPtr->mPtr->namePtr; Tcl_SetObjResult(interp, Tcl_NewListObj(3, result)); return TCL_OK; } case SELF_CALLER: - if ((framePtr->callerVarPtr == NULL) || - !(framePtr->callerVarPtr->isProcCallFrame & FRAME_IS_METHOD)){ + if (!framePtr->callerVarPtr || + !(framePtr->callerVarPtr->isProcCallFrame & FRAME_IS_METHOD)) { Tcl_SetObjResult(interp, Tcl_NewStringObj( - "caller is not an object", -1)); + "caller is not an object", TCL_AUTO_LENGTH)); Tcl_SetErrorCode(interp, "TCL", "OO", "CONTEXT_REQUIRED", (char *)NULL); return TCL_ERROR; } else { CallContext *callerPtr = (CallContext *) framePtr->callerVarPtr->clientData; Method *mPtr = callerPtr->callPtr->chain[callerPtr->index].mPtr; Object *declarerPtr; - if (mPtr->declaringClassPtr != NULL) { + if (mPtr->declaringClassPtr) { declarerPtr = mPtr->declaringClassPtr->thisPtr; - } else if (mPtr->declaringObjectPtr != NULL) { + } else if (mPtr->declaringObjectPtr) { declarerPtr = mPtr->declaringObjectPtr; } else { /* * This should be unreachable code. */ Tcl_SetObjResult(interp, Tcl_NewStringObj( - "method without declarer!", -1)); + "method without declarer!", TCL_AUTO_LENGTH)); return TCL_ERROR; } result[0] = TclOOObjectName(interp, declarerPtr); result[1] = TclOOObjectName(interp, callerPtr->oPtr); if (callerPtr->callPtr->flags & CONSTRUCTOR) { - result[2] = declarerPtr->fPtr->constructorName; + result[2] = fPtr->constructorName; } else if (callerPtr->callPtr->flags & DESTRUCTOR) { - result[2] = declarerPtr->fPtr->destructorName; + result[2] = fPtr->destructorName; } else { result[2] = mPtr->namePtr; } Tcl_SetObjResult(interp, Tcl_NewListObj(3, result)); return TCL_OK; } case SELF_NEXT: - if (contextPtr->index < contextPtr->callPtr->numChain-1) { + if (contextPtr->index < contextPtr->callPtr->numChain - 1) { Method *mPtr = contextPtr->callPtr->chain[contextPtr->index+1].mPtr; Object *declarerPtr; - if (mPtr->declaringClassPtr != NULL) { + if (mPtr->declaringClassPtr) { declarerPtr = mPtr->declaringClassPtr->thisPtr; - } else if (mPtr->declaringObjectPtr != NULL) { + } else if (mPtr->declaringObjectPtr) { declarerPtr = mPtr->declaringObjectPtr; } else { /* * This should be unreachable code. */ Tcl_SetObjResult(interp, Tcl_NewStringObj( - "method without declarer!", -1)); + "method without declarer!", TCL_AUTO_LENGTH)); return TCL_ERROR; } result[0] = TclOOObjectName(interp, declarerPtr); if (contextPtr->callPtr->flags & CONSTRUCTOR) { - result[1] = declarerPtr->fPtr->constructorName; + result[1] = fPtr->constructorName; } else if (contextPtr->callPtr->flags & DESTRUCTOR) { - result[1] = declarerPtr->fPtr->destructorName; + result[1] = fPtr->destructorName; } else { result[1] = mPtr->namePtr; } Tcl_SetObjResult(interp, Tcl_NewListObj(2, result)); } return TCL_OK; case SELF_TARGET: if (!CurrentlyInvoked(contextPtr).isFilter) { Tcl_SetObjResult(interp, Tcl_NewStringObj( - "not inside a filtering context", -1)); + "not inside a filtering context", TCL_AUTO_LENGTH)); Tcl_SetErrorCode(interp, "TCL", "OO", "UNMATCHED_CONTEXT", (char *)NULL); return TCL_ERROR; } else { Method *mPtr; Object *declarerPtr; @@ -1269,21 +1271,21 @@ } if (i == contextPtr->callPtr->numChain) { Tcl_Panic("filtering call chain without terminal non-filter"); } mPtr = contextPtr->callPtr->chain[i].mPtr; - if (mPtr->declaringClassPtr != NULL) { + if (mPtr->declaringClassPtr) { declarerPtr = mPtr->declaringClassPtr->thisPtr; - } else if (mPtr->declaringObjectPtr != NULL) { + } else if (mPtr->declaringObjectPtr) { declarerPtr = mPtr->declaringObjectPtr; } else { /* * This should be unreachable code. */ Tcl_SetObjResult(interp, Tcl_NewStringObj( - "method without declarer!", -1)); + "method without declarer!", TCL_AUTO_LENGTH)); return TCL_ERROR; } result[0] = TclOOObjectName(interp, declarerPtr); result[1] = mPtr->namePtr; Tcl_SetObjResult(interp, Tcl_NewListObj(2, result)); @@ -1324,11 +1326,11 @@ "sourceName ?targetName? ?targetNamespace?"); return TCL_ERROR; } oPtr = Tcl_GetObjectFromObj(interp, objv[1]); - if (oPtr == NULL) { + if (!oPtr) { return TCL_ERROR; } /* * Create a cloned object of the correct class. Note that constructors are @@ -1356,22 +1358,21 @@ if (objc == 4) { namespaceName = TclGetString(objv[3]); if (namespaceName[0] == '\0') { namespaceName = NULL; - } else if (Tcl_FindNamespace(interp, namespaceName, NULL, - 0) != NULL) { + } else if (Tcl_FindNamespace(interp, namespaceName, NULL, 0)) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( "%s refers to an existing namespace", namespaceName)); return TCL_ERROR; } } o2Ptr = Tcl_CopyObjectInstance(interp, oPtr, name, namespaceName); } - if (o2Ptr == NULL) { + if (!o2Ptr) { return TCL_ERROR; } /* * Return the name of the cloned object. Index: generic/tclOOCall.c ================================================================== --- generic/tclOOCall.c +++ generic/tclOOCall.c @@ -180,11 +180,11 @@ CallContext *contextPtr) { Object *oPtr = contextPtr->oPtr; TclOODeleteChain(contextPtr->callPtr); - if (oPtr != NULL) { + if (oPtr) { TclStackFree(oPtr->fPtr->interp, contextPtr); /* * Corresponding AddRef() in TclOO.c/TclOOObjectCmdCore */ @@ -231,11 +231,11 @@ void TclOODeleteChain( CallChain *callPtr) { - if (callPtr == NULL || callPtr->refCount-- > 1) { + if (!callPtr || callPtr->refCount-- > 1) { return; } if (callPtr->chain != callPtr->staticChain) { Tcl_Free(callPtr->chain); } @@ -798,14 +798,14 @@ if (isNew) { int isWanted = (!WANT_PUBLIC(flags) || IS_PUBLIC(mPtr)) ? IN_LIST : 0; - isWanted |= (mPtr->typePtr == NULL ? NO_IMPLEMENTATION : 0); + isWanted |= (mPtr->typePtr ? 0 : NO_IMPLEMENTATION); Tcl_SetHashValue(hPtr, INT2PTR(isWanted)); } else if ((PTR2INT(Tcl_GetHashValue(hPtr)) & NO_IMPLEMENTATION) - && mPtr->typePtr != NULL) { + && mPtr->typePtr) { int isWanted = PTR2INT(Tcl_GetHashValue(hPtr)); isWanted &= ~NO_IMPLEMENTATION; Tcl_SetHashValue(hPtr, INT2PTR(isWanted)); } @@ -837,11 +837,11 @@ Method *mPtr; int donePrivate = 0; if (oPtr->methodsPtr) { hPtr = Tcl_FindHashEntry(oPtr->methodsPtr, methodName); - if (hPtr != NULL) { + if (hPtr) { mPtr = (Method *) Tcl_GetHashValue(hPtr); if (IS_PRIVATE(mPtr)) { AddMethodToCallChain(mPtr, cbPtr, NULL, NULL, flags); donePrivate = 1; } @@ -887,11 +887,11 @@ Method *mPtr; if (!(flags & (KNOWN_STATE | SPECIAL)) && oPtr->methodsPtr) { hPtr = Tcl_FindHashEntry(oPtr->methodsPtr, methodNameObj); - if (hPtr != NULL) { + if (hPtr) { mPtr = (Method *) Tcl_GetHashValue(hPtr); if (!IS_PRIVATE(mPtr)) { if (WANT_PUBLIC(flags)) { if (!IS_PUBLIC(mPtr)) { blockedUnexported = 1; @@ -917,11 +917,11 @@ methodNameObj, cbPtr, doneFilters, flags | TRAVERSED_MIXIN, filterDecl); } if (oPtr->methodsPtr && !blockedUnexported) { hPtr = Tcl_FindHashEntry(oPtr->methodsPtr, methodNameObj); - if (hPtr != NULL) { + if (hPtr) { mPtr = (Method *) Tcl_GetHashValue(hPtr); if (!IS_PRIVATE(mPtr)) { AddMethodToCallChain(mPtr, cbPtr, doneFilters, filterDecl, flags); } @@ -984,11 +984,11 @@ * the call chain. * * This is also where we enforce mixin-consistency. */ - if (mPtr == NULL || mPtr->typePtr == NULL || !MIXIN_CONSISTENT(flags)) { + if (!mPtr || !mPtr->typePtr || !MIXIN_CONSISTENT(flags)) { return; } /* * Enforce real private method handling here. We will skip adding this @@ -1002,11 +1002,11 @@ * should be sufficient for [incr Tcl] support though. */ if (!WANT_UNEXPORTED(callPtr->flags) && IS_UNEXPORTED(mPtr) - && (mPtr->declaringClassPtr != NULL) + && mPtr->declaringClassPtr && (mPtr->declaringClassPtr != cbPtr->oPtr->selfCls)) { return; } /* @@ -1171,42 +1171,45 @@ * also be added. [TIP 500] */ Tcl_Obj *cacheInThisObj) /* What object to cache in, or NULL if it is * to be in the same object as the * methodNameObj. */ { + Foundation *fPtr = oPtr->fPtr; CallContext *contextPtr; CallChain *callPtr; ChainBuilder cb; Tcl_Size i, count; int doFilters, donePrivate = 0; Tcl_HashEntry *hPtr; Tcl_HashTable doneFilters; - if (cacheInThisObj == NULL) { + if (!cacheInThisObj) { cacheInThisObj = methodNameObj; } - if (flags&(SPECIAL|FILTER_HANDLING) || (oPtr->flags&FILTER_HANDLING)) { + if (flags & (SPECIAL | FILTER_HANDLING) + || (oPtr->flags & FILTER_HANDLING)) { hPtr = NULL; doFilters = 0; /* * Check if we have a cached valid constructor or destructor. */ if (flags & CONSTRUCTOR) { callPtr = oPtr->selfCls->constructorChainPtr; - if ((callPtr != NULL) + if (callPtr && (callPtr->objectEpoch == oPtr->selfCls->thisPtr->epoch) - && (callPtr->epoch == oPtr->fPtr->epoch)) { + && (callPtr->epoch == fPtr->epoch)) { callPtr->refCount++; goto returnContext; } } else if (flags & DESTRUCTOR) { callPtr = oPtr->selfCls->destructorChainPtr; - if ((oPtr->mixins.num == 0) && (callPtr != NULL) + if ((oPtr->mixins.num == 0) + && callPtr && (callPtr->objectEpoch == oPtr->selfCls->thisPtr->epoch) - && (callPtr->epoch == oPtr->fPtr->epoch)) { + && (callPtr->epoch == fPtr->epoch)) { callPtr->refCount++; goto returnContext; } } } else { @@ -1243,19 +1246,19 @@ methodNameObj); } else { hPtr = NULL; } } else { - if (oPtr->chainCache != NULL) { + if (oPtr->chainCache) { hPtr = Tcl_FindHashEntry(oPtr->chainCache, methodNameObj); } else { hPtr = NULL; } } - if (hPtr != NULL && Tcl_GetHashValue(hPtr) != NULL) { + if (hPtr && Tcl_GetHashValue(hPtr)) { callPtr = (CallChain *) Tcl_GetHashValue(hPtr); if (IsStillValid(callPtr, oPtr, flags, reuseMask)) { callPtr->refCount++; goto returnContext; } @@ -1277,14 +1280,14 @@ * If we're working with a forced use of unknown, do that now. */ if (flags & FORCE_UNKNOWN) { AddSimpleChainToCallContext(oPtr, NULL, - oPtr->fPtr->unknownMethodNameObj, &cb, NULL, BUILDING_MIXINS, + fPtr->unknownMethodNameObj, &cb, NULL, BUILDING_MIXINS, NULL); AddSimpleChainToCallContext(oPtr, NULL, - oPtr->fPtr->unknownMethodNameObj, &cb, NULL, 0, NULL); + fPtr->unknownMethodNameObj, &cb, NULL, 0, NULL); callPtr->flags |= OO_UNKNOWN_METHOD; callPtr->epoch = 0; if (callPtr->numChain == 0) { TclOODeleteChain(callPtr); return NULL; @@ -1354,34 +1357,34 @@ if (flags & SPECIAL) { TclOODeleteChain(callPtr); return NULL; } AddSimpleChainToCallContext(oPtr, NULL, - oPtr->fPtr->unknownMethodNameObj, &cb, NULL, BUILDING_MIXINS, + fPtr->unknownMethodNameObj, &cb, NULL, BUILDING_MIXINS, NULL); AddSimpleChainToCallContext(oPtr, NULL, - oPtr->fPtr->unknownMethodNameObj, &cb, NULL, 0, NULL); + fPtr->unknownMethodNameObj, &cb, NULL, 0, NULL); callPtr->flags |= OO_UNKNOWN_METHOD; callPtr->epoch = 0; if (count == callPtr->numChain) { TclOODeleteChain(callPtr); return NULL; } } else if (doFilters && !donePrivate) { - if (hPtr == NULL) { + if (!hPtr) { int isNew; if (oPtr->flags & USE_CLASS_CACHE) { - if (oPtr->selfCls->classChainCache == NULL) { + if (!oPtr->selfCls->classChainCache) { oPtr->selfCls->classChainCache = (Tcl_HashTable *) Tcl_Alloc(sizeof(Tcl_HashTable)); Tcl_InitObjHashTable(oPtr->selfCls->classChainCache); } hPtr = Tcl_CreateHashEntry(oPtr->selfCls->classChainCache, methodNameObj, &isNew); } else { - if (oPtr->chainCache == NULL) { + if (!oPtr->chainCache) { oPtr->chainCache = (Tcl_HashTable *) Tcl_Alloc(sizeof(Tcl_HashTable)); Tcl_InitObjHashTable(oPtr->chainCache); } @@ -1406,11 +1409,11 @@ callPtr->refCount++; } returnContext: contextPtr = (CallContext *) - TclStackAlloc(oPtr->fPtr->interp, sizeof(CallContext)); + TclStackAlloc(fPtr->interp, sizeof(CallContext)); contextPtr->oPtr = oPtr; /* * Corresponding TclOODecrRefCount() in TclOODeleteContext */ @@ -1458,11 +1461,11 @@ * a call into stereotypical object after it has finished running its * destructor phase. It's quite a tangle, but at that point, we simply * can't get stereotypes. [Bug 7842f33a5c] */ - if (clsPtr == NULL) { + if (!clsPtr) { return NULL; } /* * Synthesize a temporary stereotypical object so that we can use existing @@ -1480,14 +1483,14 @@ * the cache. This is made a bit more complex by the fact that there are * multiple different layers of cache (in the Tcl_Obj, in the object, and * in the class). */ - if (clsPtr->classChainCache != NULL) { + if (clsPtr->classChainCache) { hPtr = Tcl_FindHashEntry(clsPtr->classChainCache, methodNameObj); - if (hPtr != NULL && Tcl_GetHashValue(hPtr) != NULL) { + if (hPtr && Tcl_GetHashValue(hPtr)) { const int reuseMask = (WANT_PUBLIC(flags) ? ~0 : ~PUBLIC_METHOD); callPtr = (CallChain *) Tcl_GetHashValue(hPtr); if (IsStillValid(callPtr, &obj, flags, reuseMask)) { callPtr->refCount++; @@ -1551,13 +1554,13 @@ if (count == callPtr->numChain) { TclOODeleteChain(callPtr); return NULL; } } else { - if (hPtr == NULL) { + if (!hPtr) { int isNew; - if (clsPtr->classChainCache == NULL) { + if (!clsPtr->classChainCache) { clsPtr->classChainCache = (Tcl_HashTable *) Tcl_Alloc(sizeof(Tcl_HashTable)); Tcl_InitObjHashTable(clsPtr->classChainCache); } hPtr = Tcl_CreateHashEntry(clsPtr->classChainCache, @@ -1598,11 +1601,11 @@ flags & ~(TRAVERSED_MIXIN|OBJECT_MIXIN|BUILDING_MIXINS); Class *superPtr, *mixinPtr; Tcl_Obj *filterObj; tailRecurse: - if (clsPtr == NULL) { + if (!clsPtr) { return; } /* * Add all the filters defined by classes mixed into the main class @@ -1695,11 +1698,11 @@ * there is a call into stereotypical object after it has finished running * its destructor phase. [Bug 7842f33a5c] */ tailRecurse: - if (classPtr == NULL) { + if (!classPtr) { return 0; } FOREACH(superPtr, classPtr->mixins) { if (AddPrivatesFromClassChainToCallContext(superPtr, contextCls, methodName, cbPtr, doneFilters, flags|TRAVERSED_MIXIN, @@ -1710,11 +1713,11 @@ if (classPtr == contextCls) { Tcl_HashEntry *hPtr = Tcl_FindHashEntry(&classPtr->classMethods, methodName); - if (hPtr != NULL) { + if (hPtr) { Method *mPtr = (Method *) Tcl_GetHashValue(hPtr); if (IS_PRIVATE(mPtr)) { AddMethodToCallChain(mPtr, cbPtr, doneFilters, filterDecl, flags); @@ -1776,11 +1779,11 @@ * Note that mixins must be processed before the main class hierarchy. * [Bug 1998221] */ tailRecurse: - if (classPtr == NULL) { + if (!classPtr) { return privateDanger; } FOREACH(superPtr, classPtr->mixins) { privateDanger |= AddSimpleClassChainToCallContext(superPtr, methodNameObj, cbPtr, doneFilters, flags | TRAVERSED_MIXIN, @@ -1798,11 +1801,11 @@ methodNameObj); if (classPtr->flags & HAS_PRIVATE_METHODS) { privateDanger |= 1; } - if (hPtr != NULL) { + if (hPtr) { Method *mPtr = (Method *) Tcl_GetHashValue(hPtr); if (!IS_PRIVATE(mPtr)) { if (!(flags & KNOWN_STATE)) { if (flags & PUBLIC_METHOD) { @@ -1893,11 +1896,12 @@ miPtr->mPtr->namePtr; descObjs[2] = miPtr->mPtr->declaringClassPtr ? Tcl_GetObjectName(interp, (Tcl_Object) miPtr->mPtr->declaringClassPtr->thisPtr) : objectLiteral; - descObjs[3] = Tcl_NewStringObj(miPtr->mPtr->typePtr->name, -1); + descObjs[3] = Tcl_NewStringObj(miPtr->mPtr->typePtr->name, + TCL_AUTO_LENGTH); objv[i] = Tcl_NewListObj(4, descObjs); } /* @@ -2103,11 +2107,11 @@ /* * Return if this entry is blank. This is also where we enforce * mixin-consistency. */ - if (namespaceName == NULL || !MIXIN_CONSISTENT(flags)) { + if (!namespaceName || !MIXIN_CONSISTENT(flags)) { return; } /* * First test whether the method is already in the call chain. Index: generic/tclOODefineCmds.c ================================================================== --- generic/tclOODefineCmds.c +++ generic/tclOODefineCmds.c @@ -221,11 +221,11 @@ static inline void BumpGlobalEpoch( Tcl_Interp *interp, Class *classPtr) { - if (classPtr != NULL + if (classPtr && classPtr->subclasses.num == 0 && classPtr->instances.num == 0 && classPtr->mixinSubs.num == 0) { /* * If a class has no subclasses or instances, and is not mixed into @@ -302,11 +302,11 @@ static inline void RecomputeClassCacheFlag( Object *oPtr) { - if ((oPtr->methodsPtr == NULL || oPtr->methodsPtr->numEntries == 0) + if ((!oPtr->methodsPtr || oPtr->methodsPtr->numEntries == 0) && (oPtr->mixins.num == 0) && (oPtr->filters.num == 0)) { oPtr->flags |= USE_CLASS_CACHE; } else { oPtr->flags &= ~USE_CLASS_CACHE; } @@ -707,20 +707,20 @@ Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "METHOD", TclGetString(fromPtr), (char *)NULL); return TCL_ERROR; } hPtr = Tcl_FindHashEntry(oPtr->methodsPtr, fromPtr); - if (hPtr == NULL) { + if (!hPtr) { goto noSuchMethod; } if (toPtr) { newHPtr = Tcl_CreateHashEntry(oPtr->methodsPtr, toPtr, &isNew); if (hPtr == newHPtr) { renameToSelf: Tcl_SetObjResult(interp, Tcl_NewStringObj( - "cannot rename method to itself", -1)); + "cannot rename method to itself", TCL_AUTO_LENGTH)); Tcl_SetErrorCode(interp, "TCL", "OO", "RENAME_TO_SELF", (char *)NULL); return TCL_ERROR; } else if (!isNew) { renameToExisting: Tcl_SetObjResult(interp, Tcl_ObjPrintf( @@ -730,11 +730,11 @@ return TCL_ERROR; } } } else { hPtr = Tcl_FindHashEntry(&oPtr->classPtr->classMethods, fromPtr); - if (hPtr == NULL) { + if (!hPtr) { goto noSuchMethod; } if (toPtr) { newHPtr = Tcl_CreateHashEntry(&oPtr->classPtr->classMethods, (char *) toPtr, &isNew); @@ -792,46 +792,46 @@ Tcl_Size soughtLen; const char *soughtStr, *matchedStr = NULL; if (objc < 2) { Tcl_SetObjResult(interp, Tcl_NewStringObj( - "bad call of unknown handler", -1)); + "bad call of unknown handler", TCL_AUTO_LENGTH)); Tcl_SetErrorCode(interp, "TCL", "OO", "BAD_UNKNOWN", (char *)NULL); return TCL_ERROR; } - if (TclOOGetDefineCmdContext(interp) == NULL) { + if (!TclOOGetDefineCmdContext(interp)) { return TCL_ERROR; } soughtStr = TclGetStringFromObj(objv[1], &soughtLen); if (soughtLen == 0) { goto noMatch; } hPtr = Tcl_FirstHashEntry(&nsPtr->cmdTable, &search); - while (hPtr != NULL) { + while (hPtr) { const char *nameStr = (const char *) Tcl_GetHashKey(&nsPtr->cmdTable, hPtr); - if (strncmp(soughtStr, nameStr, soughtLen) == 0) { - if (matchedStr != NULL) { + if (!strncmp(soughtStr, nameStr, soughtLen)) { + if (matchedStr) { goto noMatch; } matchedStr = nameStr; } hPtr = Tcl_NextHashEntry(&search); } - if (matchedStr != NULL) { + if (matchedStr) { /* * Got one match, and only one match! */ Tcl_Obj **newObjv = (Tcl_Obj **) TclStackAlloc(interp, sizeof(Tcl_Obj*) * (objc - 1)); int result; - newObjv[0] = Tcl_NewStringObj(matchedStr, -1); + newObjv[0] = Tcl_NewStringObj(matchedStr, TCL_AUTO_LENGTH); Tcl_IncrRefCount(newObjv[0]); if (objc > 2) { memcpy(newObjv + 1, objv + 2, sizeof(Tcl_Obj *) * (objc - 2)); } result = Tcl_EvalObjv(interp, objc - 1, newObjv, 0); @@ -872,31 +872,31 @@ /* * If someone is playing games, we stop playing right now. */ - if (string[0] == '\0' || strstr(string, "::") != NULL) { + if (string[0] == '\0' || strstr(string, "::")) { return NULL; } /* * Do the exact lookup first. */ cmd = Tcl_FindCommand(interp, string, namespacePtr, TCL_NAMESPACE_ONLY); - if (cmd != NULL) { + if (cmd) { return cmd; } /* * Bother, need to perform an approximate match. Iterate across the hash * table of commands in the namespace. */ FOREACH_HASH(nameStr, cmd2, &nsPtr->cmdTable) { - if (strncmp(string, nameStr, length) == 0) { - if (cmd != NULL) { + if (!strncmp(string, nameStr, length)) { + if (cmd) { return NULL; } cmd = cmd2; } } @@ -928,13 +928,13 @@ int objc, Tcl_Obj *const objv[]) { CallFrame *framePtr, **framePtrPtr = &framePtr; - if (namespacePtr == NULL) { + if (!namespacePtr) { Tcl_SetObjResult(interp, Tcl_NewStringObj( - "no definition namespace available", -1)); + "no definition namespace available", TCL_AUTO_LENGTH)); Tcl_SetErrorCode(interp, "TCL", "OO", "MONKEY_BUSINESS", (char *)NULL); return TCL_ERROR; } /* @@ -966,24 +966,24 @@ Tcl_Interp *interp) { Interp *iPtr = (Interp *) interp; Tcl_Object object; - if ((iPtr->varFramePtr == NULL) + if (!iPtr->varFramePtr || (iPtr->varFramePtr->isProcCallFrame != FRAME_IS_OO_DEFINE && iPtr->varFramePtr->isProcCallFrame != PRIVATE_FRAME)) { Tcl_SetObjResult(interp, Tcl_NewStringObj( "this command may only be called from within the context of" - " an ::oo::define or ::oo::objdefine command", -1)); + " an ::oo::define or ::oo::objdefine command", TCL_AUTO_LENGTH)); Tcl_SetErrorCode(interp, "TCL", "OO", "MONKEY_BUSINESS", (char *)NULL); return NULL; } object = (Tcl_Object) iPtr->varFramePtr->clientData; if (Tcl_ObjectDeleted(object)) { Tcl_SetObjResult(interp, Tcl_NewStringObj( "this command cannot be called when the object has been" - " deleted", -1)); + " deleted", TCL_AUTO_LENGTH)); Tcl_SetErrorCode(interp, "TCL", "OO", "MONKEY_BUSINESS", (char *)NULL); return NULL; } return object; } @@ -991,16 +991,16 @@ Class * TclOOGetClassDefineCmdContext( Tcl_Interp *interp) { Object *oPtr = (Object *) TclOOGetDefineCmdContext(interp); - if (oPtr == NULL) { + if (!oPtr) { return NULL; } if (!oPtr->classPtr) { Tcl_SetObjResult(interp, Tcl_NewStringObj( - "attempt to misuse API", -1)); + "attempt to misuse API", TCL_AUTO_LENGTH)); Tcl_SetErrorCode(interp, "TCL", "OO", "MONKEY_BUSINESS", NULL); return NULL; } return oPtr->classPtr; } @@ -1028,24 +1028,26 @@ Object *oPtr; CallFrame *savedFramePtr = iPtr->varFramePtr; while (iPtr->varFramePtr->isProcCallFrame == FRAME_IS_OO_DEFINE || iPtr->varFramePtr->isProcCallFrame == PRIVATE_FRAME) { - if (iPtr->varFramePtr->callerVarPtr == NULL) { + if (!iPtr->varFramePtr->callerVarPtr) { Tcl_Panic("getting outer context when already in global context"); } iPtr->varFramePtr = iPtr->varFramePtr->callerVarPtr; } oPtr = (Object *) Tcl_GetObjectFromObj(interp, className); iPtr->varFramePtr = savedFramePtr; - if (oPtr == NULL) { + if (!oPtr) { return NULL; } - if (oPtr->classPtr == NULL) { - Tcl_SetObjResult(interp, Tcl_NewStringObj(errMsg, -1)); - Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "CLASS", - TclGetString(className), (char *)NULL); + if (!oPtr->classPtr) { + if (errMsg) { + Tcl_SetObjResult(interp, Tcl_NewStringObj(errMsg, TCL_AUTO_LENGTH)); + Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "CLASS", + TclGetString(className), (char *)NULL); + } return NULL; } return oPtr->classPtr; } @@ -1059,11 +1061,11 @@ int result; CallFrame *savedFramePtr = iPtr->varFramePtr; while (iPtr->varFramePtr->isProcCallFrame == FRAME_IS_OO_DEFINE || iPtr->varFramePtr->isProcCallFrame == PRIVATE_FRAME) { - if (iPtr->varFramePtr->callerVarPtr == NULL) { + if (!iPtr->varFramePtr->callerVarPtr) { Tcl_Panic("getting outer context when already in global context"); } iPtr->varFramePtr = iPtr->varFramePtr->callerVarPtr; } result = TclGetNamespaceFromObj(interp, namespaceName, &nsPtr); @@ -1156,11 +1158,11 @@ */ TclNewObj(objPtr); TclNewObj(obj2Ptr); cmd = FindCommand(interp, objv[cmdIndex], nsPtr); - if (cmd == NULL) { + if (!cmd) { /* * Punt this case! */ Tcl_AppendObjToObj(obj2Ptr, objv[cmdIndex]); @@ -1210,14 +1212,14 @@ Tcl_WrongNumArgs(interp, 1, objv, "className arg ?arg ...?"); return TCL_ERROR; } oPtr = (Object *) Tcl_GetObjectFromObj(interp, objv[1]); - if (oPtr == NULL) { + if (!oPtr) { return TCL_ERROR; } - if (oPtr->classPtr == NULL) { + if (!oPtr->classPtr) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( "%s does not refer to a class", TclGetString(objv[1]))); Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "CLASS", TclGetString(objv[1]), (char *)NULL); return TCL_ERROR; @@ -1286,11 +1288,11 @@ Tcl_WrongNumArgs(interp, 1, objv, "objectName arg ?arg ...?"); return TCL_ERROR; } oPtr = (Object *) Tcl_GetObjectFromObj(interp, objv[1]); - if (oPtr == NULL) { + if (!oPtr) { return TCL_ERROR; } /* * Make the oo::objdefine namespace the current namespace and evaluate the @@ -1350,11 +1352,11 @@ Tcl_Namespace *nsPtr; Object *oPtr; int result, isPrivate; oPtr = (Object *) TclOOGetDefineCmdContext(interp); - if (oPtr == NULL) { + if (!oPtr) { return TCL_ERROR; } if (objc < 2) { Tcl_SetObjResult(interp, TclOOObjectName(interp, oPtr)); @@ -1424,11 +1426,11 @@ Tcl_WrongNumArgs(interp, 1, objv, NULL); return TCL_ERROR; } oPtr = (Object *) TclOOGetDefineCmdContext(interp); - if (oPtr == NULL) { + if (!oPtr) { return TCL_ERROR; } Tcl_SetObjResult(interp, TclOOObjectName(interp, oPtr)); return TCL_OK; @@ -1461,11 +1463,11 @@ int saved; /* The saved flag. We restore it on exit so * that [private private ...] doesn't make * things go weird. */ int result; - if (oPtr == NULL) { + if (!oPtr) { return TCL_ERROR; } if (objc == 1) { Tcl_SetObjResult(interp, Tcl_NewBooleanObj(IsPrivateDefine(interp))); return TCL_OK; @@ -1533,22 +1535,24 @@ /* * Parse the context to get the object to operate on. */ oPtr = (Object *) TclOOGetDefineCmdContext(interp); - if (oPtr == NULL) { + if (!oPtr) { return TCL_ERROR; } if (oPtr->flags & ROOT_OBJECT) { Tcl_SetObjResult(interp, Tcl_NewStringObj( - "may not modify the class of the root object class", -1)); + "may not modify the class of the root object class", + TCL_AUTO_LENGTH)); Tcl_SetErrorCode(interp, "TCL", "OO", "MONKEY_BUSINESS", (char *)NULL); return TCL_ERROR; } if (oPtr->flags & ROOT_CLASS) { Tcl_SetObjResult(interp, Tcl_NewStringObj( - "may not modify the class of the class of classes", -1)); + "may not modify the class of the class of classes", + TCL_AUTO_LENGTH)); Tcl_SetErrorCode(interp, "TCL", "OO", "MONKEY_BUSINESS", (char *)NULL); return TCL_ERROR; } /* @@ -1559,16 +1563,17 @@ Tcl_WrongNumArgs(interp, 1, objv, "className"); return TCL_ERROR; } clsPtr = GetClassInOuterContext(interp, objv[1], "the class of an object must be a class"); - if (clsPtr == NULL) { + if (!clsPtr) { return TCL_ERROR; } if (oPtr == clsPtr->thisPtr) { Tcl_SetObjResult(interp, Tcl_NewStringObj( - "may not change classes into an instance of themselves", -1)); + "may not change classes into an instance of themselves", + TCL_AUTO_LENGTH)); Tcl_SetErrorCode(interp, "TCL", "OO", "MONKEY_BUSINESS", (char *)NULL); return TCL_ERROR; } /* @@ -1594,11 +1599,11 @@ * This is the most global of all epochs. Bump it! No cache can be * trusted! */ TclOORemoveFromMixins(oPtr->classPtr, oPtr); - oPtr->fPtr->epoch++; + GetFoundation(interp)->epoch++; oPtr->flags |= DONT_DELETE; TclOODeleteDescendants(interp, oPtr); oPtr->flags &= ~DONT_DELETE; TclOOReleaseClassContents(interp, oPtr); Tcl_Free(oPtr->classPtr); @@ -1605,11 +1610,11 @@ oPtr->classPtr = NULL; } else if (!wasClass && willBeClass) { TclOOAllocClass(interp, oPtr); } - if (oPtr->classPtr != NULL) { + if (oPtr->classPtr) { BumpGlobalEpoch(interp, oPtr->classPtr); } else { BumpInstanceEpoch(oPtr); } } @@ -1636,11 +1641,11 @@ { Class *clsPtr = TclOOGetClassDefineCmdContext(interp); Tcl_Method method; Tcl_Size bodyLength; - if (clsPtr == NULL) { + if (!clsPtr) { return TCL_ERROR; } else if (objc != 3) { Tcl_WrongNumArgs(interp, 1, objv, "arguments body"); return TCL_ERROR; } @@ -1651,11 +1656,11 @@ * Create the method structure. */ method = (Tcl_Method) TclOONewProcMethod(interp, clsPtr, PUBLIC_METHOD, NULL, objv[1], objv[2], NULL); - if (method == NULL) { + if (!method) { return TCL_ERROR; } } else { /* * Delete the constructor method record and set the field in the @@ -1701,16 +1706,16 @@ int kind = 0; Class *clsPtr = TclOOGetClassDefineCmdContext(interp); Tcl_Namespace *nsPtr; Tcl_Obj *nsNamePtr, **storagePtr; - if (clsPtr == NULL) { + if (!clsPtr) { return TCL_ERROR; } else if (clsPtr->thisPtr->flags & (ROOT_OBJECT | ROOT_CLASS)) { Tcl_SetObjResult(interp, Tcl_NewStringObj( "may not modify the definition namespace of the root classes", - -1)); + TCL_AUTO_LENGTH)); Tcl_SetErrorCode(interp, "TCL", "OO", "MONKEY_BUSINESS", (char *)NULL); return TCL_ERROR; } /* @@ -1727,11 +1732,11 @@ } if (!TclGetString(objv[objc - 1])[0]) { nsNamePtr = NULL; } else { nsPtr = GetNamespaceInOuterContext(interp, objv[objc - 1]); - if (nsPtr == NULL) { + if (!nsPtr) { return TCL_ERROR; } nsNamePtr = TclNewNamespaceObj(nsPtr); Tcl_IncrRefCount(nsNamePtr); } @@ -1743,11 +1748,11 @@ if (kind) { storagePtr = &clsPtr->objDefinitionNs; } else { storagePtr = &clsPtr->clsDefinitionNs; } - if (*storagePtr != NULL) { + if (*storagePtr) { Tcl_DecrRefCount(*storagePtr); } *storagePtr = nsNamePtr; return TCL_OK; } @@ -1778,16 +1783,16 @@ Tcl_WrongNumArgs(interp, 1, objv, "name ?name ...?"); return TCL_ERROR; } oPtr = (Object *) TclOOGetDefineCmdContext(interp); - if (oPtr == NULL) { + if (!oPtr) { return TCL_ERROR; } if (!isInstanceDeleteMethod && !oPtr->classPtr) { Tcl_SetObjResult(interp, Tcl_NewStringObj( - "attempt to misuse API", -1)); + "attempt to misuse API", TCL_AUTO_LENGTH)); Tcl_SetErrorCode(interp, "TCL", "OO", "MONKEY_BUSINESS", (char *)NULL); return TCL_ERROR; } for (i = 1; i < objc; i++) { @@ -1829,11 +1834,11 @@ { Tcl_Method method; Tcl_Size bodyLength; Class *clsPtr = TclOOGetClassDefineCmdContext(interp); - if (clsPtr == NULL) { + if (!clsPtr) { return TCL_ERROR; } else if (objc != 2) { Tcl_WrongNumArgs(interp, 1, objv, "body"); return TCL_ERROR; } @@ -1845,11 +1850,11 @@ * Create the method structure. */ method = (Tcl_Method) TclOONewProcMethod(interp, clsPtr, PUBLIC_METHOD, NULL, NULL, objv[1], NULL); - if (method == NULL) { + if (!method) { return TCL_ERROR; } } else { /* * Delete the destructor method record and set the field in the class @@ -1899,17 +1904,17 @@ Tcl_WrongNumArgs(interp, 1, objv, "name ?name ...?"); return TCL_ERROR; } oPtr = (Object *) TclOOGetDefineCmdContext(interp); - if (oPtr == NULL) { + if (!oPtr) { return TCL_ERROR; } clsPtr = oPtr->classPtr; if (!isInstanceExport && !clsPtr) { Tcl_SetObjResult(interp, Tcl_NewStringObj( - "attempt to misuse API", -1)); + "attempt to misuse API", TCL_AUTO_LENGTH)); Tcl_SetErrorCode(interp, "TCL", "OO", "MONKEY_BUSINESS", (char *)NULL); return TCL_ERROR; } for (i = 1; i < objc; i++) { @@ -1995,16 +2000,16 @@ Tcl_WrongNumArgs(interp, 1, objv, "name cmdName ?arg ...?"); return TCL_ERROR; } oPtr = (Object *) TclOOGetDefineCmdContext(interp); - if (oPtr == NULL) { + if (!oPtr) { return TCL_ERROR; } if (!isInstanceForward && !oPtr->classPtr) { Tcl_SetObjResult(interp, Tcl_NewStringObj( - "attempt to misuse API", -1)); + "attempt to misuse API", TCL_AUTO_LENGTH)); Tcl_SetErrorCode(interp, "TCL", "OO", "MONKEY_BUSINESS", (char *)NULL); return TCL_ERROR; } isPublic = Tcl_StringMatch(TclGetString(objv[1]), PUBLIC_PATTERN) ? PUBLIC_METHOD : 0; @@ -2022,11 +2027,11 @@ prefixObj); } else { mPtr = TclOONewForwardMethod(interp, oPtr->classPtr, isPublic, objv[1], prefixObj); } - if (mPtr == NULL) { + if (!mPtr) { Tcl_DecrRefCount(prefixObj); return TCL_ERROR; } return TCL_OK; } @@ -2073,16 +2078,16 @@ Tcl_WrongNumArgs(interp, 1, objv, "name ?option? args body"); return TCL_ERROR; } oPtr = (Object *) TclOOGetDefineCmdContext(interp); - if (oPtr == NULL) { + if (!oPtr) { return TCL_ERROR; } if (!isInstanceMethod && !oPtr->classPtr) { Tcl_SetObjResult(interp, Tcl_NewStringObj( - "attempt to misuse API", -1)); + "attempt to misuse API", TCL_AUTO_LENGTH)); Tcl_SetErrorCode(interp, "TCL", "OO", "MONKEY_BUSINESS", (char *)NULL); return TCL_ERROR; } if (objc == 5) { if (Tcl_GetIndexFromObj(interp, objv[2], exportModes, "export flag", @@ -2112,17 +2117,17 @@ /* * Create the method by using the right back-end API. */ if (isInstanceMethod) { - if (TclOONewProcInstanceMethod(interp, oPtr, isPublic, objv[1], - objv[objc - 2], objv[objc - 1], NULL) == NULL) { + if (!TclOONewProcInstanceMethod(interp, oPtr, isPublic, objv[1], + objv[objc - 2], objv[objc - 1], NULL)) { return TCL_ERROR; } } else { - if (TclOONewProcMethod(interp, oPtr->classPtr, isPublic, objv[1], - objv[objc - 2], objv[objc - 1], NULL) == NULL) { + if (!TclOONewProcMethod(interp, oPtr->classPtr, isPublic, objv[1], + objv[objc - 2], objv[objc - 1], NULL)) { return TCL_ERROR; } } return TCL_OK; } @@ -2152,16 +2157,16 @@ Tcl_WrongNumArgs(interp, 1, objv, "oldName newName"); return TCL_ERROR; } oPtr = (Object *) TclOOGetDefineCmdContext(interp); - if (oPtr == NULL) { + if (!oPtr) { return TCL_ERROR; } if (!isInstanceRenameMethod && !oPtr->classPtr) { Tcl_SetObjResult(interp, Tcl_NewStringObj( - "attempt to misuse API", -1)); + "attempt to misuse API", TCL_AUTO_LENGTH)); Tcl_SetErrorCode(interp, "TCL", "OO", "MONKEY_BUSINESS", (char *)NULL); return TCL_ERROR; } /* @@ -2213,17 +2218,17 @@ Tcl_WrongNumArgs(interp, 1, objv, "name ?name ...?"); return TCL_ERROR; } oPtr = (Object *) TclOOGetDefineCmdContext(interp); - if (oPtr == NULL) { + if (!oPtr) { return TCL_ERROR; } clsPtr = oPtr->classPtr; if (!isInstanceUnexport && !clsPtr) { Tcl_SetObjResult(interp, Tcl_NewStringObj( - "attempt to misuse API", -1)); + "attempt to misuse API", TCL_AUTO_LENGTH)); Tcl_SetErrorCode(interp, "TCL", "OO", "MONKEY_BUSINESS", (char *)NULL); return TCL_ERROR; } for (i = 1; i < objc; i++) { @@ -2355,15 +2360,15 @@ Tcl_Obj *getName, *setName, *resolveName; Tcl_Object object = Tcl_NewObjectInstance(interp, (Tcl_Class) fPtr->classCls, "::oo::Slot", NULL, TCL_INDEX_NONE, NULL, 0); Class *slotCls; - if (object == NULL) { + if (!object) { return TCL_ERROR; } slotCls = ((Object *) object)->classPtr; - if (slotCls == NULL) { + if (!slotCls) { return TCL_ERROR; } TclNewLiteralStringObj(getName, "Get"); TclNewLiteralStringObj(setName, "Set"); @@ -2371,11 +2376,11 @@ for (slotInfoPtr = slots ; slotInfoPtr->name ; slotInfoPtr++) { Tcl_Object slotObject = Tcl_NewObjectInstance(interp, (Tcl_Class) slotCls, slotInfoPtr->name, NULL, TCL_INDEX_NONE, NULL, 0); - if (slotObject == NULL) { + if (!slotObject) { continue; } TclNewInstanceMethod(interp, slotObject, getName, 0, &slotInfoPtr->getterType, NULL); TclNewInstanceMethod(interp, slotObject, setName, 0, @@ -2412,11 +2417,11 @@ { Class *clsPtr = TclOOGetClassDefineCmdContext(interp); Tcl_Obj *resultObj, *filterObj; Tcl_Size i; - if (clsPtr == NULL) { + if (!clsPtr) { return TCL_ERROR; } else if (Tcl_ObjectContextSkippedArgs(context) != objc) { Tcl_WrongNumArgs(interp, Tcl_ObjectContextSkippedArgs(context), objv, NULL); return TCL_ERROR; @@ -2440,11 +2445,11 @@ { Class *clsPtr = TclOOGetClassDefineCmdContext(interp); Tcl_Size filterc; Tcl_Obj **filterv; - if (clsPtr == NULL) { + if (!clsPtr) { return TCL_ERROR; } else if (Tcl_ObjectContextSkippedArgs(context) + 1 != objc) { Tcl_WrongNumArgs(interp, Tcl_ObjectContextSkippedArgs(context), objv, "filterList"); return TCL_ERROR; @@ -2482,11 +2487,11 @@ Class *clsPtr = TclOOGetClassDefineCmdContext(interp); Tcl_Obj *resultObj; Class *mixinPtr; Tcl_Size i; - if (clsPtr == NULL) { + if (!clsPtr) { return TCL_ERROR; } else if (Tcl_ObjectContextSkippedArgs(context) != objc) { Tcl_WrongNumArgs(interp, Tcl_ObjectContextSkippedArgs(context), objv, NULL); return TCL_ERROR; @@ -2518,11 +2523,11 @@ Tcl_HashTable uniqueCheck; /* Note that this hash table is just used as a * set of class references; it has no payload * values and keys are always pointers. */ int isNew; - if (clsPtr == NULL) { + if (!clsPtr) { return TCL_ERROR; } else if (Tcl_ObjectContextSkippedArgs(context) + 1 != objc) { Tcl_WrongNumArgs(interp, Tcl_ObjectContextSkippedArgs(context), objv, "mixinList"); return TCL_ERROR; @@ -2537,24 +2542,25 @@ Tcl_InitHashTable(&uniqueCheck, TCL_ONE_WORD_KEYS); for (i = 0; i < mixinc; i++) { mixins[i] = GetClassInOuterContext(interp, mixinv[i], "may only mix in classes"); - if (mixins[i] == NULL) { + if (!mixins[i]) { i--; goto freeAndError; } (void) Tcl_CreateHashEntry(&uniqueCheck, (void *) mixins[i], &isNew); if (!isNew) { Tcl_SetObjResult(interp, Tcl_NewStringObj( - "class should only be a direct mixin once", -1)); + "class should only be a direct mixin once", + TCL_AUTO_LENGTH)); Tcl_SetErrorCode(interp, "TCL", "OO", "REPETITIOUS", (char *)NULL); goto freeAndError; } if (TclOOIsReachable(clsPtr, mixins[i])) { Tcl_SetObjResult(interp, Tcl_NewStringObj( - "may not mix a class into itself", -1)); + "may not mix a class into itself", TCL_AUTO_LENGTH)); Tcl_SetErrorCode(interp, "TCL", "OO", "SELF_MIXIN", (char *)NULL); goto freeAndError; } } @@ -2591,11 +2597,11 @@ Class *clsPtr = TclOOGetClassDefineCmdContext(interp); Tcl_Obj *resultObj; Class *superPtr; Tcl_Size i; - if (clsPtr == NULL) { + if (!clsPtr) { return TCL_ERROR; } else if (Tcl_ObjectContextSkippedArgs(context) != objc) { Tcl_WrongNumArgs(interp, Tcl_ObjectContextSkippedArgs(context), objv, NULL); return TCL_ERROR; @@ -2622,23 +2628,24 @@ Tcl_Size superc, j; Tcl_Size i; Tcl_Obj **superv; Class **superclasses, *superPtr; - if (clsPtr == NULL) { + if (!clsPtr) { return TCL_ERROR; } else if (Tcl_ObjectContextSkippedArgs(context) + 1 != objc) { Tcl_WrongNumArgs(interp, Tcl_ObjectContextSkippedArgs(context), objv, "superclassList"); return TCL_ERROR; } objv += Tcl_ObjectContextSkippedArgs(context); - Foundation *fPtr = clsPtr->thisPtr->fPtr; + Foundation *fPtr = GetFoundation(interp); if (clsPtr == fPtr->objectCls) { Tcl_SetObjResult(interp, Tcl_NewStringObj( - "may not modify the superclass of the root object", -1)); + "may not modify the superclass of the root object", + TCL_AUTO_LENGTH)); Tcl_SetErrorCode(interp, "TCL", "OO", "MONKEY_BUSINESS", (char *)NULL); return TCL_ERROR; } else if (TclListObjGetElements(interp, objv[0], &superc, &superv) != TCL_OK) { return TCL_ERROR; @@ -2668,25 +2675,26 @@ AddRef(superclasses[0]->thisPtr); } else { for (i = 0; i < superc; i++) { superclasses[i] = GetClassInOuterContext(interp, superv[i], "only a class can be a superclass"); - if (superclasses[i] == NULL) { + if (!superclasses[i]) { goto failedAfterAlloc; } for (j = 0; j < i; j++) { if (superclasses[j] == superclasses[i]) { Tcl_SetObjResult(interp, Tcl_NewStringObj( "class should only be a direct superclass once", - -1)); + TCL_AUTO_LENGTH)); Tcl_SetErrorCode(interp, "TCL", "OO", "REPETITIOUS",(char *)NULL); goto failedAfterAlloc; } } if (TclOOIsReachable(clsPtr, superclasses[i])) { Tcl_SetObjResult(interp, Tcl_NewStringObj( - "attempt to form circular dependency graph", -1)); + "attempt to form circular dependency graph", + TCL_AUTO_LENGTH)); Tcl_SetErrorCode(interp, "TCL", "OO", "CIRCULARITY", (char *)NULL); failedAfterAlloc: for (; i-- > 0 ;) { TclOODecrRefCount(superclasses[i]->thisPtr); } @@ -2748,11 +2756,11 @@ { Class *clsPtr = TclOOGetClassDefineCmdContext(interp); Tcl_Obj *resultObj; Tcl_Size i; - if (clsPtr == NULL) { + if (!clsPtr) { return TCL_ERROR; } else if (Tcl_ObjectContextSkippedArgs(context) != objc) { Tcl_WrongNumArgs(interp, Tcl_ObjectContextSkippedArgs(context), objv, NULL); return TCL_ERROR; @@ -2787,11 +2795,11 @@ Class *clsPtr = TclOOGetClassDefineCmdContext(interp); Tcl_Size i; Tcl_Size varc; Tcl_Obj **varv; - if (clsPtr == NULL) { + if (!clsPtr) { return TCL_ERROR; } else if (Tcl_ObjectContextSkippedArgs(context) + 1 != objc) { Tcl_WrongNumArgs(interp, Tcl_ObjectContextSkippedArgs(context), objv, "filterList"); return TCL_ERROR; @@ -2803,11 +2811,11 @@ } for (i = 0; i < varc; i++) { const char *varName = TclGetString(varv[i]); - if (strstr(varName, "::") != NULL) { + if (strstr(varName, "::")) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( "invalid declared variable name \"%s\": must not %s", varName, "contain namespace separators")); Tcl_SetErrorCode(interp, "TCL", "OO", "BAD_DECLVAR", (char *)NULL); return TCL_ERROR; @@ -2855,11 +2863,11 @@ if (Tcl_ObjectContextSkippedArgs(context) != objc) { Tcl_WrongNumArgs(interp, Tcl_ObjectContextSkippedArgs(context), objv, NULL); return TCL_ERROR; - } else if (oPtr == NULL) { + } else if (!oPtr) { return TCL_ERROR; } TclNewObj(resultObj); FOREACH(filterObj, oPtr->filters) { @@ -2883,11 +2891,11 @@ if (Tcl_ObjectContextSkippedArgs(context) + 1 != objc) { Tcl_WrongNumArgs(interp, Tcl_ObjectContextSkippedArgs(context), objv, "filterList"); return TCL_ERROR; - } else if (oPtr == NULL) { + } else if (!oPtr) { return TCL_ERROR; } objv += Tcl_ObjectContextSkippedArgs(context); if (TclListObjGetElements(interp, objv[0], &filterc, &filterv) != TCL_OK) { return TCL_ERROR; @@ -2923,11 +2931,11 @@ if (Tcl_ObjectContextSkippedArgs(context) != objc) { Tcl_WrongNumArgs(interp, Tcl_ObjectContextSkippedArgs(context), objv, NULL); return TCL_ERROR; - } else if (oPtr == NULL) { + } else if (!oPtr) { return TCL_ERROR; } TclNewObj(resultObj); FOREACH(mixinPtr, oPtr->mixins) { @@ -2960,11 +2968,11 @@ if (Tcl_ObjectContextSkippedArgs(context) + 1 != objc) { Tcl_WrongNumArgs(interp, Tcl_ObjectContextSkippedArgs(context), objv, "mixinList"); return TCL_ERROR; - } else if (oPtr == NULL) { + } else if (!oPtr) { return TCL_ERROR; } objv += Tcl_ObjectContextSkippedArgs(context); if (TclListObjGetElements(interp, objv[0], &mixinc, &mixinv) != TCL_OK) { return TCL_ERROR; @@ -2974,17 +2982,17 @@ Tcl_InitHashTable(&uniqueCheck, TCL_ONE_WORD_KEYS); for (i = 0; i < mixinc; i++) { mixins[i] = GetClassInOuterContext(interp, mixinv[i], "may only mix in classes"); - if (mixins[i] == NULL) { + if (!mixins[i]) { goto freeAndError; } (void) Tcl_CreateHashEntry(&uniqueCheck, (void *) mixins[i], &isNew); if (!isNew) { Tcl_SetObjResult(interp, Tcl_NewStringObj( - "class should only be a direct mixin once", -1)); + "class should only be a direct mixin once", TCL_AUTO_LENGTH)); Tcl_SetErrorCode(interp, "TCL", "OO", "REPETITIOUS", (char *)NULL); goto freeAndError; } } @@ -3024,11 +3032,11 @@ if (Tcl_ObjectContextSkippedArgs(context) != objc) { Tcl_WrongNumArgs(interp, Tcl_ObjectContextSkippedArgs(context), objv, NULL); return TCL_ERROR; - } else if (oPtr == NULL) { + } else if (!oPtr) { return TCL_ERROR; } TclNewObj(resultObj); if (IsPrivateDefine(interp)) { @@ -3062,11 +3070,11 @@ if (Tcl_ObjectContextSkippedArgs(context) + 1 != objc) { Tcl_WrongNumArgs(interp, Tcl_ObjectContextSkippedArgs(context), objv, "variableList"); return TCL_ERROR; - } else if (oPtr == NULL) { + } else if (!oPtr) { return TCL_ERROR; } objv += Tcl_ObjectContextSkippedArgs(context); if (TclListObjGetElements(interp, objv[0], &varc, &varv) != TCL_OK) { return TCL_ERROR; @@ -3073,11 +3081,11 @@ } for (i = 0; i < varc; i++) { const char *varName = TclGetString(varv[i]); - if (strstr(varName, "::") != NULL) { + if (strstr(varName, "::")) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( "invalid declared variable name \"%s\": must not %s", varName, "contain namespace separators")); Tcl_SetErrorCode(interp, "TCL", "OO", "BAD_DECLVAR", (char *)NULL); return TCL_ERROR; @@ -3127,11 +3135,11 @@ /* * Check if were called wrongly. The definition context isn't used... * except that GetClassInOuterContext() assumes that it is there. */ - if (oPtr == NULL) { + if (!oPtr) { return TCL_ERROR; } else if (objc != idx + 1) { Tcl_WrongNumArgs(interp, idx, objv, "slotElement"); return TCL_ERROR; } @@ -3139,13 +3147,12 @@ /* * 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. */ - clsPtr = GetClassInOuterContext(interp, objv[idx], - "USER SHOULD NOT SEE THIS MESSAGE"); - if (clsPtr == NULL) { + clsPtr = GetClassInOuterContext(interp, objv[idx], NULL); + if (!clsPtr) { Tcl_ResetResult(interp); Tcl_SetObjResult(interp, objv[idx]); } else { Tcl_SetObjResult(interp, TclOOObjectName(interp, clsPtr->thisPtr)); } @@ -3173,11 +3180,11 @@ int objc, Tcl_Obj *const *objv) { Class *clsPtr = TclOOGetClassDefineCmdContext(interp); - if (clsPtr == NULL) { + if (!clsPtr) { return TCL_ERROR; } else if (Tcl_ObjectContextSkippedArgs(context) != objc) { Tcl_WrongNumArgs(interp, Tcl_ObjectContextSkippedArgs(context), objv, NULL); return TCL_ERROR; @@ -3197,11 +3204,11 @@ { Class *clsPtr = TclOOGetClassDefineCmdContext(interp); Tcl_Size varc; Tcl_Obj **varv; - if (clsPtr == NULL) { + if (!clsPtr) { return TCL_ERROR; } else if (Tcl_ObjectContextSkippedArgs(context) + 1 != objc) { Tcl_WrongNumArgs(interp, Tcl_ObjectContextSkippedArgs(context), objv, "filterList"); return TCL_ERROR; @@ -3225,11 +3232,11 @@ int objc, Tcl_Obj *const *objv) { Object *oPtr = (Object *) TclOOGetDefineCmdContext(interp); - if (oPtr == NULL) { + if (!oPtr) { return TCL_ERROR; } else if (Tcl_ObjectContextSkippedArgs(context) != objc) { Tcl_WrongNumArgs(interp, Tcl_ObjectContextSkippedArgs(context), objv, NULL); return TCL_ERROR; @@ -3256,11 +3263,11 @@ "filterList"); return TCL_ERROR; } objv += Tcl_ObjectContextSkippedArgs(context); - if (oPtr == NULL) { + if (!oPtr) { return TCL_ERROR; } else if (TclListObjGetElements(interp, objv[0], &varc, &varv) != TCL_OK) { return TCL_ERROR; } @@ -3289,11 +3296,11 @@ int objc, Tcl_Obj *const *objv) { Class *clsPtr = TclOOGetClassDefineCmdContext(interp); - if (clsPtr == NULL) { + if (!clsPtr) { return TCL_ERROR; } else if (Tcl_ObjectContextSkippedArgs(context) != objc) { Tcl_WrongNumArgs(interp, Tcl_ObjectContextSkippedArgs(context), objv, NULL); return TCL_ERROR; @@ -3313,11 +3320,11 @@ { Class *clsPtr = TclOOGetClassDefineCmdContext(interp); Tcl_Size varc; Tcl_Obj **varv; - if (clsPtr == NULL) { + if (!clsPtr) { return TCL_ERROR; } else if (Tcl_ObjectContextSkippedArgs(context) + 1 != objc) { Tcl_WrongNumArgs(interp, Tcl_ObjectContextSkippedArgs(context), objv, "propertyList"); return TCL_ERROR; @@ -3341,11 +3348,11 @@ int objc, Tcl_Obj *const *objv) { Object *oPtr = (Object *) TclOOGetDefineCmdContext(interp); - if (oPtr == NULL) { + if (!oPtr) { return TCL_ERROR; } else if (Tcl_ObjectContextSkippedArgs(context) != objc) { Tcl_WrongNumArgs(interp, Tcl_ObjectContextSkippedArgs(context), objv, NULL); return TCL_ERROR; @@ -3372,11 +3379,11 @@ "propertyList"); return TCL_ERROR; } objv += Tcl_ObjectContextSkippedArgs(context); - if (oPtr == NULL) { + if (!oPtr) { return TCL_ERROR; } else if (TclListObjGetElements(interp, objv[0], &varc, &varv) != TCL_OK) { return TCL_ERROR; } Index: generic/tclOOInfo.c ================================================================== --- generic/tclOOInfo.c +++ generic/tclOOInfo.c @@ -160,14 +160,14 @@ Tcl_Interp *interp, Tcl_Obj *objPtr) { Object *oPtr = (Object *) Tcl_GetObjectFromObj(interp, objPtr); - if (oPtr == NULL) { + if (!oPtr) { return NULL; } - if (oPtr->classPtr == NULL) { + if (!oPtr->classPtr) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( "\"%s\" is not a class", TclGetString(objPtr))); Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "CLASS", TclGetString(objPtr), (char *)NULL); return NULL; @@ -198,11 +198,11 @@ Tcl_WrongNumArgs(interp, 1, objv, "objName ?className?"); return TCL_ERROR; } oPtr = (Object *) Tcl_GetObjectFromObj(interp, objv[1]); - if (oPtr == NULL) { + if (!oPtr) { return TCL_ERROR; } if (objc == 2) { Tcl_SetObjResult(interp, @@ -211,11 +211,11 @@ } else { Class *mixinPtr, *o2clsPtr; Tcl_Size i; o2clsPtr = TclOOGetClassFromObj(interp, objv[2]); - if (o2clsPtr == NULL) { + if (!o2clsPtr) { return TCL_ERROR; } FOREACH(mixinPtr, oPtr->mixins) { if (!mixinPtr) { @@ -259,23 +259,23 @@ Tcl_WrongNumArgs(interp, 1, objv, "objName methodName"); return TCL_ERROR; } oPtr = (Object *) Tcl_GetObjectFromObj(interp, objv[1]); - if (oPtr == NULL) { + if (!oPtr) { return TCL_ERROR; } if (!oPtr->methodsPtr) { goto unknownMethod; } hPtr = Tcl_FindHashEntry(oPtr->methodsPtr, objv[2]); - if (hPtr == NULL) { + if (!hPtr) { goto unknownMethod; } procPtr = TclOOGetProcFromMethod((Method *) Tcl_GetHashValue(hPtr)); - if (procPtr == NULL) { + if (!procPtr) { goto wrongType; } /* * We now have the method to describe the definition of. @@ -287,11 +287,11 @@ if (TclIsVarArgument(localPtr)) { Tcl_Obj *argObj; TclNewObj(argObj); Tcl_ListObjAppendElement(NULL, argObj, LocalVarName(localPtr)); - if (localPtr->defValuePtr != NULL) { + if (localPtr->defValuePtr) { Tcl_ListObjAppendElement(NULL, argObj, localPtr->defValuePtr); } Tcl_ListObjAppendElement(NULL, resultObjs[0], argObj); } } @@ -310,11 +310,11 @@ TclGetString(objv[2]), (char *)NULL); return TCL_ERROR; wrongType: Tcl_SetObjResult(interp, Tcl_NewStringObj( - "definition not available for this kind of method", -1)); + "definition not available for this kind of method", TCL_AUTO_LENGTH)); Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "METHOD", TclGetString(objv[2]), (char *)NULL); return TCL_ERROR; } @@ -343,11 +343,11 @@ Tcl_WrongNumArgs(interp, 1, objv, "objName"); return TCL_ERROR; } oPtr = (Object *) Tcl_GetObjectFromObj(interp, objv[1]); - if (oPtr == NULL) { + if (!oPtr) { return TCL_ERROR; } TclNewObj(resultObj); FOREACH(filterObj, oPtr->filters) { @@ -382,23 +382,23 @@ Tcl_WrongNumArgs(interp, 1, objv, "objName methodName"); return TCL_ERROR; } oPtr = (Object *) Tcl_GetObjectFromObj(interp, objv[1]); - if (oPtr == NULL) { + if (!oPtr) { return TCL_ERROR; } if (!oPtr->methodsPtr) { goto unknownMethod; } hPtr = Tcl_FindHashEntry(oPtr->methodsPtr, objv[2]); - if (hPtr == NULL) { + if (!hPtr) { goto unknownMethod; } prefixObj = TclOOGetFwdFromMethod((Method *) Tcl_GetHashValue(hPtr)); - if (prefixObj == NULL) { + if (!prefixObj) { goto wrongType; } /* * Describe the valid forward method. @@ -419,11 +419,11 @@ return TCL_ERROR; wrongType: Tcl_SetObjResult(interp, Tcl_NewStringObj( "prefix argument list not available for this kind of method", - -1)); + TCL_AUTO_LENGTH)); Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "METHOD", TclGetString(objv[2]), (char *)NULL); return TCL_ERROR; } @@ -490,11 +490,11 @@ * Perform the check. Note that we can guarantee that we will not fail * from here on; "failures" result in a false-TCL_OK result. */ oPtr = (Object *) Tcl_GetObjectFromObj(interp, objv[2]); - if (oPtr == NULL) { + if (!oPtr) { goto failPrecondition; } switch (idx) { case IsObject: @@ -502,21 +502,21 @@ break; case IsClass: result = (oPtr->classPtr != NULL); break; case IsMetaclass: - if (oPtr->classPtr != NULL) { + if (oPtr->classPtr) { result = TclOOIsReachable(TclOOGetFoundation(interp)->classCls, oPtr->classPtr); } break; case IsMixin: o2Ptr = (Object *) Tcl_GetObjectFromObj(interp, objv[3]); - if (o2Ptr == NULL) { + if (!o2Ptr) { goto failPrecondition; } - if (o2Ptr->classPtr != NULL) { + if (o2Ptr->classPtr) { Class *mixinPtr; FOREACH(mixinPtr, oPtr->mixins) { if (!mixinPtr) { continue; @@ -528,14 +528,14 @@ } } break; case IsType: o2Ptr = (Object *) Tcl_GetObjectFromObj(interp, objv[3]); - if (o2Ptr == NULL) { + if (!o2Ptr) { goto failPrecondition; } - if (o2Ptr->classPtr != NULL) { + if (o2Ptr->classPtr) { result = TclOOIsReachable(o2Ptr->classPtr, oPtr->selfCls); } break; } Tcl_SetObjResult(interp, Tcl_NewBooleanObj(result)); @@ -562,15 +562,10 @@ TCL_UNUSED(void *), Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]) { - Object *oPtr; - int flag = PUBLIC_METHOD, recurse = 0, scope = -1; - FOREACH_HASH_DECLS; - Tcl_Obj *namePtr, *resultObj; - Method *mPtr; static const char *const options[] = { "-all", "-localprivate", "-private", "-scope", NULL }; enum Options { OPT_ALL, OPT_LOCALPRIVATE, OPT_PRIVATE, OPT_SCOPE @@ -578,12 +573,18 @@ static const char *const scopes[] = { "private", "public", "unexported" }; enum Scopes { SCOPE_PRIVATE, SCOPE_PUBLIC, SCOPE_UNEXPORTED, - SCOPE_LOCALPRIVATE + SCOPE_LOCALPRIVATE, + UNSCOPED = -1 // No scope given; legacy mode }; + Object *oPtr; + int flag = PUBLIC_METHOD, recurse = 0, scope = UNSCOPED; + FOREACH_HASH_DECLS; + Tcl_Obj *namePtr, *resultObj; + Method *mPtr; /* * Parse arguments. */ @@ -590,11 +591,11 @@ if (objc < 2) { Tcl_WrongNumArgs(interp, 1, objv, "objName ?-option value ...?"); return TCL_ERROR; } oPtr = (Object *) Tcl_GetObjectFromObj(interp, objv[1]); - if (oPtr == NULL) { + if (!oPtr) { return TCL_ERROR; } if (objc != 2) { int i; @@ -627,11 +628,11 @@ } break; } } } - if (scope != -1) { + if (scope != UNSCOPED) { recurse = 0; switch (scope) { case SCOPE_PRIVATE: flag = TRUE_PRIVATE_METHOD; break; @@ -657,17 +658,17 @@ int i, numNames = TclOOGetSortedMethodList(oPtr, NULL, NULL, flag, &names); for (i=0 ; i 0) { Tcl_Free((void *) names); } } else if (oPtr->methodsPtr) { - if (scope == -1) { + if (scope == UNSCOPED) { /* * Handle legacy-mode matching. [Bug 36e5517a6850] */ int scopeFilter = flag | TRUE_PRIVATE_METHOD; @@ -713,32 +714,32 @@ Tcl_WrongNumArgs(interp, 1, objv, "objName methodName"); return TCL_ERROR; } oPtr = (Object *) Tcl_GetObjectFromObj(interp, objv[1]); - if (oPtr == NULL) { + if (!oPtr) { return TCL_ERROR; } if (!oPtr->methodsPtr) { goto unknownMethod; } hPtr = Tcl_FindHashEntry(oPtr->methodsPtr, objv[2]); - if (hPtr == NULL) { + if (!hPtr) { goto unknownMethod; } mPtr = (Method *) Tcl_GetHashValue(hPtr); - if (mPtr->typePtr == NULL) { + if (!mPtr->typePtr) { /* * Special entry for visibility control: pretend the method doesnt * exist. */ goto unknownMethod; } - Tcl_SetObjResult(interp, Tcl_NewStringObj(mPtr->typePtr->name, -1)); + Tcl_SetObjResult(interp, Tcl_NewStringObj(mPtr->typePtr->name, TCL_AUTO_LENGTH)); return TCL_OK; unknownMethod: Tcl_SetObjResult(interp, Tcl_ObjPrintf( "unknown method \"%s\"", TclGetString(objv[2]))); @@ -772,11 +773,11 @@ if (objc != 2) { Tcl_WrongNumArgs(interp, 1, objv, "objName"); return TCL_ERROR; } oPtr = (Object *) Tcl_GetObjectFromObj(interp, objv[1]); - if (oPtr == NULL) { + if (!oPtr) { return TCL_ERROR; } TclNewObj(resultObj); FOREACH(mixinPtr, oPtr->mixins) { @@ -812,11 +813,11 @@ if (objc != 2) { Tcl_WrongNumArgs(interp, 1, objv, "objName"); return TCL_ERROR; } oPtr = (Object *) Tcl_GetObjectFromObj(interp, objv[1]); - if (oPtr == NULL) { + if (!oPtr) { return TCL_ERROR; } Tcl_SetObjResult(interp, Tcl_NewWideIntObj(oPtr->creationEpoch)); return TCL_OK; @@ -844,11 +845,11 @@ if (objc != 2) { Tcl_WrongNumArgs(interp, 1, objv, "objName"); return TCL_ERROR; } oPtr = (Object *) Tcl_GetObjectFromObj(interp, objv[1]); - if (oPtr == NULL) { + if (!oPtr) { return TCL_ERROR; } Tcl_SetObjResult(interp, TclNewNamespaceObj(oPtr->namespacePtr)); return TCL_OK; @@ -889,11 +890,11 @@ return TCL_ERROR; } isPrivate = 1; } oPtr = (Object *) Tcl_GetObjectFromObj(interp, objv[1]); - if (oPtr == NULL) { + if (!oPtr) { return TCL_ERROR; } TclNewObj(resultObj); if (isPrivate) { @@ -939,11 +940,11 @@ if (objc != 2 && objc != 3) { Tcl_WrongNumArgs(interp, 1, objv, "objName ?pattern?"); return TCL_ERROR; } oPtr = (Object *) Tcl_GetObjectFromObj(interp, objv[1]); - if (oPtr == NULL) { + if (!oPtr) { return TCL_ERROR; } if (objc == 3) { pattern = TclGetString(objv[2]); } @@ -961,12 +962,11 @@ if (TclIsVarUndefined(&vihPtr->var) || !TclIsVarNamespaceVar(&vihPtr->var)) { continue; } - if (pattern != NULL - && !Tcl_StringMatch(TclGetString(nameObj), pattern)) { + if (pattern && !Tcl_StringMatch(TclGetString(nameObj), pattern)) { continue; } Tcl_ListObjAppendElement(NULL, resultObj, nameObj); } @@ -999,20 +999,20 @@ if (objc != 2) { Tcl_WrongNumArgs(interp, 1, objv, "className"); return TCL_ERROR; } clsPtr = TclOOGetClassFromObj(interp, objv[1]); - if (clsPtr == NULL) { + if (!clsPtr) { return TCL_ERROR; } - if (clsPtr->constructorPtr == NULL) { + if (!clsPtr->constructorPtr) { return TCL_OK; } procPtr = TclOOGetProcFromMethod(clsPtr->constructorPtr); - if (procPtr == NULL) { + if (!procPtr) { Tcl_SetObjResult(interp, Tcl_NewStringObj( - "definition not available for this kind of method", -1)); + "definition not available for this kind of method", TCL_AUTO_LENGTH)); Tcl_SetErrorCode(interp, "TCL", "OO", "METHOD_TYPE", (char *)NULL); return TCL_ERROR; } TclNewObj(resultObjs[0]); @@ -1021,11 +1021,11 @@ if (TclIsVarArgument(localPtr)) { Tcl_Obj *argObj; TclNewObj(argObj); Tcl_ListObjAppendElement(NULL, argObj, LocalVarName(localPtr)); - if (localPtr->defValuePtr != NULL) { + if (localPtr->defValuePtr) { Tcl_ListObjAppendElement(NULL, argObj, localPtr->defValuePtr); } Tcl_ListObjAppendElement(NULL, resultObjs[0], argObj); } } @@ -1060,25 +1060,25 @@ if (objc != 3) { Tcl_WrongNumArgs(interp, 1, objv, "className methodName"); return TCL_ERROR; } clsPtr = TclOOGetClassFromObj(interp, objv[1]); - if (clsPtr == NULL) { + if (!clsPtr) { return TCL_ERROR; } hPtr = Tcl_FindHashEntry(&clsPtr->classMethods, objv[2]); - if (hPtr == NULL) { + if (!hPtr) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( "unknown method \"%s\"", TclGetString(objv[2]))); Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "METHOD", TclGetString(objv[2]), (char *)NULL); return TCL_ERROR; } procPtr = TclOOGetProcFromMethod((Method *) Tcl_GetHashValue(hPtr)); - if (procPtr == NULL) { + if (!procPtr) { Tcl_SetObjResult(interp, Tcl_NewStringObj( - "definition not available for this kind of method", -1)); + "definition not available for this kind of method", TCL_AUTO_LENGTH)); Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "METHOD", TclGetString(objv[2]), (char *)NULL); return TCL_ERROR; } @@ -1088,11 +1088,11 @@ if (TclIsVarArgument(localPtr)) { Tcl_Obj *argObj; TclNewObj(argObj); Tcl_ListObjAppendElement(NULL, argObj, LocalVarName(localPtr)); - if (localPtr->defValuePtr != NULL) { + if (localPtr->defValuePtr) { Tcl_ListObjAppendElement(NULL, argObj, localPtr->defValuePtr); } Tcl_ListObjAppendElement(NULL, resultObjs[0], argObj); } } @@ -1130,11 +1130,11 @@ if (objc != 2 && objc != 3) { Tcl_WrongNumArgs(interp, 1, objv, "className ?kind?"); return TCL_ERROR; } clsPtr = TclOOGetClassFromObj(interp, objv[1]); - if (clsPtr == NULL) { + if (!clsPtr) { return TCL_ERROR; } if (objc == 3 && Tcl_GetIndexFromObj(interp, objv[2], kindList, "kind", 0, &kind) != TCL_OK) { return TCL_ERROR; @@ -1174,21 +1174,21 @@ if (objc != 2) { Tcl_WrongNumArgs(interp, 1, objv, "className"); return TCL_ERROR; } clsPtr = TclOOGetClassFromObj(interp, objv[1]); - if (clsPtr == NULL) { + if (!clsPtr) { return TCL_ERROR; } - if (clsPtr->destructorPtr == NULL) { + if (!clsPtr->destructorPtr) { return TCL_OK; } procPtr = TclOOGetProcFromMethod(clsPtr->destructorPtr); - if (procPtr == NULL) { + if (!procPtr) { Tcl_SetObjResult(interp, Tcl_NewStringObj( - "definition not available for this kind of method", -1)); + "definition not available for this kind of method", TCL_AUTO_LENGTH)); Tcl_SetErrorCode(interp, "TCL", "OO", "METHOD_TYPE", (char *)NULL); return TCL_ERROR; } Tcl_SetObjResult(interp, TclOOGetMethodBody(clsPtr->destructorPtr)); @@ -1219,11 +1219,11 @@ if (objc != 2) { Tcl_WrongNumArgs(interp, 1, objv, "className"); return TCL_ERROR; } clsPtr = TclOOGetClassFromObj(interp, objv[1]); - if (clsPtr == NULL) { + if (!clsPtr) { return TCL_ERROR; } TclNewObj(resultObj); FOREACH(filterObj, clsPtr->filters) { @@ -1257,26 +1257,26 @@ if (objc != 3) { Tcl_WrongNumArgs(interp, 1, objv, "className methodName"); return TCL_ERROR; } clsPtr = TclOOGetClassFromObj(interp, objv[1]); - if (clsPtr == NULL) { + if (!clsPtr) { return TCL_ERROR; } hPtr = Tcl_FindHashEntry(&clsPtr->classMethods, objv[2]); - if (hPtr == NULL) { + if (!hPtr) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( "unknown method \"%s\"", TclGetString(objv[2]))); Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "METHOD", TclGetString(objv[2]), (char *)NULL); return TCL_ERROR; } prefixObj = TclOOGetFwdFromMethod((Method *) Tcl_GetHashValue(hPtr)); - if (prefixObj == NULL) { + if (!prefixObj) { Tcl_SetObjResult(interp, Tcl_NewStringObj( "prefix argument list not available for this kind of method", - -1)); + TCL_AUTO_LENGTH)); Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "METHOD", TclGetString(objv[2]), (char *)NULL); return TCL_ERROR; } @@ -1310,11 +1310,11 @@ if (objc != 2 && objc != 3) { Tcl_WrongNumArgs(interp, 1, objv, "className ?pattern?"); return TCL_ERROR; } clsPtr = TclOOGetClassFromObj(interp, objv[1]); - if (clsPtr == NULL) { + if (!clsPtr) { return TCL_ERROR; } if (objc == 3) { pattern = TclGetString(objv[2]); } @@ -1347,14 +1347,10 @@ TCL_UNUSED(void *), Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]) { - int flag = PUBLIC_METHOD, recurse = 0, scope = -1; - Tcl_Obj *namePtr, *resultObj; - Method *mPtr; - Class *clsPtr; static const char *const options[] = { "-all", "-localprivate", "-private", "-scope", NULL }; enum Options { OPT_ALL, OPT_LOCALPRIVATE, OPT_PRIVATE, OPT_SCOPE @@ -1361,19 +1357,24 @@ } idx; static const char *const scopes[] = { "private", "public", "unexported" }; enum Scopes { - SCOPE_PRIVATE, SCOPE_PUBLIC, SCOPE_UNEXPORTED + SCOPE_PRIVATE, SCOPE_PUBLIC, SCOPE_UNEXPORTED, + UNSCOPED = -1 // No scope given; legacy mode }; + int flag = PUBLIC_METHOD, recurse = 0, scope = UNSCOPED; + Tcl_Obj *namePtr, *resultObj; + Method *mPtr; + Class *clsPtr; if (objc < 2) { Tcl_WrongNumArgs(interp, 1, objv, "className ?-option value ...?"); return TCL_ERROR; } clsPtr = TclOOGetClassFromObj(interp, objv[1]); - if (clsPtr == NULL) { + if (!clsPtr) { return TCL_ERROR; } if (objc != 2) { int i; @@ -1406,11 +1407,11 @@ } break; } } } - if (scope != -1) { + if (scope != UNSCOPED) { recurse = 0; switch (scope) { case SCOPE_PRIVATE: flag = TRUE_PRIVATE_METHOD; break; @@ -1428,19 +1429,19 @@ const char **names; Tcl_Size i, numNames = TclOOGetSortedClassMethodList(clsPtr, flag, &names); for (i=0 ; i 0) { Tcl_Free((void *) names); } } else { FOREACH_HASH_DECLS; - if (scope == -1) { + if (scope == UNSCOPED) { /* * Handle legacy-mode matching. [Bug 36e5517a6850] */ int scopeFilter = flag | TRUE_PRIVATE_METHOD; @@ -1485,28 +1486,28 @@ if (objc != 3) { Tcl_WrongNumArgs(interp, 1, objv, "className methodName"); return TCL_ERROR; } clsPtr = TclOOGetClassFromObj(interp, objv[1]); - if (clsPtr == NULL) { + if (!clsPtr) { return TCL_ERROR; } hPtr = Tcl_FindHashEntry(&clsPtr->classMethods, objv[2]); - if (hPtr == NULL) { + if (!hPtr) { goto unknownMethod; } mPtr = (Method *) Tcl_GetHashValue(hPtr); - if (mPtr->typePtr == NULL) { + if (!mPtr->typePtr) { /* * Special entry for visibility control: pretend the method doesnt * exist. */ goto unknownMethod; } - Tcl_SetObjResult(interp, Tcl_NewStringObj(mPtr->typePtr->name, -1)); + Tcl_SetObjResult(interp, Tcl_NewStringObj(mPtr->typePtr->name, TCL_AUTO_LENGTH)); return TCL_OK; unknownMethod: Tcl_SetObjResult(interp, Tcl_ObjPrintf( "unknown method \"%s\"", TclGetString(objv[2]))); @@ -1539,11 +1540,11 @@ if (objc != 2) { Tcl_WrongNumArgs(interp, 1, objv, "className"); return TCL_ERROR; } clsPtr = TclOOGetClassFromObj(interp, objv[1]); - if (clsPtr == NULL) { + if (!clsPtr) { return TCL_ERROR; } TclNewObj(resultObj); FOREACH(mixinPtr, clsPtr->mixins) { @@ -1582,11 +1583,11 @@ if (objc != 2 && objc != 3) { Tcl_WrongNumArgs(interp, 1, objv, "className ?pattern?"); return TCL_ERROR; } clsPtr = TclOOGetClassFromObj(interp, objv[1]); - if (clsPtr == NULL) { + if (!clsPtr) { return TCL_ERROR; } if (objc == 3) { pattern = TclGetString(objv[2]); } @@ -1636,11 +1637,11 @@ if (objc != 2) { Tcl_WrongNumArgs(interp, 1, objv, "className"); return TCL_ERROR; } clsPtr = TclOOGetClassFromObj(interp, objv[1]); - if (clsPtr == NULL) { + if (!clsPtr) { return TCL_ERROR; } TclNewObj(resultObj); FOREACH(superPtr, clsPtr->superclasses) { @@ -1686,11 +1687,11 @@ return TCL_ERROR; } isPrivate = 1; } clsPtr = TclOOGetClassFromObj(interp, objv[1]); - if (clsPtr == NULL) { + if (!clsPtr) { return TCL_ERROR; } TclNewObj(resultObj); if (isPrivate) { @@ -1733,23 +1734,23 @@ if (objc != 3) { Tcl_WrongNumArgs(interp, 1, objv, "objName methodName"); return TCL_ERROR; } oPtr = (Object *) Tcl_GetObjectFromObj(interp, objv[1]); - if (oPtr == NULL) { + if (!oPtr) { return TCL_ERROR; } /* * Get the call context and render its call chain. */ contextPtr = TclOOGetCallContext(oPtr, objv[2], PUBLIC_METHOD, NULL, NULL, NULL); - if (contextPtr == NULL) { + if (!contextPtr) { Tcl_SetObjResult(interp, Tcl_NewStringObj( - "cannot construct any call chain", -1)); + "cannot construct any call chain", TCL_AUTO_LENGTH)); Tcl_SetErrorCode(interp, "TCL", "OO", "BAD_CALL_CHAIN"); return TCL_ERROR; } Tcl_SetObjResult(interp, TclOORenderCallChain(interp, contextPtr->callPtr)); @@ -1780,22 +1781,22 @@ if (objc != 3) { Tcl_WrongNumArgs(interp, 1, objv, "className methodName"); return TCL_ERROR; } clsPtr = TclOOGetClassFromObj(interp, objv[1]); - if (clsPtr == NULL) { + if (!clsPtr) { return TCL_ERROR; } /* * Get an render the stereotypical call chain. */ callPtr = TclOOGetStereotypeCallChain(clsPtr, objv[2], PUBLIC_METHOD); - if (callPtr == NULL) { + if (!callPtr) { Tcl_SetObjResult(interp, Tcl_NewStringObj( - "cannot construct any call chain", -1)); + "cannot construct any call chain", TCL_AUTO_LENGTH)); Tcl_SetErrorCode(interp, "TCL", "OO", "BAD_CALL_CHAIN"); return TCL_ERROR; } Tcl_SetObjResult(interp, TclOORenderCallChain(interp, callPtr)); TclOODeleteChain(callPtr); Index: generic/tclOOInt.h ================================================================== --- generic/tclOOInt.h +++ generic/tclOOInt.h @@ -405,10 +405,17 @@ * "" pseudo-constructor. */ Tcl_Obj *defineName; /* Fully qualified name of oo::define. */ Tcl_Obj *myName; /* The "my" shared object. */ }; +/* + * Convenience macro for getting the foundation from an interpreter. + */ + +#define GetFoundation(interp) \ + ((Foundation *)((Interp *)(interp))->objectFoundation) + /* * The number of MInvoke records in the CallChain before we allocate * separately. */ #define CALL_CHAIN_STATIC_SIZE 4 Index: generic/tclOOMethod.c ================================================================== --- generic/tclOOMethod.c +++ generic/tclOOMethod.c @@ -143,11 +143,11 @@ Object *oPtr = (Object *) object; Method *mPtr; Tcl_HashEntry *hPtr; int isNew; - if (nameObj == NULL) { + if (!nameObj) { mPtr = (Method *) Tcl_Alloc(sizeof(Method)); mPtr->namePtr = NULL; mPtr->refCount = 1; goto populate; } @@ -163,11 +163,11 @@ mPtr->refCount = 1; Tcl_IncrRefCount(nameObj); Tcl_SetHashValue(hPtr, mPtr); } else { mPtr = (Method *) Tcl_GetHashValue(hPtr); - if (mPtr->typePtr != NULL && mPtr->typePtr->deleteProc != NULL) { + if (mPtr->typePtr && mPtr->typePtr->deleteProc) { mPtr->typePtr->deleteProc(mPtr->clientData); } } populate: @@ -260,11 +260,11 @@ Class *clsPtr = (Class *) cls; Method *mPtr; Tcl_HashEntry *hPtr; int isNew; - if (nameObj == NULL) { + if (!nameObj) { mPtr = (Method *) Tcl_Alloc(sizeof(Method)); mPtr->namePtr = NULL; mPtr->refCount = 1; goto populate; } @@ -275,11 +275,11 @@ mPtr->namePtr = nameObj; Tcl_IncrRefCount(nameObj); Tcl_SetHashValue(hPtr, mPtr); } else { mPtr = (Method *) Tcl_GetHashValue(hPtr); - if (mPtr->typePtr != NULL && mPtr->typePtr->deleteProc != NULL) { + if (mPtr->typePtr && mPtr->typePtr->deleteProc) { mPtr->typePtr->deleteProc(mPtr->clientData); } } populate: @@ -357,15 +357,15 @@ void TclOODelMethodRef( Method *mPtr) { - if ((mPtr != NULL) && (mPtr->refCount-- <= 1)) { - if (mPtr->typePtr != NULL && mPtr->typePtr->deleteProc != NULL) { + if (mPtr && (mPtr->refCount-- <= 1)) { + if (mPtr->typePtr && mPtr->typePtr->deleteProc) { mPtr->typePtr->deleteProc(mPtr->clientData); } - if (mPtr->namePtr != NULL) { + if (mPtr->namePtr) { Tcl_DecrRefCount(mPtr->namePtr); } Tcl_Free(mPtr); } @@ -387,11 +387,11 @@ Class *clsPtr, /* Class to attach the method to. */ const DeclaredClassMethod *dcm) /* Name of the method, whether it is public, * and the function to implement it. */ { - Tcl_Obj *namePtr = Tcl_NewStringObj(dcm->name, -1); + Tcl_Obj *namePtr = Tcl_NewStringObj(dcm->name, TCL_AUTO_LENGTH); TclNewMethod((Tcl_Class) clsPtr, namePtr, (dcm->isPublic ? PUBLIC_METHOD : 0), &dcm->definition, NULL); Tcl_BounceRefCount(namePtr); } @@ -430,13 +430,13 @@ return NULL; } pmPtr = AllocProcedureMethodRecord(flags); method = TclOOMakeProcInstanceMethod(interp, oPtr, flags, nameObj, argsObj, bodyObj, &procMethodType, pmPtr, &pmPtr->procPtr); - if (method == NULL) { + if (!method) { Tcl_Free(pmPtr); - } else if (pmPtrPtr != NULL) { + } else if (pmPtrPtr) { *pmPtrPtr = pmPtr; } return (Method *) method; } @@ -472,11 +472,11 @@ Tcl_Size argsLen; /* TCL_INDEX_NONE => delete argsObj before exit */ ProcedureMethod *pmPtr; const char *procName; Tcl_Method method; - if (argsObj == NULL) { + if (!argsObj) { argsLen = TCL_INDEX_NONE; TclNewObj(argsObj); Tcl_IncrRefCount(argsObj); procName = ""; } else if (TclListObjLength(interp, argsObj, &argsLen) != TCL_OK) { @@ -490,13 +490,13 @@ argsObj, bodyObj, &procMethodType, pmPtr, &pmPtr->procPtr); if (argsLen == TCL_INDEX_NONE) { Tcl_DecrRefCount(argsObj); } - if (method == NULL) { + if (!method) { Tcl_Free(pmPtr); - } else if (pmPtrPtr != NULL) { + } else if (pmPtrPtr) { *pmPtrPtr = pmPtr; } return (Method *) method; } @@ -733,16 +733,16 @@ pmPtr->efi.fields[0].clientData = pmPtr; pmPtr->callSiteFlags = ((CallContext *) context)->callPtr->flags & (CONSTRUCTOR | DESTRUCTOR); pmPtr->interp = interp; pmPtr->method = method; - if (pmPtr->gfivProc != NULL) { + if (pmPtr->gfivProc) { pmPtr->efi.fields[1].name = ""; pmPtr->efi.fields[1].proc = pmPtr->gfivProc; pmPtr->efi.fields[1].clientData = pmPtr; } else { - if (Tcl_MethodDeclarerObject(method) != NULL) { + if (Tcl_MethodDeclarerObject(method)) { pmPtr->efi.fields[1].name = "object"; } else { pmPtr->efi.fields[1].name = "class"; } pmPtr->efi.fields[1].proc = RenderDeclarerName; @@ -771,11 +771,11 @@ /* * Give the pre-call callback a chance to do some setup and, possibly, * veto the call. */ - if (pmPtr->preCallProc != NULL) { + if (pmPtr->preCallProc) { int isFinished; result = pmPtr->preCallProc(pmPtr->clientData, interp, context, (Tcl_CallFrame *) fdPtr->framePtr, &isFinished); if (isFinished || result != TCL_OK) { @@ -842,30 +842,31 @@ Tcl_Obj *const *objv, /* Array of arguments. */ PMFrameData *fdPtr) /* Place to store information about the call * frame. */ { Namespace *nsPtr = (Namespace *) contextPtr->oPtr->namespacePtr; + Foundation *fPtr = GetFoundation(interp); int result; CallFrame **framePtrPtr = &fdPtr->framePtr; ByteCode *codePtr; /* * Compute basic information on the basis of the type of method it is. */ if (contextPtr->callPtr->flags & CONSTRUCTOR) { - fdPtr->nameObj = contextPtr->oPtr->fPtr->constructorName; + fdPtr->nameObj = fPtr->constructorName; fdPtr->errProc = ConstructorErrorHandler; } else if (contextPtr->callPtr->flags & DESTRUCTOR) { - fdPtr->nameObj = contextPtr->oPtr->fPtr->destructorName; + fdPtr->nameObj = fPtr->destructorName; fdPtr->errProc = DestructorErrorHandler; } else { fdPtr->nameObj = Tcl_MethodName( Tcl_ObjectContextMethod((Tcl_ObjectContext) contextPtr)); fdPtr->errProc = MethodErrorHandler; } - if (pmPtr->errProc != NULL) { + if (pmPtr->errProc) { fdPtr->errProc = pmPtr->errProc; } /* * Magic to enable things like [incr Tcl], which wants methods to run in @@ -873,11 +874,11 @@ */ if (pmPtr->flags & USE_DECLARER_NS) { Method *mPtr = contextPtr->callPtr->chain[contextPtr->index].mPtr; - if (mPtr->declaringClassPtr != NULL) { + if (mPtr->declaringClassPtr) { nsPtr = (Namespace *) mPtr->declaringClassPtr->thisPtr->namespacePtr; } else { nsPtr = (Namespace *) mPtr->declaringObjectPtr->namespacePtr; } @@ -939,11 +940,11 @@ Tcl_Namespace *nsPtr) { Tcl_ResolverInfo info; Tcl_GetNamespaceResolvers(nsPtr, &info); - if (info.compiledVarResProc == NULL) { + if (!info.compiledVarResProc) { Tcl_SetNamespaceResolvers(nsPtr, NULL, ProcedureMethodVarResolver, ProcedureMethodCompiledVarResolver); } } @@ -995,11 +996,11 @@ * Check that the variable is being requested in a context that is also a * method call; if not (i.e. we're evaluating in the object's namespace or * in a procedure of that namespace) then we do nothing. */ - if (framePtr == NULL || !(framePtr->isProcCallFrame & FRAME_IS_METHOD)) { + if (!framePtr || !(framePtr->isProcCallFrame & FRAME_IS_METHOD)) { return NULL; } contextPtr = (CallContext *) framePtr->clientData; /* @@ -1016,12 +1017,11 @@ * is in the list provided by the user). If not, we mustn't do anything * either. */ varName = Tcl_GetStringFromObj(infoPtr->variableObj, &varLen); - if (contextPtr->callPtr->chain[contextPtr->index] - .mPtr->declaringClassPtr != NULL) { + if (contextPtr->callPtr->chain[contextPtr->index].mPtr->declaringClassPtr) { FOREACH_STRUCT(privateVar, contextPtr->callPtr->chain[contextPtr->index] .mPtr->declaringClassPtr->privateVariables) { match = Tcl_GetStringFromObj(privateVar->variableObj, &len); if ((len == varLen) && !memcmp(match, varName, len)) { variableObj = privateVar->fullNameObj; @@ -1112,11 +1112,11 @@ /* * Do not create resolvers for cases that contain namespace separators or * which look like array accesses. Both will lead us astray. */ - if (strstr(TclGetString(variableObj), "::") != NULL || + if (strstr(TclGetString(variableObj), "::") || Tcl_StringMatch(TclGetString(variableObj), "*(*)")) { Tcl_DecrRefCount(variableObj); return TCL_CONTINUE; } @@ -1174,11 +1174,11 @@ void *clientData) { ProcedureMethod *pmPtr = (ProcedureMethod *) clientData; Tcl_Object object = Tcl_MethodDeclarerObject(pmPtr->method); - if (object == NULL) { + if (!object) { object = Tcl_GetClassAsObject(Tcl_MethodDeclarerClass(pmPtr->method)); } return TclOOObjectName(pmPtr->interp, (Object *) object); } @@ -1215,15 +1215,15 @@ Method *mPtr = contextPtr->callPtr->chain[contextPtr->index].mPtr; const char *objectName, *kindName, *methodName = Tcl_GetStringFromObj(mPtr->namePtr, &nameLen); Object *declarerPtr; - if (mPtr->declaringObjectPtr != NULL) { + if (mPtr->declaringObjectPtr) { declarerPtr = mPtr->declaringObjectPtr; kindName = "object"; } else { - if (mPtr->declaringClassPtr == NULL) { + if (!mPtr->declaringClassPtr) { Tcl_Panic("method not declared in class or object"); } declarerPtr = mPtr->declaringClassPtr->thisPtr; kindName = "class"; } @@ -1247,15 +1247,15 @@ Method *mPtr = contextPtr->callPtr->chain[contextPtr->index].mPtr; Object *declarerPtr; const char *objectName, *kindName; Tcl_Size objectNameLen; - if (mPtr->declaringObjectPtr != NULL) { + if (mPtr->declaringObjectPtr) { declarerPtr = mPtr->declaringObjectPtr; kindName = "object"; } else { - if (mPtr->declaringClassPtr == NULL) { + if (!mPtr->declaringClassPtr) { Tcl_Panic("method not declared in class or object"); } declarerPtr = mPtr->declaringClassPtr->thisPtr; kindName = "class"; } @@ -1278,15 +1278,15 @@ Method *mPtr = contextPtr->callPtr->chain[contextPtr->index].mPtr; Object *declarerPtr; const char *objectName, *kindName; Tcl_Size objectNameLen; - if (mPtr->declaringObjectPtr != NULL) { + if (mPtr->declaringObjectPtr) { declarerPtr = mPtr->declaringObjectPtr; kindName = "object"; } else { - if (mPtr->declaringClassPtr == NULL) { + if (!mPtr->declaringClassPtr) { Tcl_Panic("method not declared in class or object"); } declarerPtr = mPtr->declaringClassPtr->thisPtr; kindName = "class"; } @@ -1351,12 +1351,12 @@ if (TclIsVarArgument(localPtr)) { Tcl_Obj *argObj; TclNewObj(argObj); Tcl_ListObjAppendElement(NULL, argObj, - Tcl_NewStringObj(localPtr->name, -1)); - if (localPtr->defValuePtr != NULL) { + Tcl_NewStringObj(localPtr->name, TCL_AUTO_LENGTH)); + if (localPtr->defValuePtr) { Tcl_ListObjAppendElement(NULL, argObj, localPtr->defValuePtr); } Tcl_ListObjAppendElement(NULL, argsObj, argObj); } } @@ -1424,11 +1424,11 @@ if (TclListObjLength(interp, prefixObj, &prefixLen) != TCL_OK) { return NULL; } if (prefixLen < 1) { Tcl_SetObjResult(interp, Tcl_NewStringObj( - "method forward prefix must be non-empty", -1)); + "method forward prefix must be non-empty", TCL_AUTO_LENGTH)); Tcl_SetErrorCode(interp, "TCL", "OO", "BAD_FORWARD", (char *)NULL); return NULL; } fmPtr = (ForwardMethod *) Tcl_Alloc(sizeof(ForwardMethod)); @@ -1463,11 +1463,11 @@ if (TclListObjLength(interp, prefixObj, &prefixLen) != TCL_OK) { return NULL; } if (prefixLen < 1) { Tcl_SetObjResult(interp, Tcl_NewStringObj( - "method forward prefix must be non-empty", -1)); + "method forward prefix must be non-empty", TCL_AUTO_LENGTH)); Tcl_SetErrorCode(interp, "TCL", "OO", "BAD_FORWARD", (char *)NULL); return NULL; } fmPtr = (ForwardMethod *) Tcl_Alloc(sizeof(ForwardMethod)); @@ -1712,11 +1712,11 @@ void **clientDataPtr) { Method *mPtr = (Method *) method; if (mPtr->typePtr == typePtr) { - if (clientDataPtr != NULL) { + if (clientDataPtr) { *clientDataPtr = mPtr->clientData; } return 1; } return 0; @@ -1733,11 +1733,11 @@ if (typePtr->version > TCL_OO_METHOD_VERSION_1) { Tcl_Panic("%s: Wrong version in typePtr->version, should be %s", "Tcl_MethodIsType", "TCL_OO_METHOD_VERSION_1"); } if (mPtr->typePtr == typePtr) { - if (clientDataPtr != NULL) { + if (clientDataPtr) { *clientDataPtr = mPtr->clientData; } return 1; } return 0; @@ -1754,11 +1754,11 @@ if (typePtr->version < TCL_OO_METHOD_VERSION_2) { Tcl_Panic("%s: Wrong version in typePtr->version, should be %s", "Tcl_MethodIsType2", "TCL_OO_METHOD_VERSION_2"); } if (mPtr->typePtr == (const Tcl_MethodType *) typePtr) { - if (clientDataPtr != NULL) { + if (clientDataPtr) { *clientDataPtr = mPtr->clientData; } return 1; } return 0; @@ -1803,19 +1803,19 @@ { ProcedureMethod *pmPtr; Tcl_Method method = (Tcl_Method) TclOONewProcInstanceMethod(interp, (Object *) oPtr, flags, nameObj, argsObj, bodyObj, &pmPtr); - if (method == NULL) { + if (!method) { return NULL; } pmPtr->flags = flags & USE_DECLARER_NS; pmPtr->preCallProc = preCallPtr; pmPtr->postCallProc = postCallPtr; pmPtr->errProc = errProc; pmPtr->clientData = clientData; - if (internalTokenPtr != NULL) { + if (internalTokenPtr) { *internalTokenPtr = pmPtr; } return method; } @@ -1843,19 +1843,19 @@ { ProcedureMethod *pmPtr; Tcl_Method method = (Tcl_Method) TclOONewProcMethod(interp, (Class *) clsPtr, flags, nameObj, argsObj, bodyObj, &pmPtr); - if (method == NULL) { + if (!method) { return NULL; } pmPtr->flags = flags & USE_DECLARER_NS; pmPtr->preCallProc = preCallPtr; pmPtr->postCallProc = postCallPtr; pmPtr->errProc = errProc; pmPtr->clientData = clientData; - if (internalTokenPtr != NULL) { + if (internalTokenPtr) { *internalTokenPtr = pmPtr; } return method; } Index: generic/tclOOProp.c ================================================================== --- generic/tclOOProp.c +++ generic/tclOOProp.c @@ -92,14 +92,16 @@ */ static inline int ReadProperty( Tcl_Interp *interp, Object *oPtr, - const char *propName) + Tcl_Obj *propNameObj) { + const char *propName = TclGetString(propNameObj); + Foundation *fPtr = GetFoundation(interp); Tcl_Obj *args[] = { - oPtr->fPtr->myName, + fPtr->myName, Tcl_ObjPrintf("", propName) }; int code; Tcl_IncrRefCount(args[0]); @@ -123,15 +125,17 @@ static inline int WriteProperty( Tcl_Interp *interp, Object *oPtr, - const char *propName, + Tcl_Obj *propNameObj, Tcl_Obj *valueObj) { + const char *propName = TclGetString(propNameObj); + Foundation *fPtr = GetFoundation(interp); Tcl_Obj *args[] = { - oPtr->fPtr->myName, + fPtr->myName, Tcl_ObjPrintf("", propName), valueObj }; int code; @@ -168,12 +172,11 @@ GPNCache **cachePtr) /* Where to cache the table, if the caller * wants that. The contents are to be freed * with Tcl_Free if the cache is used. */ { Tcl_Size objc, index, i; - Tcl_Obj *listPtr = TclOOGetAllObjectProperties( - oPtr, flags & GPN_WRITABLE); + Tcl_Obj *listPtr = TclOOGetAllObjectProperties(oPtr, flags & GPN_WRITABLE); Tcl_Obj **objv; GPNCache *tablePtr; (void) Tcl_ListObjGetElements(NULL, listPtr, &objc, &objv); if (cachePtr && *cachePtr) { @@ -213,11 +216,11 @@ Tcl_InterpState foo = Tcl_SaveInterpState(interp, result); Tcl_Obj *otherName = GetPropertyName(interp, oPtr, flags ^ (GPN_WRITABLE | GPN_FALLING_BACK), namePtr, NULL); result = Tcl_RestoreInterpState(interp, foo); - if (otherName != NULL) { + if (otherName) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( "property \"%s\" is %s only", TclGetString(otherName), (flags & GPN_WRITABLE) ? "read" : "write")); } @@ -283,11 +286,11 @@ Tcl_IncrRefCount(listPtr); ListObjGetElements(listPtr, namec, namev); for (i = 0; i < namec; ) { - code = ReadProperty(interp, oPtr, TclGetString(namev[i])); + code = ReadProperty(interp, oPtr, namev[i]); if (code != TCL_OK) { Tcl_DecrRefCount(resultPtr); break; } Tcl_DictObjPut(NULL, resultPtr, namev[i], @@ -304,27 +307,27 @@ /* * Read a single named property. */ namePtr = GetPropertyName(interp, oPtr, 0, objv[0], NULL); - if (namePtr == NULL) { + if (!namePtr) { return TCL_ERROR; } - return ReadProperty(interp, oPtr, TclGetString(namePtr)); + return ReadProperty(interp, oPtr, namePtr); } else if (objc == 2) { /* * Special case for writing to one property. Saves fiddling with the * cache in this common case. */ namePtr = GetPropertyName(interp, oPtr, GPN_WRITABLE, objv[0], NULL); - if (namePtr == NULL) { + if (!namePtr) { return TCL_ERROR; } - code = WriteProperty(interp, oPtr, TclGetString(namePtr), objv[1]); + code = WriteProperty(interp, oPtr, namePtr, objv[1]); if (code == TCL_OK) { - Tcl_ResetResult(interp); + Tcl_SetObjResult(interp, ((Interp *) interp)->emptyObjPtr); } return code; } else { /* * Write properties. Slightly tricky because we want to cache the @@ -334,22 +337,21 @@ code = TCL_OK; for (i = 0; i < objc; i += 2) { namePtr = GetPropertyName(interp, oPtr, GPN_WRITABLE, objv[i], &cache); - if (namePtr == NULL) { + if (!namePtr) { code = TCL_ERROR; break; } - code = WriteProperty(interp, oPtr, TclGetString(namePtr), - objv[i + 1]); + code = WriteProperty(interp, oPtr, namePtr, objv[i + 1]); if (code != TCL_OK) { break; } } if (code == TCL_OK) { - Tcl_ResetResult(interp); + Tcl_SetObjResult(interp, ((Interp *) interp)->emptyObjPtr); } ReleasePropertyNameCache(interp, &cache); return code; } } @@ -386,17 +388,17 @@ return TCL_ERROR; } varPtr = TclOOLookupObjectVar(interp, Tcl_ObjectContextObject(context), propNamePtr, &aryVar); - if (varPtr == NULL) { + if (!varPtr) { return TCL_ERROR; } valuePtr = TclPtrGetVar(interp, varPtr, aryVar, propNamePtr, NULL, TCL_NAMESPACE_ONLY | TCL_LEAVE_ERR_MSG); - if (valuePtr == NULL) { + if (!valuePtr) { return TCL_ERROR; } Tcl_SetObjResult(interp, valuePtr); return TCL_OK; } @@ -421,16 +423,16 @@ return TCL_ERROR; } varPtr = TclOOLookupObjectVar(interp, Tcl_ObjectContextObject(context), propNamePtr, &aryVar); - if (varPtr == NULL) { + if (!varPtr) { return TCL_ERROR; } - if (TclPtrSetVar(interp, varPtr, aryVar, propNamePtr, NULL, - objv[objc - 1], TCL_NAMESPACE_ONLY | TCL_LEAVE_ERR_MSG) == NULL) { + if (!TclPtrSetVar(interp, varPtr, aryVar, propNamePtr, NULL, + objv[objc - 1], TCL_NAMESPACE_ONLY | TCL_LEAVE_ERR_MSG)) { return TCL_ERROR; } return TCL_OK; } @@ -632,20 +634,23 @@ * instead. */ int *allocated) /* Address of variable to set to true if a * Tcl_Obj was allocated and may be safely * modified by the caller. */ { - Tcl_HashTable hashTable; + Tcl_HashTable hashTable; /* Set of property names built by calling + * FindClassProps(). Strictly, the keys are + * the set and the values are ignored. */ + Foundation *fPtr = clsPtr->thisPtr->fPtr; FOREACH_HASH_DECLS; Tcl_Obj *propName, *result; void *dummy; /* * Look in the cache. */ - if (clsPtr->properties.epoch == clsPtr->thisPtr->fPtr->epoch) { + if (clsPtr->properties.epoch == fPtr->epoch) { if (writable) { if (clsPtr->properties.allWritableCache) { *allocated = 0; return clsPtr->properties.allWritableCache; } @@ -672,21 +677,21 @@ /* * Cache the information. Also purges the cache. */ - if (clsPtr->properties.epoch != clsPtr->thisPtr->fPtr->epoch) { + if (clsPtr->properties.epoch != fPtr->epoch) { if (clsPtr->properties.allWritableCache) { Tcl_DecrRefCount(clsPtr->properties.allWritableCache); clsPtr->properties.allWritableCache = NULL; } if (clsPtr->properties.allReadableCache) { Tcl_DecrRefCount(clsPtr->properties.allReadableCache); clsPtr->properties.allReadableCache = NULL; } } - clsPtr->properties.epoch = clsPtr->thisPtr->fPtr->epoch; + clsPtr->properties.epoch = fPtr->epoch; if (writable) { clsPtr->properties.allWritableCache = result; } else { clsPtr->properties.allReadableCache = result; } @@ -734,11 +739,11 @@ /* * ---------------------------------------------------------------------- * * TclOOGetAllObjectProperties -- * - * Get the sorted list of all properties known to a object, including to its + * Get the sorted list of all properties known to a object, including to * its classes. Manages a cache so this operation is usually cheap. * * ---------------------------------------------------------------------- */ @@ -747,20 +752,23 @@ Object *oPtr, /* The object to inspect. Must exist. */ int writable) /* Whether to get writable properties. If * false, readable properties will be returned * instead. */ { - Tcl_HashTable hashTable; + Tcl_HashTable hashTable; /* Set of property names built by calling + * FindObjectProps(). Strictly, the keys are + * the set and the values are ignored. */ + Foundation *fPtr = oPtr->fPtr; FOREACH_HASH_DECLS; Tcl_Obj *propName, *result; void *dummy; /* * Look in the cache. */ - if (oPtr->properties.epoch == oPtr->fPtr->epoch) { + if (oPtr->properties.epoch == fPtr->epoch) { if (writable) { if (oPtr->properties.allWritableCache) { return oPtr->properties.allWritableCache; } } else { @@ -785,21 +793,21 @@ /* * Cache the information. */ - if (oPtr->properties.epoch != oPtr->fPtr->epoch) { + if (oPtr->properties.epoch != fPtr->epoch) { if (oPtr->properties.allWritableCache) { Tcl_DecrRefCount(oPtr->properties.allWritableCache); oPtr->properties.allWritableCache = NULL; } if (oPtr->properties.allReadableCache) { Tcl_DecrRefCount(oPtr->properties.allReadableCache); oPtr->properties.allReadableCache = NULL; } } - oPtr->properties.epoch = oPtr->fPtr->epoch; + oPtr->properties.epoch = fPtr->epoch; if (writable) { oPtr->properties.allWritableCache = result; } else { oPtr->properties.allReadableCache = result; } @@ -1046,16 +1054,16 @@ enum Kinds { KIND_RO, KIND_RW, KIND_WO }; Object *oPtr = (Object *) TclOOGetDefineCmdContext(interp); - if (oPtr == NULL) { + if (!oPtr) { return TCL_ERROR; } if (!useInstance && !oPtr->classPtr) { Tcl_SetObjResult(interp, Tcl_NewStringObj( - "attempt to misuse API", -1)); + "attempt to misuse API", TCL_AUTO_LENGTH)); Tcl_SetErrorCode(interp, "TCL", "OO", "MONKEY_BUSINESS", (char *)NULL); return TCL_ERROR; } for (i = 1; i < objc; i++) { @@ -1108,12 +1116,12 @@ * Install the property. Note that TclOOInstallStdPropertyImpls * validates the property name as well. */ if (TclOOInstallStdPropertyImpls(useInstance, interp, propObj, - kind != KIND_WO && getterScript == NULL, - kind != KIND_RO && setterScript == NULL) != TCL_OK) { + kind != KIND_WO && !getterScript, + kind != KIND_RO && !setterScript) != TCL_OK) { return TCL_ERROR; } hyphenated = Tcl_ObjPrintf("-%s", TclGetString(propObj)); if (useInstance) { @@ -1129,11 +1137,11 @@ * Create property implementation methods by using the right * back-end API, but only if the user has given us the bodies of the * methods we'll make. */ - if (getterScript != NULL) { + if (getterScript) { Tcl_Obj *getterName = Tcl_ObjPrintf("", TclGetString(propObj)); Tcl_Obj *argsPtr = Tcl_NewObj(); Method *mPtr; @@ -1146,15 +1154,15 @@ getterName, argsPtr, getterScript, NULL); } Tcl_BounceRefCount(getterName); Tcl_BounceRefCount(argsPtr); Tcl_DecrRefCount(getterScript); - if (mPtr == NULL) { + if (!mPtr) { return TCL_ERROR; } } - if (setterScript != NULL) { + if (setterScript) { Tcl_Obj *setterName = Tcl_ObjPrintf("", TclGetString(propObj)); Tcl_Obj *argsPtr; Method *mPtr; @@ -1168,11 +1176,11 @@ setterName, argsPtr, setterScript, NULL); } Tcl_BounceRefCount(setterName); Tcl_BounceRefCount(argsPtr); Tcl_DecrRefCount(setterScript); - if (mPtr == NULL) { + if (!mPtr) { return TCL_ERROR; } } } return TCL_OK; @@ -1203,11 +1211,11 @@ if (objc < 2) { Tcl_WrongNumArgs(interp, 1, objv, "className ?options...?"); return TCL_ERROR; } clsPtr = TclOOGetClassFromObj(interp, objv[1]); - if (clsPtr == NULL) { + if (!clsPtr) { return TCL_ERROR; } for (i = 2; i < objc; i++) { if (Tcl_GetIndexFromObj(interp, objv[i], propOptNames, "option", 0, &idx) != TCL_OK) { @@ -1261,11 +1269,11 @@ if (objc < 2) { Tcl_WrongNumArgs(interp, 1, objv, "objName ?options...?"); return TCL_ERROR; } oPtr = (Object *) Tcl_GetObjectFromObj(interp, objv[1]); - if (oPtr == NULL) { + if (!oPtr) { return TCL_ERROR; } for (i = 2; i < objc; i++) { if (Tcl_GetIndexFromObj(interp, objv[i], propOptNames, "option", 0, &idx) != TCL_OK) { Index: generic/tclProc.c ================================================================== --- generic/tclProc.c +++ generic/tclProc.c @@ -203,13 +203,13 @@ * Create the data structure to represent the procedure. */ if (TclCreateProc(interp, /*ignored nsPtr*/ NULL, simpleName, objv[2], objv[3], &procPtr) != TCL_OK) { - Tcl_AddErrorInfo(interp, "\n (creating proc \""); - Tcl_AddErrorInfo(interp, simpleName); - Tcl_AddErrorInfo(interp, "\")"); + Tcl_AppendObjToErrorInfo(interp, Tcl_ObjPrintf( + "\n (creating proc \"%s\")", + simpleName)); return TCL_ERROR; } cmd = TclNRCreateCommandInNs(interp, simpleName, (Tcl_Namespace *) nsPtr, TclObjInterpProc, NRInterpProc, procPtr, TclProcDeleteProc); Index: generic/tclZlib.c ================================================================== --- generic/tclZlib.c +++ generic/tclZlib.c @@ -2570,13 +2570,12 @@ } Tcl_SetObjResult(interp, objv[3]); return TCL_OK; genericOptionError: - Tcl_AddErrorInfo(interp, "\n (in "); - Tcl_AddErrorInfo(interp, pushOptions[option]); - Tcl_AddErrorInfo(interp, " option)"); + Tcl_AppendObjToErrorInfo(interp, Tcl_ObjPrintf( + "\n (in %s option)", pushOptions[option])); return TCL_ERROR; } /* *---------------------------------------------------------------------- Index: tests/ooProp.test ================================================================== --- tests/ooProp.test +++ tests/ooProp.test @@ -11,10 +11,27 @@ package require tcl::oo 1.0.3 package require tcltest 2 if {"::tcltest" in [namespace children]} { namespace import -force ::tcltest::* } + +testConstraint memory [llength [info commands memory]] +if {[testConstraint memory]} { + proc getbytes {} { + set lines [split [memory info] \n] + return [lindex $lines 3 3] + } + proc leaktest {script {iterations 3}} { + set end [getbytes] + for {set i 0} {$i < $iterations} {incr i} { + uplevel 1 $script + set tmp $end + set end [getbytes] + } + return [expr {$end - $tmp}] + } +} test ooProp-1.1 {TIP 558: properties: core support} -setup { oo::class create parent unset -nocomplain result set result {} @@ -874,12 +891,115 @@ } -cleanup { parent destroy } -result {1 {bad property "-gorp": must be -x while executing "pt configure -gorp blarg"} {TCL LOOKUP INDEX property -gorp}} + +test ooProp-5.1 {properties: basic leak test} -constraints memory -setup { + oo::class create parent { + variable x + constructor {{v 123}} {set x $v} + } +} -body { + oo::configurable create cls { + superclass parent + property x + } + set obj [cls new] + leaktest { + $obj configure -x 123 + } +} -cleanup { + parent destroy +} -result 0 +test ooProp-5.2 {properties: basic leak test} -constraints memory -setup { + oo::class create parent { + variable x + constructor {{v 123}} {set x $v} + } +} -body { + oo::configurable create cls { + superclass parent + property x + } + set obj [cls new] + leaktest { + $obj configure -x + } +} -cleanup { + parent destroy +} -result 0 +test ooProp-5.3 {properties: basic leak test} -constraints memory -setup { + oo::class create parent { + variable x + constructor {{v 123}} {set x $v} + } +} -body { + oo::configurable create cls { + superclass parent + property x + } + set obj [cls new] + leaktest { + $obj configure -x [expr {[$obj configure -x] + 1}] + } +} -cleanup { + parent destroy +} -result 0 +test ooProp-5.4 {properties: basic leak test} -constraints memory -setup { + oo::class create parent { + variable x + constructor {{v 123}} {set x $v} + } +} -body { + oo::configurable create cls { + superclass parent + } + set obj [cls new] + oo::objdefine $obj property x + leaktest { + $obj configure -x [expr {[$obj configure -x] + 1}] + } +} -cleanup { + parent destroy +} -result 0 +test ooProp-5.5 {properties: basic leak test} -constraints memory -setup { + oo::class create parent { + variable x + constructor {{v 123}} {set x $v} + } +} -body { + oo::configurable create cls { + superclass parent + } + set obj [cls new] + oo::objdefine $obj property x + leaktest { + $obj configure + } +} -cleanup { + parent destroy +} -result 0 +test ooProp-5.6 {properties: basic leak test} -constraints memory -setup { + oo::class create parent { + variable x y + constructor {{v 123} {w 234}} {set x $v; set y $w} + } +} -body { + oo::configurable create cls { + superclass parent + } + set obj [cls new] + oo::objdefine $obj property x y + leaktest { + list [$obj configure -x 1 -y 2] [$obj configure] + } +} -cleanup { + parent destroy +} -result 0 cleanupTests return # Local Variables: # mode: tcl # End: Index: win/nmakehlp.c ================================================================== --- win/nmakehlp.c +++ win/nmakehlp.c @@ -99,11 +99,11 @@ } return CheckForCompilerFeature(argv[2]); case 'l': if (argc < 3) { chars = snprintf(msg, sizeof(msg) - 1, - "usage: %s -l ? ...?\n" + "usage: %s -l ? ...?\n" "Tests for whether link.exe supports an option\n" "exitcodes: 0 == no, 1 == yes, 2 == error\n", argv[0]); WriteFile(GetStdHandle(STD_ERROR_HANDLE), msg, chars, &dwWritten, NULL); return 2; @@ -491,13 +491,13 @@ return (strstr(string, substring) != NULL); } /* * GetVersionFromFile -- - * Looks for a match string in a file and then returns the version - * following the match where a version is anything acceptable to - * package provide or package ifneeded. + * Looks for a match string in a file and then returns the version + * following the match where a version is anything acceptable to + * package provide or package ifneeded. */ static const char * GetVersionFromFile( const char *filename, Index: win/tclWinDde.c ================================================================== --- win/tclWinDde.c +++ win/tclWinDde.c @@ -46,11 +46,11 @@ typedef struct Conversation { struct Conversation *nextPtr; /* The next conversation in the list. */ RegisteredInterp *riPtr; /* The info we know about the conversation. */ HCONV hConv; /* The DDE handle for this conversation. */ - Tcl_Obj *returnPackagePtr; /* The result package for this conversation. */ + Tcl_Obj *returnTuplePtr; /* The result package for this conversation. */ } Conversation; typedef struct { Tcl_Interp *interp; int result; @@ -63,11 +63,11 @@ Conversation *currentConversations; /* A list of conversations currently being * processed. */ RegisteredInterp *interpListPtr; /* List of all interpreters registered in the - * current process. */ + * current thread. */ } ThreadSpecificData; static Tcl_ThreadDataKey dataKey; /* * The following variables cannot be placed in thread-local storage. The Mutex @@ -79,16 +79,20 @@ * by DdeInitialize. */ static int ddeIsServer = 0; #define TCL_DDE_VERSION "1.4.5" #define TCL_DDE_PACKAGE_NAME "dde" +#define TCL_DDE_COMMAND_NAME "dde" +#define TCL_DDE_HIDDEN_NAME "dde" #define TCL_DDE_SERVICE_NAME L"TclEval" #define TCL_DDE_EXECUTE_RESULT L"$TCLEVAL$EXECUTE$RESULT" -#define DDE_FLAG_ASYNC 1 -#define DDE_FLAG_BINARY 2 -#define DDE_FLAG_FORCE 4 +enum TclDdeFlags { + DDE_FLAG_ASYNC = 1, + DDE_FLAG_BINARY = 2, + DDE_FLAG_FORCE = 4 +}; TCL_DECLARE_MUTEX(ddeMutex) #if (TCL_MAJOR_VERSION < 9) && defined(TCL_MINOR_VERSION) && (TCL_MINOR_VERSION < 7) # if TCL_UTF_MAX > 3 @@ -137,11 +141,14 @@ extern "C" { #endif DLLEXPORT int Dde_Init(Tcl_Interp *interp); DLLEXPORT int Dde_SafeInit(Tcl_Interp *interp); #if TCL_MAJOR_VERSION < 9 -/* With those additional entries, "load tcldde14.dll" works without 3th argument */ +/* + * With those additional entries, "load tcldde14.dll" works without 3rd + * argument. + */ DLLEXPORT int Tcldde_Init(Tcl_Interp *interp); DLLEXPORT int Tcldde_SafeInit(Tcl_Interp *interp); #endif #ifdef __cplusplus } @@ -165,15 +172,15 @@ int Dde_Init( Tcl_Interp *interp) { - if (!Tcl_InitStubs(interp, "8.5-", 0)) { + if (!Tcl_InitStubs(interp, "8.7-", 0)) { return TCL_ERROR; } - Tcl_CreateObjCommand2(interp, "dde", DdeObjCmd, NULL, NULL); + Tcl_CreateObjCommand2(interp, TCL_DDE_COMMAND_NAME, DdeObjCmd, NULL, NULL); Tcl_CreateExitHandler(DdeExitProc, NULL); return Tcl_PkgProvideEx(interp, TCL_DDE_PACKAGE_NAME, TCL_DDE_VERSION, NULL); } #if TCL_MAJOR_VERSION < 9 int @@ -204,11 +211,11 @@ Dde_SafeInit( Tcl_Interp *interp) { int result = Dde_Init(interp); if (result == TCL_OK) { - Tcl_HideCommand(interp, "dde", "dde"); + Tcl_HideCommand(interp, TCL_DDE_COMMAND_NAME, TCL_DDE_HIDDEN_NAME); } return result; } #if TCL_MAJOR_VERSION < 9 int @@ -216,10 +223,83 @@ Tcl_Interp *interp) { return Dde_SafeInit(interp); } #endif + +/* + *---------------------------------------------------------------------- + * + * DStringToObj -- + * + * Knock-off version of Tcl_DStringToObj() that works with versions of + * Tcl before 8.7; it might not be quite as efficient, but it has the + * same overall interface. + * + *---------------------------------------------------------------------- + */ +static inline Tcl_Obj * +DStringToObj( + Tcl_DString *dsPtr) +{ +#if TCL_MAJOR_VERSION < 9 + Tcl_Obj *objPtr = Tcl_NewStringObj( + Tcl_DStringValue(dsPtr), Tcl_DStringLength(dsPtr)); + Tcl_DStringFree(dsPtr); + return objPtr; +#else + return Tcl_DStringToObj(dsPtr); +#endif +} + +/* + *---------------------------------------------------------------------- + * + * GetConversation -- + * + * Look up the conversation structure for a particular DDE conversation. + * + *---------------------------------------------------------------------- + */ +static inline Conversation * +GetConversation( + HCONV hConv) /* DDE conversation handle. */ +{ + ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); + Conversation *convPtr; + for (convPtr = tsdPtr->currentConversations; + convPtr && (convPtr->hConv != hConv); + convPtr = convPtr->nextPtr) { + /* + * Empty loop body. + */ + } + return convPtr; +} + +/* + *---------------------------------------------------------------------- + * + * GetRegisteredInterp -- + * + * Look up a registered interpreter handler for a service name. + * + *---------------------------------------------------------------------- + */ +static inline RegisteredInterp * +GetRegisteredInterp( + const WCHAR *name) /* Service name. */ +{ + ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); + RegisteredInterp *riPtr; + for (riPtr = tsdPtr->interpListPtr; riPtr; riPtr = riPtr->nextPtr) { + if (!_wcsicmp(name, riPtr->name)) { + break; + } + } + return riPtr; +} /* *---------------------------------------------------------------------- * * Initialize -- @@ -245,33 +325,33 @@ * See if the application is already registered; if so, remove its current * name from the registry. The deletion of the command will take care of * disposing of this entry. */ - if (tsdPtr->interpListPtr != NULL) { + if (tsdPtr->interpListPtr) { nameFound = 1; } /* * Make sure that the DDE server is there. This is done only once, add an - * exit handler tear it down. + * exit handler to tear it down. */ - if (ddeInstance == 0) { + if (!ddeInstance) { Tcl_MutexLock(&ddeMutex); - if (ddeInstance == 0) { + if (!ddeInstance) { if (DdeInitializeW(&ddeInstance, (PFNCALLBACK)(void *)DdeServerProc, CBF_SKIP_REGISTRATIONS | CBF_SKIP_UNREGISTRATIONS | CBF_FAIL_POKES, 0) != DMLERR_NO_ERROR) { ddeInstance = 0; } } Tcl_MutexUnlock(&ddeMutex); } - if ((ddeServiceGlobal == 0) && (nameFound != 0)) { + if (!ddeServiceGlobal && nameFound) { Tcl_MutexLock(&ddeMutex); - if ((ddeServiceGlobal == 0) && (nameFound != 0)) { + if (!ddeServiceGlobal && nameFound) { ddeIsServer = 1; Tcl_CreateExitHandler(DdeExitProc, NULL); ddeServiceGlobal = DdeCreateStringHandleW(ddeInstance, TCL_DDE_SERVICE_NAME, CP_WINUNICODE); DdeNameService(ddeInstance, ddeServiceGlobal, 0L, DNS_REGISTER); @@ -279,10 +359,31 @@ ddeIsServer = 0; } Tcl_MutexUnlock(&ddeMutex); } } + +/* + *---------------------------------------------------------------------- + * + * ReadDdeString -- + * Get a unicode string from a DDE string handle. + * + *---------------------------------------------------------------------- + */ +static inline WCHAR * +ReadDdeString( + Tcl_DString *dsBufferPtr, + HSZ ddeToken) /* DDE string handle. */ +{ + DWORD len = DdeQueryStringW(ddeInstance, ddeToken, NULL, 0, CP_WINUNICODE); + Tcl_DStringSetLength(dsBufferPtr, (len + 1) * sizeof(WCHAR) - 1); + WCHAR *utilString = (WCHAR *) Tcl_DStringValue(dsBufferPtr); + DdeQueryStringW(ddeInstance, ddeToken, utilString, (DWORD) len + 1, + CP_WINUNICODE); + return utilString; +} /* *---------------------------------------------------------------------- * * DdeSetServerName -- @@ -308,14 +409,14 @@ */ static const WCHAR * DdeSetServerName( Tcl_Interp *interp, - const WCHAR *name, /* The name that will be used to refer to the + const WCHAR *name, /* The name that will be used to refer to the * interpreter in later "send" commands. Must * be globally unique. */ - int flags, /* DDE_FLAG_FORCE or 0 */ + int flags, /* DDE_FLAG_FORCE or 0 */ Tcl_Obj *handlerPtr) /* Name of the optional proc/command to handle * incoming Dde eval's */ { int suffix; RegisteredInterp *riPtr, *prevPtr; @@ -333,12 +434,12 @@ */ for (riPtr = tsdPtr->interpListPtr, prevPtr = NULL; riPtr != NULL; prevPtr = riPtr, riPtr = riPtr->nextPtr) { if (riPtr->interp == interp) { - if (name != NULL) { - if (prevPtr == NULL) { + if (name) { + if (!prevPtr) { tsdPtr->interpListPtr = tsdPtr->interpListPtr->nextPtr; } else { prevPtr->nextPtr = riPtr->nextPtr; } break; @@ -351,11 +452,11 @@ return riPtr->name; } } } - if (name == NULL) { + if (!name) { /* * The name was NULL, so the caller is asking for the name of the * current interp, but it doesn't have a name. */ @@ -379,11 +480,13 @@ r = Tcl_ListObjGetElements(interp, srvListPtr, &srvCount, &srvPtrPtr); } if (r != TCL_OK) { Tcl_DStringInit(&dString); - OutputDebugStringW(Tcl_UtfToWCharDString(Tcl_GetString(Tcl_GetObjResult(interp)), -1, &dString)); + OutputDebugStringW(Tcl_UtfToWCharDString( + Tcl_GetString(Tcl_GetObjResult(interp)), TCL_AUTO_LENGTH, + &dString)); Tcl_DStringFree(&dString); return NULL; } /* @@ -397,14 +500,17 @@ while (suffix != lastSuffix) { lastSuffix = suffix; if (suffix > 1) { if (suffix == 2) { - Tcl_DStringAppend(&dString, (char *)name, wcslen(name) * sizeof(WCHAR)); - Tcl_DStringAppend(&dString, (char *)L" #", 2 * sizeof(WCHAR)); + Tcl_DStringAppend(&dString, (char *)name, + wcslen(name) * sizeof(WCHAR)); + Tcl_DStringAppend(&dString, (char *)L" #", + 2 * sizeof(WCHAR)); offset = Tcl_DStringLength(&dString); - Tcl_DStringSetLength(&dString, offset + sizeof(WCHAR) * TCL_INTEGER_SPACE); + Tcl_DStringSetLength(&dString, + offset + sizeof(WCHAR) * TCL_INTEGER_SPACE); actualName = (WCHAR *) Tcl_DStringValue(&dString); } _snwprintf((WCHAR *) (Tcl_DStringValue(&dString) + offset), TCL_INTEGER_SPACE, L"%d", suffix); } @@ -417,12 +523,13 @@ Tcl_Obj* namePtr; Tcl_DString ds; Tcl_ListObjIndex(interp, srvPtrPtr[n], 1, &namePtr); Tcl_DStringInit(&ds); - Tcl_UtfToWCharDString(Tcl_GetString(namePtr), -1, &ds); - if (wcscmp(actualName, (WCHAR *)Tcl_DStringValue(&ds)) == 0) { + Tcl_UtfToWCharDString(Tcl_GetString(namePtr), TCL_AUTO_LENGTH, + &ds); + if (!wcscmp(actualName, (WCHAR *)Tcl_DStringValue(&ds))) { suffix++; Tcl_DStringFree(&ds); break; } Tcl_DStringFree(&ds); @@ -434,27 +541,28 @@ * We have found a unique name. Now add it to the registry. */ riPtr = (RegisteredInterp *) Tcl_Alloc(sizeof(RegisteredInterp)); riPtr->interp = interp; - riPtr->name = (WCHAR *) Tcl_Alloc((wcslen(actualName) + 1) * sizeof(WCHAR)); + riPtr->name = (WCHAR *) + Tcl_Alloc((wcslen(actualName) + 1) * sizeof(WCHAR)); riPtr->nextPtr = tsdPtr->interpListPtr; riPtr->handlerPtr = handlerPtr; - if (riPtr->handlerPtr != NULL) { + if (riPtr->handlerPtr) { Tcl_IncrRefCount(riPtr->handlerPtr); } tsdPtr->interpListPtr = riPtr; wcscpy(riPtr->name, actualName); if (Tcl_IsSafe(interp)) { - Tcl_ExposeCommand(interp, "dde", "dde"); + Tcl_ExposeCommand(interp, TCL_DDE_HIDDEN_NAME, TCL_DDE_COMMAND_NAME); } - Tcl_CreateObjCommand2(interp, "dde", DdeObjCmd, - riPtr, DeleteProc); + Tcl_CreateObjCommand2(interp, TCL_DDE_COMMAND_NAME, DdeObjCmd, riPtr, + DeleteProc); if (Tcl_IsSafe(interp)) { - Tcl_HideCommand(interp, "dde", "dde"); + Tcl_HideCommand(interp, TCL_DDE_COMMAND_NAME, TCL_DDE_HIDDEN_NAME); } Tcl_DStringFree(&dString); /* * Re-initialize with the new name. @@ -479,11 +587,11 @@ * None * *---------------------------------------------------------------------- */ -static RegisteredInterp * +static inline RegisteredInterp * DdeGetRegistrationPtr( Tcl_Interp *interp) { RegisteredInterp *riPtr; ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); @@ -513,26 +621,26 @@ *---------------------------------------------------------------------- */ static void DeleteProc( - void *clientData) /* The interp we are deleting. */ + void *clientData) /* The interp we are deleting. */ { RegisteredInterp *riPtr = (RegisteredInterp *) clientData; RegisteredInterp *searchPtr, *prevPtr; ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); for (searchPtr = tsdPtr->interpListPtr, prevPtr = NULL; - (searchPtr != NULL) && (searchPtr != riPtr); + searchPtr && (searchPtr != riPtr); prevPtr = searchPtr, searchPtr = searchPtr->nextPtr) { /* * Empty loop body. */ } - if (searchPtr != NULL) { - if (prevPtr == NULL) { + if (searchPtr) { + if (!prevPtr) { tsdPtr->interpListPtr = tsdPtr->interpListPtr->nextPtr; } else { prevPtr->nextPtr = searchPtr->nextPtr; } } @@ -569,22 +677,23 @@ static Tcl_Obj * ExecuteRemoteObject( RegisteredInterp *riPtr, /* Info about this server. */ Tcl_Obj *ddeObjectPtr) /* The object to execute. */ { - Tcl_Obj *returnPackagePtr; + Tcl_Obj *returnTuplePtr; int result = TCL_OK; - if ((riPtr->handlerPtr == NULL) && Tcl_IsSafe(riPtr->interp)) { + if (!riPtr->handlerPtr && Tcl_IsSafe(riPtr->interp)) { Tcl_SetObjResult(riPtr->interp, Tcl_NewStringObj("permission denied: " "a handler procedure must be defined for use in a safe " - "interp", -1)); - Tcl_SetErrorCode(riPtr->interp, "TCL", "DDE", "SECURITY_CHECK", (char *)NULL); + "interp", TCL_AUTO_LENGTH)); + Tcl_SetErrorCode(riPtr->interp, "TCL", "DDE", "SECURITY_CHECK", + (char *)NULL); result = TCL_ERROR; } - if (riPtr->handlerPtr != NULL) { + if (riPtr->handlerPtr) { /* * Add the dde request data to the handler proc list. */ Tcl_Obj *cmdPtr = Tcl_DuplicateObj(riPtr->handlerPtr); @@ -591,38 +700,52 @@ result = Tcl_ListObjAppendElement(riPtr->interp, cmdPtr, ddeObjectPtr); if (result == TCL_OK) { ddeObjectPtr = cmdPtr; + } else { + Tcl_DecrRefCount(cmdPtr); } } + /* + * Execute the script. + */ + + Tcl_IncrRefCount(ddeObjectPtr); if (result == TCL_OK) { result = Tcl_EvalObjEx(riPtr->interp, ddeObjectPtr, TCL_EVAL_GLOBAL); } + Tcl_DecrRefCount(ddeObjectPtr); - returnPackagePtr = Tcl_NewListObj(0, NULL); + /* + * Package the result into a tuple. + * TODO: Transfer the whole result option dictionary, a protocol change. + */ - Tcl_ListObjAppendElement(NULL, returnPackagePtr, - Tcl_NewIntObj(result)); - Tcl_ListObjAppendElement(NULL, returnPackagePtr, + returnTuplePtr = Tcl_NewListObj(0, NULL); + + Tcl_ListObjAppendElement(NULL, returnTuplePtr, Tcl_NewIntObj(result)); + Tcl_ListObjAppendElement(NULL, returnTuplePtr, Tcl_GetObjResult(riPtr->interp)); if (result == TCL_ERROR) { Tcl_Obj *errorObjPtr = Tcl_GetVar2Ex(riPtr->interp, "errorCode", NULL, TCL_GLOBAL_ONLY); - if (errorObjPtr) { - Tcl_ListObjAppendElement(NULL, returnPackagePtr, errorObjPtr); + if (!errorObjPtr) { + errorObjPtr = Tcl_NewObj(); } + Tcl_ListObjAppendElement(NULL, returnTuplePtr, errorObjPtr); errorObjPtr = Tcl_GetVar2Ex(riPtr->interp, "errorInfo", NULL, TCL_GLOBAL_ONLY); - if (errorObjPtr) { - Tcl_ListObjAppendElement(NULL, returnPackagePtr, errorObjPtr); + if (!errorObjPtr) { + errorObjPtr = Tcl_NewObj(); } + Tcl_ListObjAppendElement(NULL, returnTuplePtr, errorObjPtr); } - return returnPackagePtr; + return returnTuplePtr; } /* *---------------------------------------------------------------------- * @@ -662,64 +785,43 @@ Tcl_Obj *ddeObjectPtr; HDDEDATA ddeReturn = NULL; RegisteredInterp *riPtr; Conversation *convPtr, *prevConvPtr; ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); - (void)unused1; - (void)unused2; + (void) unused1; + (void) unused2; switch(uType) { case XTYP_CONNECT: /* * Dde is trying to initialize a conversation with us. Check and make * sure we have a valid topic. */ - len = DdeQueryStringW(ddeInstance, ddeTopic, NULL, 0, CP_WINUNICODE); Tcl_DStringInit(&dString); - Tcl_DStringSetLength(&dString, (len + 1) * sizeof(WCHAR) - 1); - utilString = (WCHAR *) Tcl_DStringValue(&dString); - DdeQueryStringW(ddeInstance, ddeTopic, utilString, (DWORD) len + 1, - CP_WINUNICODE); - - for (riPtr = tsdPtr->interpListPtr; riPtr != NULL; - riPtr = riPtr->nextPtr) { - if (_wcsicmp(utilString, riPtr->name) == 0) { - Tcl_DStringFree(&dString); - return (HDDEDATA) TRUE; - } - } - - Tcl_DStringFree(&dString); - return (HDDEDATA) FALSE; + riPtr = GetRegisteredInterp(ReadDdeString(&dString, ddeTopic)); + Tcl_DStringFree(&dString); + return (riPtr != NULL ? (HDDEDATA) TRUE : (HDDEDATA) FALSE); case XTYP_CONNECT_CONFIRM: /* * Dde has decided that we can connect, so it gives us a conversation * handle. We need to keep track of it so we know which execution * result to return in an XTYP_REQUEST. */ - len = DdeQueryStringW(ddeInstance, ddeTopic, NULL, 0, CP_WINUNICODE); Tcl_DStringInit(&dString); - Tcl_DStringSetLength(&dString, (len + 1) * sizeof(WCHAR) - 1); - utilString = (WCHAR *) Tcl_DStringValue(&dString); - DdeQueryStringW(ddeInstance, ddeTopic, utilString, (DWORD) len + 1, - CP_WINUNICODE); - for (riPtr = tsdPtr->interpListPtr; riPtr != NULL; - riPtr = riPtr->nextPtr) { - if (_wcsicmp(riPtr->name, utilString) == 0) { - convPtr = (Conversation *) Tcl_Alloc(sizeof(Conversation)); - convPtr->nextPtr = tsdPtr->currentConversations; - convPtr->returnPackagePtr = NULL; - convPtr->hConv = hConv; - convPtr->riPtr = riPtr; - tsdPtr->currentConversations = convPtr; - break; - } - } + riPtr = GetRegisteredInterp(ReadDdeString(&dString, ddeTopic)); Tcl_DStringFree(&dString); + if (riPtr) { + convPtr = (Conversation *) Tcl_Alloc(sizeof(Conversation)); + convPtr->nextPtr = tsdPtr->currentConversations; + convPtr->returnTuplePtr = NULL; + convPtr->hConv = hConv; + convPtr->riPtr = riPtr; + tsdPtr->currentConversations = convPtr; + } return (HDDEDATA) TRUE; case XTYP_DISCONNECT: /* * The client has disconnected from our server. Forget this @@ -728,17 +830,17 @@ for (convPtr = tsdPtr->currentConversations, prevConvPtr = NULL; convPtr != NULL; prevConvPtr = convPtr, convPtr = convPtr->nextPtr) { if (hConv == convPtr->hConv) { - if (prevConvPtr == NULL) { + if (!prevConvPtr) { tsdPtr->currentConversations = convPtr->nextPtr; } else { prevConvPtr->nextPtr = convPtr->nextPtr; } - if (convPtr->returnPackagePtr != NULL) { - Tcl_DecrRefCount(convPtr->returnPackagePtr); + if (convPtr->returnTuplePtr) { + Tcl_DecrRefCount(convPtr->returnTuplePtr); } Tcl_Free((char *) convPtr); break; } } @@ -754,75 +856,80 @@ if ((uFmt != CF_TEXT) && (uFmt != CF_UNICODETEXT)) { return (HDDEDATA) FALSE; } ddeReturn = (HDDEDATA) FALSE; - for (convPtr = tsdPtr->currentConversations; (convPtr != NULL) - && (convPtr->hConv != hConv); convPtr = convPtr->nextPtr) { - /* - * Empty loop body. - */ - } - - if (convPtr != NULL) { - Tcl_DString dsBuf; - char *returnString; - - len = DdeQueryStringW(ddeInstance, ddeItem, NULL, 0, CP_WINUNICODE); - Tcl_DStringInit(&dString); - Tcl_DStringInit(&dsBuf); - Tcl_DStringSetLength(&dString, (len + 1) * sizeof(WCHAR) - 1); - utilString = (WCHAR *) Tcl_DStringValue(&dString); - DdeQueryStringW(ddeInstance, ddeItem, utilString, (DWORD) len + 1, - CP_WINUNICODE); - if (_wcsicmp(utilString, TCL_DDE_EXECUTE_RESULT) == 0) { - returnString = - Tcl_GetStringFromObj(convPtr->returnPackagePtr, &len); - if (uFmt != CF_TEXT) { - Tcl_DStringInit(&dsBuf); - Tcl_UtfToWCharDString(returnString, len, &dsBuf); - returnString = Tcl_DStringValue(&dsBuf); - len = Tcl_DStringLength(&dsBuf) + sizeof(WCHAR) - 1; - } - ddeReturn = DdeCreateDataHandle(ddeInstance, (BYTE *)returnString, - (DWORD) len+1, 0, ddeItem, uFmt, 0); - } else { - if (Tcl_IsSafe(convPtr->riPtr->interp)) { - ddeReturn = NULL; - } else { - Tcl_DString ds; - Tcl_Obj *variableObjPtr; - - Tcl_DStringInit(&ds); - Tcl_WCharToUtfDString(utilString, wcslen(utilString), &ds); - variableObjPtr = Tcl_GetVar2Ex( - convPtr->riPtr->interp, Tcl_DStringValue(&ds), NULL, - TCL_GLOBAL_ONLY); - if (variableObjPtr != NULL) { - returnString = Tcl_GetStringFromObj(variableObjPtr, &len); - if (uFmt != CF_TEXT) { - Tcl_DStringInit(&dsBuf); - Tcl_UtfToWCharDString(returnString, len, &dsBuf); - returnString = Tcl_DStringValue(&dsBuf); - len = Tcl_DStringLength(&dsBuf) + sizeof(WCHAR) - 1; - } - ddeReturn = DdeCreateDataHandle(ddeInstance, - (BYTE *)returnString, (DWORD) len+1, 0, ddeItem, - uFmt, 0); - } else { - ddeReturn = NULL; - } - Tcl_DStringFree(&ds); + convPtr = GetConversation(hConv); + if (convPtr) { + Tcl_DString dsBuf; + const char *returnString; + + Tcl_DStringInit(&dString); + Tcl_DStringInit(&dsBuf); + utilString = ReadDdeString(&dString, ddeItem); + if (!_wcsicmp(utilString, TCL_DDE_EXECUTE_RESULT)) { + if (convPtr->returnTuplePtr) { + returnString = Tcl_GetStringFromObj( + convPtr->returnTuplePtr, &len); + } else { + /* + * No previous call in the conversation; someone's playing + * naughty games. Pretend everything's TCL_OK. + */ + returnString = "0 {}"; + len = 4; + } + if (uFmt == CF_UNICODETEXT) { + Tcl_UtfToWCharDString(returnString, len, &dsBuf); + returnString = Tcl_DStringValue(&dsBuf); + len = Tcl_DStringLength(&dsBuf) + sizeof(WCHAR) - 1; + } + ddeReturn = DdeCreateDataHandle(ddeInstance, + (BYTE *) returnString, (DWORD) len + 1, 0, ddeItem, + uFmt, 0); + } else if (Tcl_IsSafe(convPtr->riPtr->interp)) { + /* + * Safe interps don't support direct variable reading; all + * variables have to be read through the script handler (if + * one is defined, which isn't examined here). + */ + ddeReturn = NULL; + } else { + Tcl_DString ds; + Tcl_Obj *valueObjPtr; + const char *varName; + + Tcl_DStringInit(&ds); + varName = Tcl_WCharToUtfDString(utilString, + wcslen(utilString), &ds); + valueObjPtr = Tcl_GetVar2Ex(convPtr->riPtr->interp, varName, + NULL, TCL_GLOBAL_ONLY); + Tcl_DStringFree(&ds); + + if (valueObjPtr) { + returnString = Tcl_GetStringFromObj(valueObjPtr, &len); + if (uFmt == CF_UNICODETEXT) { + Tcl_UtfToWCharDString(returnString, len, &dsBuf); + returnString = Tcl_DStringValue(&dsBuf); + len = Tcl_DStringLength(&dsBuf) + sizeof(WCHAR) - 1; + } + ddeReturn = DdeCreateDataHandle(ddeInstance, + (BYTE *) returnString, (DWORD) len + 1, 0, + ddeItem, uFmt, 0); + } else { + ddeReturn = NULL; } } Tcl_DStringFree(&dsBuf); Tcl_DStringFree(&dString); } return ddeReturn; -#if !CBF_FAIL_POKES case XTYP_POKE: +#if CBF_FAIL_POKES + return NULL; +#else /* * This is a poke for a Tcl variable, only implemented in * debug/UNICODE mode. */ ddeReturn = DDE_FNOTPROCESSED; @@ -829,47 +936,43 @@ if ((uFmt != CF_TEXT) && (uFmt != CF_UNICODETEXT)) { return ddeReturn; } - for (convPtr = tsdPtr->currentConversations; (convPtr != NULL) - && (convPtr->hConv != hConv); convPtr = convPtr->nextPtr) { - /* - * Empty loop body. - */ - } - + convPtr = GetConversation(hConv); if (convPtr && !Tcl_IsSafe(convPtr->riPtr->interp)) { - Tcl_DString ds, ds2; - Tcl_Obj *variableObjPtr; - DWORD len2; + Tcl_DString varNameDs, valueDs; + const char *varName; + Tcl_Obj *valueObj; + LPBYTE ptr; Tcl_DStringInit(&dString); - Tcl_DStringInit(&ds2); - len = DdeQueryStringW(ddeInstance, ddeItem, NULL, 0, CP_WINUNICODE); - Tcl_DStringSetLength(&dString, (len + 1) * sizeof(WCHAR) - 1); - utilString = (WCHAR *) Tcl_DStringValue(&dString); - DdeQueryStringW(ddeInstance, ddeItem, utilString, (DWORD) len + 1, - CP_WINUNICODE); - Tcl_DStringInit(&ds); - Tcl_WCharToUtfDString(utilString, wcslen(utilString), &ds); - utilString = (WCHAR *) DdeAccessData(hData, &len2); - len = len2; - if (uFmt != CF_TEXT) { - Tcl_DStringInit(&ds2); - Tcl_WCharToUtfDString(utilString, wcslen(utilString), &ds2); - utilString = (WCHAR *) Tcl_DStringValue(&ds2); - } - variableObjPtr = Tcl_NewStringObj((char *)utilString, -1); - - Tcl_SetVar2Ex(convPtr->riPtr->interp, Tcl_DStringValue(&ds), NULL, - variableObjPtr, TCL_GLOBAL_ONLY); - - Tcl_DStringFree(&ds2); - Tcl_DStringFree(&ds); + Tcl_DStringInit(&varNameDs); + Tcl_DStringInit(&valueDs); + + utilString = ReadDdeString(&dString, ddeItem); + varName = Tcl_WCharToUtfDString(utilString, wcslen(utilString), + &varNameDs); + + ptr = DdeAccessData(hData, NULL); + if (uFmt == CF_UNICODETEXT) { + utilString = (WCHAR *) ptr; + Tcl_WCharToUtfDString(utilString, wcslen(utilString), + &valueDs); + valueObj = DStringToObj(&valueDs); + } else { + valueObj = Tcl_NewStringObj((char *) ptr, TCL_AUTO_LENGTH); + } + DdeUnaccessData(hData); + + Tcl_SetVar2Ex(convPtr->riPtr->interp, varName, NULL, valueObj, + TCL_GLOBAL_ONLY); + + Tcl_DStringFree(&valueDs); + Tcl_DStringFree(&varNameDs); Tcl_DStringFree(&dString); - ddeReturn = (HDDEDATA) DDE_FACK; + ddeReturn = (HDDEDATA) DDE_FACK; } return ddeReturn; #endif case XTYP_EXECUTE: { @@ -876,97 +979,98 @@ /* * Execute this script. The results will be saved into a list object * which will be retrieved later. See ExecuteRemoteObject. */ - Tcl_Obj *returnPackagePtr; + Tcl_Obj *returnTuplePtr; char *string; - - for (convPtr = tsdPtr->currentConversations; (convPtr != NULL) - && (convPtr->hConv != hConv); convPtr = convPtr->nextPtr) { - /* - * Empty loop body. - */ - } - - if (convPtr == NULL) { + Tcl_DString dsBuf; + + convPtr = GetConversation(hConv); + if (!convPtr) { return (HDDEDATA) DDE_FNOTPROCESSED; } + /* + * Read the string to execute. + */ + utilString = (WCHAR *) DdeAccessData(hData, &dlen); string = (char *) utilString; if (!dlen) { /* Empty binary array. */ ddeObjectPtr = Tcl_NewObj(); - } else if ((dlen & 1) || utilString[(dlen>>1)-1]) { + } else if ((dlen & 1) || utilString[dlen / sizeof(WCHAR) - 1]) { /* Cannot be Unicode, so assume utf-8 */ - if (!string[dlen-1]) { + if (!string[dlen - 1]) { dlen--; } ddeObjectPtr = Tcl_NewStringObj(string, dlen); } else { /* Unicode */ - Tcl_DString dsBuf; - Tcl_DStringInit(&dsBuf); - Tcl_WCharToUtfDString(utilString, (dlen>>1) - 1, &dsBuf); - ddeObjectPtr = Tcl_NewStringObj(Tcl_DStringValue(&dsBuf), - Tcl_DStringLength(&dsBuf)); - Tcl_DStringFree(&dsBuf); + Tcl_WCharToUtfDString(utilString, dlen / sizeof(WCHAR) - 1, &dsBuf); + ddeObjectPtr = DStringToObj(&dsBuf); } Tcl_IncrRefCount(ddeObjectPtr); DdeUnaccessData(hData); - if (convPtr->returnPackagePtr != NULL) { - Tcl_DecrRefCount(convPtr->returnPackagePtr); - } - convPtr->returnPackagePtr = NULL; - returnPackagePtr = ExecuteRemoteObject(convPtr->riPtr, ddeObjectPtr); - Tcl_IncrRefCount(returnPackagePtr); - for (convPtr = tsdPtr->currentConversations; (convPtr != NULL) - && (convPtr->hConv != hConv); convPtr = convPtr->nextPtr) { - /* - * Empty loop body. - */ - } - if (convPtr != NULL) { - convPtr->returnPackagePtr = returnPackagePtr; + + /* + * Release previous result tuple, if there is one + */ + + if (convPtr->returnTuplePtr) { + Tcl_DecrRefCount(convPtr->returnTuplePtr); + } + convPtr->returnTuplePtr = NULL; + + returnTuplePtr = ExecuteRemoteObject(convPtr->riPtr, ddeObjectPtr); + + /* + * Attach the result tuple to the conversation, ready for pickup. + * Note that this called user code, so we need to loop up the + * conversation again for safety. + */ + + convPtr = GetConversation(hConv); + if (convPtr) { + Tcl_IncrRefCount(returnTuplePtr); + convPtr->returnTuplePtr = returnTuplePtr; } else { - Tcl_DecrRefCount(returnPackagePtr); + Tcl_DecrRefCount(returnTuplePtr); } Tcl_DecrRefCount(ddeObjectPtr); - if (returnPackagePtr == NULL) { - return (HDDEDATA) DDE_FNOTPROCESSED; - } else { - return (HDDEDATA) DDE_FACK; - } + return (HDDEDATA) DDE_FACK; } case XTYP_WILDCONNECT: { /* * Dde wants a list of services and topics that we support. */ HSZPAIR *returnPtr; - Tcl_Size i; - DWORD numItems; + DWORD i, numItems; - for (i = 0, riPtr = tsdPtr->interpListPtr; riPtr != NULL; - i++, riPtr = riPtr->nextPtr) { + for (numItems = 0, riPtr = tsdPtr->interpListPtr; + riPtr != NULL && numItems < UINT_MAX; + numItems++, riPtr = riPtr->nextPtr) { /* * Empty loop body. */ } - - if ((size_t)i >= UINT_MAX/sizeof(HSZPAIR)) { + if ((size_t)numItems >= UINT_MAX / sizeof(HSZPAIR)) { return NULL; } - numItems = (DWORD)i; + + /* + * Allocate a buffer and write the service/topic descriptors into it. + */ + ddeReturn = DdeCreateDataHandle(ddeInstance, NULL, - (numItems + 1) * (DWORD)sizeof(HSZPAIR), 0, 0, 0, 0); - returnPtr = (HSZPAIR *) DdeAccessData(ddeReturn, &dlen); - len = dlen; - for (i = 0, riPtr = tsdPtr->interpListPtr; i < (Tcl_Size)numItems; + (numItems + 1) * (DWORD) sizeof(HSZPAIR), 0, 0, 0, 0); + returnPtr = (HSZPAIR *) DdeAccessData(ddeReturn, NULL); + for (i = 0, riPtr = tsdPtr->interpListPtr; i < numItems; i++, riPtr = riPtr->nextPtr) { returnPtr[i].hszSvc = DdeCreateStringHandleW(ddeInstance, TCL_DDE_SERVICE_NAME, CP_WINUNICODE); returnPtr[i].hszTopic = DdeCreateStringHandleW(ddeInstance, riPtr->name, CP_WINUNICODE); @@ -1032,25 +1136,27 @@ HCONV *ddeConvPtr) { HSZ ddeTopic, ddeService; HCONV ddeConv; - ddeService = DdeCreateStringHandleW(ddeInstance, TCL_DDE_SERVICE_NAME, CP_WINUNICODE); + ddeService = DdeCreateStringHandleW(ddeInstance, TCL_DDE_SERVICE_NAME, + CP_WINUNICODE); ddeTopic = DdeCreateStringHandleW(ddeInstance, name, CP_WINUNICODE); ddeConv = DdeConnect(ddeInstance, ddeService, ddeTopic, NULL); DdeFreeStringHandle(ddeInstance, ddeService); DdeFreeStringHandle(ddeInstance, ddeTopic); if (ddeConv == (HCONV) NULL) { - if (interp != NULL) { + if (interp) { Tcl_DString dString; Tcl_DStringInit(&dString); Tcl_WCharToUtfDString(name, wcslen(name), &dString); Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "no registered server named \"%s\"", Tcl_DStringValue(&dString))); + "no registered server named \"%s\"", + Tcl_DStringValue(&dString))); Tcl_DStringFree(&dString); Tcl_SetErrorCode(interp, "TCL", "DDE", "NO_SERVER", (char *)NULL); } return TCL_ERROR; } @@ -1097,11 +1203,11 @@ * Register and create the callback window. */ RegisterClassExW(&wc); es->hwnd = CreateWindowExW(0, szDdeClientClassName, szDdeClientWindowName, - WS_POPUP, 0, 0, 0, 0, NULL, NULL, NULL, (LPVOID)es); + WS_POPUP, 0, 0, 0, 0, NULL, NULL, NULL, (LPVOID) es); return TCL_OK; } static LRESULT CALLBACK DdeClientWindowProc( @@ -1111,12 +1217,11 @@ LPARAM lParam) /* (Potentially) our local handle */ { switch (uMsg) { case WM_CREATE: { LPCREATESTRUCT lpcs = (LPCREATESTRUCT) lParam; - DdeEnumServices *es = - (DdeEnumServices *) lpcs->lpCreateParams; + DdeEnumServices *es = (DdeEnumServices *) lpcs->lpCreateParams; #ifdef _WIN64 SetWindowLongPtrW(hwnd, GWLP_USERDATA, (LONG_PTR) es); #else SetWindowLongW(hwnd, GWL_USERDATA, (LONG) es); @@ -1134,13 +1239,13 @@ DdeServicesOnAck( HWND hwnd, WPARAM wParam, LPARAM lParam) { - HWND hwndRemote = (HWND)wParam; - ATOM service = (ATOM)LOWORD(lParam); - ATOM topic = (ATOM)HIWORD(lParam); + HWND hwndRemote = (HWND) wParam; + ATOM service = (ATOM) LOWORD(lParam); + ATOM topic = (ATOM) HIWORD(lParam); DdeEnumServices *es; WCHAR sz[255]; Tcl_DString dString; #ifdef _WIN64 @@ -1155,16 +1260,17 @@ Tcl_Obj *resultPtr = Tcl_GetObjResult(es->interp); GlobalGetAtomNameW(service, sz, 255); Tcl_DStringInit(&dString); Tcl_WCharToUtfDString(sz, wcslen(sz), &dString); - Tcl_ListObjAppendElement(NULL, matchPtr, Tcl_NewStringObj(Tcl_DStringValue(&dString), -1)); + Tcl_ListObjAppendElement(NULL, matchPtr, Tcl_NewStringObj( + Tcl_DStringValue(&dString), TCL_AUTO_LENGTH)); Tcl_DStringFree(&dString); GlobalGetAtomNameW(topic, sz, 255); - Tcl_DStringInit(&dString); Tcl_WCharToUtfDString(sz, wcslen(sz), &dString); - Tcl_ListObjAppendElement(NULL, matchPtr, Tcl_NewStringObj(Tcl_DStringValue(&dString), -1)); + Tcl_ListObjAppendElement(NULL, matchPtr, Tcl_NewStringObj( + Tcl_DStringValue(&dString), TCL_AUTO_LENGTH)); Tcl_DStringFree(&dString); /* * Adding the hwnd as a third list element provides a unique * identifier in the case of multiple servers with the name @@ -1171,11 +1277,11 @@ * application and topic names. */ /* * Needs a TIP though: * Tcl_ListObjAppendElement(NULL, matchPtr, - * Tcl_NewLongObj((long)hwndRemote)); + * Tcl_NewLongObj((long) hwndRemote)); */ if (Tcl_IsShared(resultPtr)) { resultPtr = Tcl_DuplicateObj(resultPtr); } @@ -1187,11 +1293,11 @@ /* * Tell the server we are no longer interested. */ - PostMessageW(hwndRemote, WM_DDE_TERMINATE, (WPARAM)hwnd, 0L); + PostMessageW(hwndRemote, WM_DDE_TERMINATE, (WPARAM) hwnd, 0L); return 0L; } static BOOL CALLBACK DdeEnumWindowsCallback( @@ -1199,11 +1305,11 @@ LPARAM lParam) { DWORD_PTR dwResult = 0; DdeEnumServices *es = (DdeEnumServices *) lParam; - SendMessageTimeoutW(hwndTarget, WM_DDE_INITIATE, (WPARAM)es->hwnd, + SendMessageTimeoutW(hwndTarget, WM_DDE_INITIATE, (WPARAM) es->hwnd, MAKELONG(es->service, es->topic), SMTO_ABORTIFHUNG, 1000, &dwResult); return TRUE; } @@ -1254,11 +1360,11 @@ *---------------------------------------------------------------------- */ static void SetDdeError( - Tcl_Interp *interp) /* The interp to put the message in. */ + Tcl_Interp *interp) /* The interp to put the message in. */ { const char *errorMessage, *errorCode; switch (DdeGetLastError(ddeInstance)) { case DMLERR_DATAACKTIMEOUT: @@ -1278,11 +1384,11 @@ default: errorMessage = "dde command failed"; errorCode = "FAILED"; } - Tcl_SetObjResult(interp, Tcl_NewStringObj(errorMessage, -1)); + Tcl_SetObjResult(interp, Tcl_NewStringObj(errorMessage, TCL_AUTO_LENGTH)); Tcl_SetErrorCode(interp, "TCL", "DDE", errorCode, (char *)NULL); } /* *---------------------------------------------------------------------- @@ -1299,15 +1405,18 @@ * See the user documentation. * *---------------------------------------------------------------------- */ +#define Format(flags) \ + (((flags) & DDE_FLAG_BINARY) ? CF_TEXT : CF_UNICODETEXT) + static int DdeObjCmd( - void *dummy, /* Not used. */ + void *dummy, /* Not used. */ Tcl_Interp *interp, /* The interp we are sending from */ - Tcl_Size objc, /* Number of arguments */ + Tcl_Size objc, /* Number of arguments */ Tcl_Obj *const *objv) /* The arguments */ { static const char *const ddeCommands[] = { "servername", "execute", "poke", "request", "services", "eval", NULL}; enum DdeSubcommands { @@ -1338,18 +1447,17 @@ int flags = 0, result = TCL_OK, firstArg = 0; HSZ ddeService = NULL, ddeTopic = NULL, ddeItem = NULL, ddeCookie = NULL; HDDEDATA ddeData = NULL, ddeItemData = NULL, ddeReturn; HCONV hConv = NULL; const WCHAR *serviceName = NULL, *topicName = NULL; - const char *string; DWORD ddeResult; Tcl_Obj *objPtr, *handlerPtr = NULL; - Tcl_DString serviceBuf, topicBuf, itemBuf; + Tcl_DString serviceBuf, topicBuf, itemBuf, dsBuf; (void)dummy; /* - * Initialize DDE server/client + * Parse arguments. */ if (objc < 2) { Tcl_WrongNumArgs(interp, 1, objv, "command ?arg ...?"); return TCL_ERROR; @@ -1358,13 +1466,10 @@ if (Tcl_GetIndexFromObj(interp, objv[1], ddeCommands, "command", 0, &index) != TCL_OK) { return TCL_ERROR; } - Tcl_DStringInit(&serviceBuf); - Tcl_DStringInit(&topicBuf); - Tcl_DStringInit(&itemBuf); switch ((enum DdeSubcommands) index) { case DDE_SERVERNAME: for (i = 2; i < objc; i++) { if (Tcl_GetIndexFromObj(interp, objv[i], ddeSrvOptions, "option", 0, &argIndex) != TCL_OK) { @@ -1371,20 +1476,20 @@ /* * If it is the last argument, it might be a server name * instead of a bad argument. */ - if (i != objc-1) { + if (i != objc - 1) { return TCL_ERROR; } Tcl_ResetResult(interp); break; } if (argIndex == DDE_SERVERNAME_EXACT) { flags |= DDE_FLAG_FORCE; } else if (argIndex == DDE_SERVERNAME_HANDLER) { - if ((objc - i) == 1) { /* return current handler */ + if (objc - i == 1) { /* return current handler */ RegisteredInterp *riPtr = DdeGetRegistrationPtr(interp); if (riPtr && riPtr->handlerPtr) { Tcl_SetObjResult(interp, riPtr->handlerPtr); } else { @@ -1397,11 +1502,11 @@ i++; break; } } - if ((objc - i) > 1) { + if (objc - i > 1) { Tcl_ResetResult(interp); Tcl_WrongNumArgs(interp, 2, objv, "?-force? ?-handler proc? ?--? ?serverName?"); return TCL_ERROR; } @@ -1478,30 +1583,37 @@ case DDE_EVAL: if (objc < 4) { wrongDdeEvalArgs: Tcl_WrongNumArgs(interp, 2, objv, "?-async? serviceName args"); return TCL_ERROR; - } else { - firstArg = 2; - if (Tcl_GetIndexFromObj(NULL, objv[2], ddeEvalOptions, "option", - 0, &argIndex) == TCL_OK) { - if (objc < 5) { - goto wrongDdeEvalArgs; - } - flags |= DDE_FLAG_ASYNC; - firstArg++; - } - break; - } - } + } + firstArg = 2; + if (Tcl_GetIndexFromObj(NULL, objv[2], ddeEvalOptions, "option", + 0, &argIndex) == TCL_OK) { + if (objc < 5) { + goto wrongDdeEvalArgs; + } + flags |= DDE_FLAG_ASYNC; + firstArg++; + } + break; + } + + /* + * Arguments parsed. Time to implement. + * Initialize DDE server/client. + */ Initialize(); + Tcl_DStringInit(&serviceBuf); + Tcl_DStringInit(&topicBuf); + Tcl_DStringInit(&itemBuf); + Tcl_DStringInit(&dsBuf); if (firstArg != 1) { const char *src = Tcl_GetStringFromObj(objv[firstArg], &length); - Tcl_DStringInit(&serviceBuf); Tcl_UtfToWCharDString(src, length, &serviceBuf); serviceName = (WCHAR *) Tcl_DStringValue(&serviceBuf); length = Tcl_DStringLength(&serviceBuf) / sizeof(WCHAR); } else { length = 0; @@ -1515,11 +1627,10 @@ } if ((index != DDE_SERVERNAME) && (index != DDE_EVAL)) { const char *src = Tcl_GetStringFromObj(objv[firstArg + 1], &length); - Tcl_DStringInit(&topicBuf); topicName = Tcl_UtfToWCharDString(src, length, &topicBuf); length = Tcl_DStringLength(&topicBuf) / sizeof(WCHAR); if (length == 0) { topicName = NULL; } else { @@ -1528,218 +1639,178 @@ } } switch ((enum DdeSubcommands) index) { case DDE_SERVERNAME: - serviceName = DdeSetServerName(interp, serviceName, flags, - handlerPtr); - if (serviceName != NULL) { - Tcl_DString dsBuf; - - Tcl_DStringInit(&dsBuf); + serviceName = DdeSetServerName(interp, serviceName, flags, handlerPtr); + if (serviceName) { Tcl_WCharToUtfDString(serviceName, wcslen(serviceName), &dsBuf); - Tcl_SetObjResult(interp, Tcl_NewStringObj(Tcl_DStringValue(&dsBuf), - Tcl_DStringLength(&dsBuf))); - Tcl_DStringFree(&dsBuf); + Tcl_SetObjResult(interp, DStringToObj(&dsBuf)); } else { Tcl_ResetResult(interp); } break; case DDE_EXECUTE: { Tcl_Size dataLength; const void *dataString; - Tcl_DString dsBuf; - Tcl_DStringInit(&dsBuf); if (flags & DDE_FLAG_BINARY) { - dataString = - Tcl_GetByteArrayFromObj(objv[firstArg + 2], &dataLength); + dataString = Tcl_GetByteArrayFromObj(objv[firstArg + 2], + &dataLength); } else { - const char *src; + const char *src = Tcl_GetStringFromObj(objv[firstArg + 2], + &dataLength); - src = Tcl_GetStringFromObj(objv[firstArg + 2], &dataLength); - Tcl_DStringInit(&dsBuf); - dataString = - Tcl_UtfToWCharDString(src, dataLength, &dsBuf); + dataString = Tcl_UtfToWCharDString(src, dataLength, &dsBuf); dataLength = Tcl_DStringLength(&dsBuf) + sizeof(WCHAR); } if (dataLength + 1 < 2) { - Tcl_SetObjResult(interp, - Tcl_NewStringObj("cannot execute null data", -1)); - Tcl_DStringFree(&dsBuf); + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "cannot execute null data", TCL_AUTO_LENGTH)); Tcl_SetErrorCode(interp, "TCL", "DDE", "NULL", (char *)NULL); result = TCL_ERROR; break; } hConv = DdeConnect(ddeInstance, ddeService, ddeTopic, NULL); DdeFreeStringHandle(ddeInstance, ddeService); DdeFreeStringHandle(ddeInstance, ddeTopic); - - if (hConv == NULL) { - Tcl_DStringFree(&dsBuf); - SetDdeError(interp); - result = TCL_ERROR; - break; + if (!hConv) { + goto ddeError; } ddeData = DdeCreateDataHandle(ddeInstance, (BYTE *) dataString, - (DWORD) dataLength, 0, 0, (flags & DDE_FLAG_BINARY) ? CF_TEXT : CF_UNICODETEXT, 0); - if (ddeData != NULL) { - if (flags & DDE_FLAG_ASYNC) { - DdeClientTransaction((LPBYTE) ddeData, 0xFFFFFFFF, hConv, 0, - (flags & DDE_FLAG_BINARY) ? CF_TEXT : CF_UNICODETEXT, XTYP_EXECUTE, TIMEOUT_ASYNC, &ddeResult); - DdeAbandonTransaction(ddeInstance, hConv, ddeResult); - } else { - ddeReturn = DdeClientTransaction((LPBYTE) ddeData, 0xFFFFFFFF, - hConv, 0, (flags & DDE_FLAG_BINARY) ? CF_TEXT : CF_UNICODETEXT, XTYP_EXECUTE, 30000, NULL); - if (ddeReturn == 0) { - SetDdeError(interp); - result = TCL_ERROR; - } - } - DdeFreeDataHandle(ddeData); - } else { - SetDdeError(interp); - result = TCL_ERROR; - } - Tcl_DStringFree(&dsBuf); + (DWORD) dataLength, 0, 0, Format(flags), 0); + if (!ddeData) { + goto ddeError; + } + + if (flags & DDE_FLAG_ASYNC) { + DdeClientTransaction((LPBYTE) ddeData, 0xFFFFFFFF, hConv, 0, + Format(flags), XTYP_EXECUTE, TIMEOUT_ASYNC, &ddeResult); + DdeAbandonTransaction(ddeInstance, hConv, ddeResult); + } else { + ddeReturn = DdeClientTransaction((LPBYTE) ddeData, 0xFFFFFFFF, + hConv, 0, Format(flags), XTYP_EXECUTE, 30000, NULL); + if (!ddeReturn) { + DdeFreeDataHandle(ddeData); + goto ddeError; + } + } + DdeFreeDataHandle(ddeData); break; } case DDE_REQUEST: { const WCHAR *itemString; const char *src; + DWORD len; + WCHAR *dataString; + Tcl_Obj *returnObjPtr; src = Tcl_GetStringFromObj(objv[firstArg + 2], &length); - Tcl_DStringInit(&itemBuf); itemString = Tcl_UtfToWCharDString(src, length, &itemBuf); length = Tcl_DStringLength(&itemBuf) / sizeof(WCHAR); if (length == 0) { - Tcl_SetObjResult(interp, - Tcl_NewStringObj("cannot request value of null data", -1)); + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "cannot request value of null data", TCL_AUTO_LENGTH)); Tcl_SetErrorCode(interp, "TCL", "DDE", "NULL", (char *)NULL); result = TCL_ERROR; goto cleanup; } hConv = DdeConnect(ddeInstance, ddeService, ddeTopic, NULL); DdeFreeStringHandle(ddeInstance, ddeService); DdeFreeStringHandle(ddeInstance, ddeTopic); - - if (hConv == NULL) { - SetDdeError(interp); - result = TCL_ERROR; - } else { - Tcl_Obj *returnObjPtr; - ddeItem = DdeCreateStringHandleW(ddeInstance, itemString, - CP_WINUNICODE); - if (ddeItem != NULL) { - ddeData = DdeClientTransaction(NULL, 0, hConv, ddeItem, - (flags & DDE_FLAG_BINARY) ? CF_TEXT : CF_UNICODETEXT, XTYP_REQUEST, 5000, NULL); - if (ddeData == NULL) { - SetDdeError(interp); - result = TCL_ERROR; - } else { - DWORD tmp; - WCHAR *dataString = (WCHAR *) DdeAccessData(ddeData, &tmp); - - if (flags & DDE_FLAG_BINARY) { - returnObjPtr = - Tcl_NewByteArrayObj((BYTE *) dataString, tmp); - } else { - Tcl_DString dsBuf; - - if ((tmp >= sizeof(WCHAR)) - && !dataString[tmp / sizeof(WCHAR) - 1]) { - tmp -= (DWORD)sizeof(WCHAR); - } - Tcl_DStringInit(&dsBuf); - Tcl_WCharToUtfDString(dataString, tmp>>1, &dsBuf); - returnObjPtr = - Tcl_NewStringObj(Tcl_DStringValue(&dsBuf), - Tcl_DStringLength(&dsBuf)); - Tcl_DStringFree(&dsBuf); - } - DdeUnaccessData(ddeData); - DdeFreeDataHandle(ddeData); - Tcl_SetObjResult(interp, returnObjPtr); - } - } else { - SetDdeError(interp); - result = TCL_ERROR; - } - } + if (!hConv) { + goto ddeError; + } + + ddeItem = DdeCreateStringHandleW(ddeInstance, itemString, + CP_WINUNICODE); + if (!ddeItem) { + goto ddeError; + } + ddeData = DdeClientTransaction(NULL, 0, hConv, ddeItem, + Format(flags), XTYP_REQUEST, 5000, NULL); + if (!ddeData) { + goto ddeError; + } + + dataString = (WCHAR *) DdeAccessData(ddeData, &len); + + if (flags & DDE_FLAG_BINARY) { + returnObjPtr = Tcl_NewByteArrayObj((BYTE *) dataString, len); + } else { + if ((len >= sizeof(WCHAR)) + && !dataString[len / sizeof(WCHAR) - 1]) { + len -= (DWORD) sizeof(WCHAR); + } + Tcl_WCharToUtfDString(dataString, len / sizeof(WCHAR), &dsBuf); + returnObjPtr = DStringToObj(&dsBuf); + } + DdeUnaccessData(ddeData); + DdeFreeDataHandle(ddeData); + Tcl_SetObjResult(interp, returnObjPtr); break; } case DDE_POKE: { - Tcl_DString dsBuf; const WCHAR *itemString; BYTE *dataString; - const char *src; + const char *src = Tcl_GetStringFromObj(objv[firstArg + 2], &length); - src = Tcl_GetStringFromObj(objv[firstArg + 2], &length); - Tcl_DStringInit(&itemBuf); itemString = Tcl_UtfToWCharDString(src, length, &itemBuf); length = Tcl_DStringLength(&itemBuf) / sizeof(WCHAR); if (length == 0) { - Tcl_SetObjResult(interp, - Tcl_NewStringObj("cannot have a null item", -1)); + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "cannot have a null item", TCL_AUTO_LENGTH)); Tcl_SetErrorCode(interp, "TCL", "DDE", "NULL", (char *)NULL); result = TCL_ERROR; goto cleanup; } - Tcl_DStringInit(&dsBuf); if (flags & DDE_FLAG_BINARY) { dataString = (BYTE *) Tcl_GetByteArrayFromObj(objv[firstArg + 3], &length); } else { - const char *data = - Tcl_GetStringFromObj(objv[firstArg + 3], &length); - Tcl_DStringInit(&dsBuf); + const char *data = Tcl_GetStringFromObj(objv[firstArg + 3], + &length); dataString = (BYTE *) Tcl_UtfToWCharDString(data, length, &dsBuf); length = Tcl_DStringLength(&dsBuf) + sizeof(WCHAR); } hConv = DdeConnect(ddeInstance, ddeService, ddeTopic, NULL); DdeFreeStringHandle(ddeInstance, ddeService); DdeFreeStringHandle(ddeInstance, ddeTopic); - - if (hConv == NULL) { - SetDdeError(interp); - result = TCL_ERROR; - } else { - ddeItem = DdeCreateStringHandleW(ddeInstance, itemString, - CP_WINUNICODE); - if (ddeItem != NULL) { - ddeData = DdeClientTransaction(dataString, (DWORD) length, - hConv, ddeItem, (flags & DDE_FLAG_BINARY) ? CF_TEXT : CF_UNICODETEXT, XTYP_POKE, 5000, NULL); - if (ddeData == NULL) { - SetDdeError(interp); - result = TCL_ERROR; - } - } else { - SetDdeError(interp); - result = TCL_ERROR; - } - } - Tcl_DStringFree(&dsBuf); + if (!hConv) { + goto ddeError; + } + + ddeItem = DdeCreateStringHandleW(ddeInstance, itemString, + CP_WINUNICODE); + if (!ddeItem) { + goto ddeError; + } + + ddeData = DdeClientTransaction(dataString, (DWORD) length, + hConv, ddeItem, Format(flags), XTYP_POKE, 5000, NULL); + if (!ddeData) { + goto ddeError; + } break; } case DDE_SERVICES: result = DdeGetServicesList(interp, serviceName, topicName); break; case DDE_EVAL: { RegisteredInterp *riPtr; - ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); - if (serviceName == NULL) { - Tcl_SetObjResult(interp, - Tcl_NewStringObj("invalid service name \"\"", -1)); + if (!serviceName) { + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "invalid service name \"\"", TCL_AUTO_LENGTH)); Tcl_SetErrorCode(interp, "TCL", "DDE", "NO_SERVER", (char *)NULL); result = TCL_ERROR; goto cleanup; } @@ -1753,27 +1824,19 @@ * producing a bytecode structure that refers to other objects owned * by the target interp. If the target interp is then deleted, the * bytecode structure would be referring to deallocated objects. */ - for (riPtr = tsdPtr->interpListPtr; riPtr != NULL; - riPtr = riPtr->nextPtr) { - if (_wcsicmp(serviceName, riPtr->name) == 0) { - break; - } - } - - if (riPtr != NULL) { - Tcl_Interp *sendInterp; - + riPtr = GetRegisteredInterp(serviceName); + if (riPtr) { /* - * This command is to a local interp. No need to go through the - * server. + * This command is to a local interp (current thread of current + * process). No need to go through the server. */ Tcl_Preserve(riPtr); - sendInterp = riPtr->interp; + Tcl_Interp *sendInterp = riPtr->interp; Tcl_Preserve(sendInterp); /* * Don't exchange objects between interps. The target interp would * compile an object, producing a bytecode structure that refers @@ -1780,15 +1843,15 @@ * to other objects owned by the target interp. If the target * interp is then deleted, the bytecode structure would be * referring to deallocated objects. */ - if (Tcl_IsSafe(riPtr->interp) && (riPtr->handlerPtr == NULL)) { - Tcl_SetObjResult(riPtr->interp, Tcl_NewStringObj( + if (Tcl_IsSafe(sendInterp) && !riPtr->handlerPtr) { + Tcl_SetObjResult(sendInterp, Tcl_NewStringObj( "permission denied: a handler procedure must be" - " defined for use in a safe interp", -1)); - Tcl_SetErrorCode(interp, "TCL", "DDE", "SECURITY_CHECK", + " defined for use in a safe interp", TCL_AUTO_LENGTH)); + Tcl_SetErrorCode(sendInterp, "TCL", "DDE", "SECURITY_CHECK", (char *)NULL); result = TCL_ERROR; } if (result == TCL_OK) { @@ -1795,11 +1858,11 @@ if (objc == 1) { objPtr = objv[0]; } else { objPtr = Tcl_ConcatObj(objc, objv); } - if (riPtr->handlerPtr != NULL) { + if (riPtr->handlerPtr) { /* add the dde request data to the handler proc list */ /* *result = Tcl_ListObjReplace(sendInterp, objPtr, 0, 0, 1, * &(riPtr->handlerPtr)); */ @@ -1839,30 +1902,25 @@ Tcl_SetObjResult(interp, Tcl_GetObjResult(sendInterp)); } Tcl_Release(riPtr); Tcl_Release(sendInterp); } else { - Tcl_DString dsBuf; + const char *string; /* * This is a non-local request. Send the script to the server and * poll it for a result. */ if (MakeDdeConnection(interp, serviceName, &hConv) != TCL_OK) { - invalidServerResponse: - Tcl_SetObjResult(interp, - Tcl_NewStringObj("invalid data returned from server", -1)); - Tcl_SetErrorCode(interp, "TCL", "DDE", "BAD_RESPONSE", (char *)NULL); - result = TCL_ERROR; - goto cleanup; + goto invalidServerResponse; } objPtr = Tcl_ConcatObj(objc, objv); string = Tcl_GetStringFromObj(objPtr, &length); - Tcl_DStringInit(&dsBuf); Tcl_UtfToWCharDString(string, length, &dsBuf); + Tcl_DecrRefCount(objPtr); string = Tcl_DStringValue(&dsBuf); length = Tcl_DStringLength(&dsBuf) + sizeof(WCHAR); ddeItemData = DdeCreateDataHandle(ddeInstance, (BYTE *) string, (DWORD) length, 0, 0, CF_UNICODETEXT, 0); Tcl_DStringFree(&dsBuf); @@ -1882,21 +1940,18 @@ ddeData = DdeClientTransaction(NULL, 0, hConv, ddeCookie, CF_UNICODETEXT, XTYP_REQUEST, 30000, NULL); } } - Tcl_DecrRefCount(objPtr); - if (ddeData == 0) { - SetDdeError(interp); - result = TCL_ERROR; - goto cleanup; + goto ddeError; } if (!(flags & DDE_FLAG_ASYNC)) { - Tcl_Obj *resultPtr; + Tcl_Obj *tuplePtr, **tuple; WCHAR *ddeDataString; + Tcl_Size tupleLen; /* * The return handle has a two or four element list in it. The * first element is the return code (TCL_OK, TCL_ERROR, etc.). * The second is the result of the script. If the return code @@ -1906,72 +1961,106 @@ */ length = DdeGetData(ddeData, NULL, 0, 0); ddeDataString = (WCHAR *) Tcl_Alloc(length); DdeGetData(ddeData, (BYTE *) ddeDataString, (DWORD) length, 0); - if (length > (Tcl_Size)sizeof(WCHAR)) { - length -= sizeof(WCHAR); - } - Tcl_DStringInit(&dsBuf); - Tcl_WCharToUtfDString(ddeDataString, length>>1, &dsBuf); - resultPtr = Tcl_NewStringObj(Tcl_DStringValue(&dsBuf), - Tcl_DStringLength(&dsBuf)); - Tcl_DStringFree(&dsBuf); - Tcl_Free((char *) ddeDataString); - - if (Tcl_ListObjIndex(NULL, resultPtr, 0, &objPtr) != TCL_OK) { - Tcl_DecrRefCount(resultPtr); - goto invalidServerResponse; - } - if (Tcl_GetIntFromObj(NULL, objPtr, &result) != TCL_OK) { - Tcl_DecrRefCount(resultPtr); - goto invalidServerResponse; - } - if (result == TCL_ERROR) { - Tcl_ResetResult(interp); - - if (Tcl_ListObjIndex(NULL, resultPtr, 3, - &objPtr) != TCL_OK) { - Tcl_DecrRefCount(resultPtr); - goto invalidServerResponse; - } - Tcl_AppendObjToErrorInfo(interp, objPtr); - - Tcl_ListObjIndex(NULL, resultPtr, 2, &objPtr); - Tcl_SetObjErrorCode(interp, objPtr); - } - if (Tcl_ListObjIndex(NULL, resultPtr, 1, &objPtr) != TCL_OK) { - Tcl_DecrRefCount(resultPtr); - goto invalidServerResponse; - } - Tcl_SetObjResult(interp, objPtr); - Tcl_DecrRefCount(resultPtr); - } - } - } + if (length > (Tcl_Size) sizeof(WCHAR)) { + length -= sizeof(WCHAR); + } + Tcl_WCharToUtfDString(ddeDataString, length / sizeof(WCHAR), + &dsBuf); + tuplePtr = DStringToObj(&dsBuf); + Tcl_Free((char *) ddeDataString); + + if (Tcl_ListObjGetElements(NULL, tuplePtr, + &tupleLen, &tuple) != TCL_OK + || (tupleLen < 1)) { + Tcl_DecrRefCount(tuplePtr); + goto invalidServerResponse; + } + if (Tcl_GetIntFromObj(NULL, tuple[0], &result) != TCL_OK) { + Tcl_DecrRefCount(tuplePtr); + goto invalidServerResponse; + } + /* + * TODO: transfer the whole result dictionary + */ + if (result == TCL_ERROR) { + /* + * Four elements to the tuple: + * resultCode (== TCL_ERROR), message, errorCode, errorInfo + */ + Tcl_ResetResult(interp); + if (tupleLen != 4) { + Tcl_DecrRefCount(tuplePtr); + goto invalidServerResponse; + } + + if (Tcl_ListObjLength(NULL, tuple[2], &length) != TCL_OK) { + Tcl_DecrRefCount(tuplePtr); + goto invalidServerResponse; + } else if (length > 0) { + Tcl_SetObjErrorCode(interp, objPtr); + } else { + objPtr = Tcl_NewStringObj("NONE", TCL_AUTO_LENGTH); + Tcl_IncrRefCount(objPtr); + Tcl_SetObjErrorCode(interp, objPtr); + Tcl_DecrRefCount(objPtr); + } + + Tcl_AppendObjToErrorInfo(interp, tuple[3]); + } else { + /* Two elements: resultCode (!= TCL_ERROR), message */ + if (tupleLen != 2) { + Tcl_DecrRefCount(tuplePtr); + goto invalidServerResponse; + } + } + Tcl_SetObjResult(interp, tuple[1]); + Tcl_DecrRefCount(tuplePtr); + } + } + break; + + } + default: + Tcl_Panic("unreachable case"); } cleanup: - if (ddeCookie != NULL) { + if (ddeCookie) { DdeFreeStringHandle(ddeInstance, ddeCookie); } - if (ddeItem != NULL) { + if (ddeItem) { DdeFreeStringHandle(ddeInstance, ddeItem); } - if (ddeItemData != NULL) { + if (ddeItemData) { DdeFreeDataHandle(ddeItemData); } - if (ddeData != NULL) { + if (ddeData) { DdeFreeDataHandle(ddeData); } - if (hConv != NULL) { + if (hConv) { DdeDisconnect(hConv); } + Tcl_DStringFree(&dsBuf); Tcl_DStringFree(&itemBuf); Tcl_DStringFree(&topicBuf); Tcl_DStringFree(&serviceBuf); return result; + + ddeError: + SetDdeError(interp); + result = TCL_ERROR; + goto cleanup; + + invalidServerResponse: + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "invalid data returned from server", TCL_AUTO_LENGTH)); + Tcl_SetErrorCode(interp, "TCL", "DDE", "BAD_RESPONSE", (char *)NULL); + result = TCL_ERROR; + goto cleanup; } /* * Local variables: * mode: c