Attachment "sebres-3.4-patch3.patch" to
ticket [3161787fff]
added by
sebres
2012-04-11 17:16:40.
Index: generic/itcl_bicmds.c
===================================================================
--- generic/itcl_bicmds.c (revision 1)
+++ generic/itcl_bicmds.c (working copy)
@@ -465,9 +465,8 @@
Tcl_DStringSetLength(&buffer, 0);
Tcl_DStringAppend(&buffer, (lastval) ? lastval : "", -1);
- token = Tcl_GetStringFromObj(objv[i+1], (int*)NULL);
-
- if (Tcl_SetVar2(interp, member->fullname, (char*)NULL, token,
+ // [SB] set obj, to prevent loss of obj type ...
+ if (Tcl_SetVar2Ex(interp, member->fullname, (char*)NULL, objv[i+1],
TCL_LEAVE_ERR_MSG) == NULL) {
char msg[256];
@@ -545,7 +544,7 @@
ItclClass *contextClass;
ItclObject *contextObj;
- CONST char *name, *val;
+ CONST char *name; Tcl_Obj *val;
ItclVarLookup *vlookup;
Tcl_HashEntry *entry;
@@ -583,11 +582,11 @@
return TCL_ERROR;
}
- val = Itcl_GetInstanceVar(interp, vlookup->vdefn->member->fullname,
+ val = Itcl_GetInstanceVarObj(interp, vlookup->vdefn->member->fullname,
contextObj, contextObj->classDefn);
if (val) {
- Tcl_SetObjResult(interp, Tcl_NewStringObj(val, -1));
+ Tcl_SetObjResult(interp, val);
} else {
Tcl_SetObjResult(interp, Tcl_NewStringObj("<undefined>", -1));
}
@@ -643,8 +642,8 @@
Tcl_DStringFree(&optName);
- if (vdefn->init) {
- objPtr = Tcl_NewStringObj(vdefn->init, -1);
+ if (vdefn->initObj) {
+ objPtr = vdefn->initObj;
} else {
objPtr = Tcl_NewStringObj("<undefined>", -1);
}
@@ -1353,8 +1352,8 @@
objPtr = Tcl_NewStringObj("<objectName>", -1);
}
}
- else if (vlookup->vdefn->init) {
- objPtr = Tcl_NewStringObj(vlookup->vdefn->init, -1);
+ else if (vlookup->vdefn->initObj) {
+ objPtr = vlookup->vdefn->initObj;
}
else {
objPtr = Tcl_NewStringObj("<undefined>", -1);
Index: generic/itcl_class.c
===================================================================
--- generic/itcl_class.c (revision 1)
+++ generic/itcl_class.c (working copy)
@@ -910,6 +910,118 @@
/*
* ------------------------------------------------------------------------
+ * Itcl_HandleClassIntern()
+ *
+ * Special case to create object without call any constructor of self
+ * or inherited.
+ *
+ * ::itcl::struct <className> <objName>
+ *
+ * This procedure creates a new object named <objName> in the appropriate class.
+ * Note that if <objName> contains "#auto", that part is automatically replaced
+ * by a unique string built from the class name.
+ * ------------------------------------------------------------------------
+ */
+int
+Itcl_HandleClassIntern(
+ ClientData clientData, /* class definition */
+ Tcl_Interp *interp, /* current interpreter */
+ int objc, /* number of arguments */
+ Tcl_Obj *CONST objv[] /* argument objects */
+)
+{
+ ItclClass *cdefnPtr;
+ int result = TCL_OK;
+
+ Tcl_DString buffer; /* buffer used to build object names */
+ char *token, *objName, *match;
+
+ ItclObject *newObj;
+
+ if (objc != 3) {
+ Tcl_AppendResult(interp,
+ "wrong # args: should be \"::itcl::struct <className> <objName>\"",
+ NULL);
+ return TCL_ERROR;
+ }
+
+ // find class :
+ cdefnPtr = Itcl_FindClass(interp, Tcl_GetString(objv[1]), /* autoload */ 1);
+ if (cdefnPtr == NULL) {
+ return TCL_ERROR;
+ }
+
+ // obj name :
+ token = Tcl_GetString(objv[2]);
+
+ /*
+ * Create a new instance with that name.
+ * If the name contains "#auto", replace this with
+ * a uniquely generated string based on the class name.
+ */
+ Tcl_DStringInit(&buffer);
+ objName = token;
+ match = strstr(token, "#auto");
+ if (match != NULL) {
+ int len;
+ char unique[TCL_INTEGER_SPACE]; /* for unique part of object names */
+ Tcl_CmdInfo dummy;
+ Tcl_UniChar ch;
+
+ Tcl_DStringAppend(&buffer, token, (match - token));
+
+ /*
+ * Only lowercase the first char of $class, per itcl #auto semantics
+ */
+ len = Tcl_UtfToUniChar(cdefnPtr->name, &ch);
+ ch = Tcl_UniCharToLower(ch);
+ Tcl_UniCharToUtfDString(&ch, 1, &buffer);
+ Tcl_DStringAppend(&buffer, cdefnPtr->name + len, -1);
+
+ /*
+ * Substitute a unique part in for "#auto", and keep
+ * incrementing a counter until a valid name is found.
+ */
+ len = Tcl_DStringLength(&buffer);
+ do {
+ sprintf(unique, "%d", cdefnPtr->unique++);
+
+ Tcl_DStringTrunc(&buffer, len);
+ Tcl_DStringAppend(&buffer, unique, -1);
+ Tcl_DStringAppend(&buffer, match+5, -1);
+
+ objName = Tcl_DStringValue(&buffer);
+
+ /*
+ * [Fix 227811] Check for any command with the given name, not
+ * only objects.
+ */
+
+ if (Tcl_GetCommandInfo (interp, objName, &dummy) == 0) {
+ break; /* if an error is found, bail out! */
+ }
+ } while (1);
+ }
+
+ /*
+ * Try to create a new object. If successful, return the
+ * object name as the result of this command.
+ * -1 for objc - special case wo constructor ...
+ */
+ result = Itcl_CreateObject(interp, objName, cdefnPtr,
+ -1, objv, &newObj);
+
+ if (result == TCL_OK) {
+ Tcl_SetObjResult(interp, Tcl_NewStringObj(objName, -1));
+ }
+
+ Tcl_DStringFree(&buffer);
+ return result;
+}
+
+
+/*
+ * ------------------------------------------------------------------------
* Itcl_ClassCmdResolver()
*
* Used by the class namespaces to handle name resolution for all
@@ -1590,10 +1702,12 @@
}
if (init) {
- vdefn->init = (char*)ckalloc((unsigned)(strlen(init)+1));
- strcpy(vdefn->init, init);
+ vdefn->initObj=Tcl_NewStringObj(init,-1);
+ vdefn->init=Tcl_GetString(vdefn->initObj);
+ Tcl_IncrRefCount(vdefn->initObj);
}
else {
+ vdefn->initObj = NULL;
vdefn->init = NULL;
}
@@ -1617,8 +1731,8 @@
{
Itcl_DeleteMember(vdefn->member);
- if (vdefn->init) {
- ckfree(vdefn->init);
+ if (vdefn->initObj) {
+ Tcl_DecrRefCount(vdefn->initObj);
}
ckfree((char*)vdefn);
}
Index: generic/itcl_cmds.c
===================================================================
--- generic/itcl_cmds.c (revision 1)
+++ generic/itcl_cmds.c (working copy)
@@ -307,6 +307,10 @@
Itcl_PreserveData((ClientData)info);
+ // add builtin command to create object without constructor
+ // (unserialize purposes)
+ Tcl_CreateObjCommand(interp, "::itcl::struct", Itcl_HandleClassIntern,
+ (ClientData)NULL, (Tcl_CmdDeleteProc*)NULL);
/*
* Add "code" and "scope" commands for handling scoped values.
*/
@@ -1603,7 +1607,7 @@
* "namespace inscope <namesp> <command>". If it is,
* decode it.
*/
- if (Itcl_DecodeScopedCommand(interp, name, &contextNs, &cmdName)
+ if (itclDecodeScopedCommand(interp, name, &contextNs, &cmdName)
!= TCL_OK) {
return TCL_ERROR;
}
@@ -1637,7 +1641,6 @@
* Got this far, so assume that it is a valid object
*/
Tcl_SetObjResult(interp, Tcl_NewBooleanObj(1));
- ckfree(cmdName);
return TCL_OK;
}
@@ -1685,7 +1688,7 @@
* "namespace inscope <namesp> <command>". If it is,
* decode it.
*/
- if (Itcl_DecodeScopedCommand(interp, name, &contextNs, &cname) != TCL_OK) {
+ if (itclDecodeScopedCommand(interp, name, &contextNs, &cname) != TCL_OK) {
return TCL_ERROR;
}
@@ -1701,8 +1704,6 @@
Tcl_SetObjResult(interp, Tcl_NewBooleanObj(0));
}
- ckfree(cname);
-
return TCL_OK;
} /* end Itcl_IsClassCmd function */
Index: generic/itcl_methods.c
===================================================================
--- generic/itcl_methods.c (revision 1)
+++ generic/itcl_methods.c (working copy)
@@ -2424,6 +2424,78 @@
/*
* ------------------------------------------------------------------------
+ * Itcl_InvokeMethodHashEntry()
+ *
+ * Looks for a particular method in the specified class. If the
+ * method is found, it is invoked with the given arguments. Any
+ * protection level (protected/private) for the method is ignored.
+ * If the method does not exist, this procedure does nothing.
+ *
+ * This procedure is used primarily to invoke the constructor/destructor
+ * when an object is created/destroyed.
+ *
+ * Returns TCL_OK on success; otherwise, this procedure returns
+ * TCL_ERROR along with an error message in the interpreter.
+ * ------------------------------------------------------------------------
+ */
+int
+Itcl_InvokeMethodHashEntry(interp, entry, contextClass, contextObj, objc, objv)
+ Tcl_Interp *interp; /* interpreter */
+ Tcl_HashEntry *entry; /* hash entry of method */
+ ItclClass *contextClass; /* current class being constructed */
+ ItclObject *contextObj; /* object being constructed */
+ int objc; /* number of arguments */
+ Tcl_Obj *CONST objv[]; /* argument objects */
+{
+ int result = TCL_OK;
+
+ ItclMemberFunc *mfunc;
+ ItclMember *member;
+ Tcl_Obj *cmdlinePtr;
+ int cmdlinec;
+ Tcl_Obj **cmdlinev;
+
+ /*
+ * Scan through the list of base classes and see if any of these
+ * have not been constructed. Invoke base class constructors
+ * implicitly, as needed. Go through the list of base classes
+ * in reverse order, so that least-specific classes are constructed
+ * first.
+ */
+ CONST char * name = entry->key.string;
+
+ mfunc = (ItclMemberFunc*)Tcl_GetHashValue(entry);
+ member = mfunc->member;
+
+ /*
+ * Prepend the method name to the list of arguments.
+ */
+ cmdlinePtr = Itcl_CreateArgs(interp, entry->key.string, objc, objv);
+
+ (void) Tcl_ListObjGetElements((Tcl_Interp*)NULL, cmdlinePtr,
+ &cmdlinec, &cmdlinev);
+
+ /*
+ * Execute the code for the method. Be careful to protect
+ * the method in case it gets deleted during execution.
+ */
+ Itcl_PreserveData((ClientData)mfunc);
+
+ result = Itcl_EvalMemberCode(interp, mfunc, member,
+ contextObj, cmdlinec, cmdlinev);
+
+ result = Itcl_ReportFuncErrors(interp, mfunc,
+ contextObj, result);
+
+ Itcl_ReleaseData((ClientData)mfunc);
+ Tcl_DecrRefCount(cmdlinePtr);
+
+ return result;
+}
+
+
+/*
+ * ------------------------------------------------------------------------
* Itcl_ReportFuncErrors()
*
* Used to interpret the status code returned when the body of a
Index: generic/itcl_migrate.c
===================================================================
--- generic/itcl_migrate.c (revision 1)
+++ generic/itcl_migrate.c (working copy)
@@ -122,7 +122,7 @@
Var *
_TclNewVar()
{
- Var *varPtr;
+ register Var *varPtr;
varPtr = (Var *) ckalloc(itclVarLocalSize);
ItclInitVarFlags(varPtr);
@@ -143,7 +143,7 @@
#if ITCL_TCL_PRE_8_5
Var *
ItclVarHashCreateVar(
- TclVarHashTable *tablePtr,
+ ITclVarHashTable *tablePtr,
const char *key,
int *newPtr)
{
Index: generic/itcl_objects.c
===================================================================
--- generic/itcl_objects.c (revision 1)
+++ generic/itcl_objects.c (working copy)
@@ -148,6 +148,7 @@
newObj->dataSize = cdefnPtr->numInstanceVars;
newObj->data = (Var**)ckalloc((unsigned)(newObj->dataSize*sizeof(Var*)));
+ // constructed table to listen all constructors of object :
newObj->constructed = (Tcl_HashTable*)ckalloc(sizeof(Tcl_HashTable));
Tcl_InitHashTable(newObj->constructed, TCL_STRING_KEYS);
newObj->destructed = NULL;
@@ -166,7 +167,6 @@
Itcl_EventuallyFree((ClientData)newObj, ItclFreeObject);
Tcl_DStringFree(&buffer);
- Tcl_DStringFree(&objName);
/*
* Install the class namespace and object context so that
@@ -176,7 +176,10 @@
if (Itcl_PushContext(interp, (ItclMember*)NULL, cdefnPtr, newObj,
&context) != TCL_OK) {
+ Tcl_DStringFree(&objName);
+
return TCL_ERROR;
+
}
Itcl_InitHierIter(&hier, cdefn);
@@ -189,9 +192,10 @@
if ((vdefn->member->flags & ITCL_THIS_VAR) != 0) {
if (cdPtr == cdefnPtr) {
ItclCreateObjVar(interp, vdefn, newObj);
- Tcl_SetVar2(interp, "this", (char*)NULL, "", 0);
- Tcl_TraceVar2(interp, "this", NULL,
- TCL_TRACE_READS|TCL_TRACE_WRITES, ItclTraceThisVar,
+ Tcl_SetVar2(interp, "this", (const char*)NULL,
+ Tcl_DStringValue(&objName), 0);
+ Tcl_TraceVar2(interp, "this", (const char*)NULL,
+ TCL_TRACE_WRITES, ItclTraceThisVar,
(ClientData)newObj);
}
}
@@ -204,8 +208,17 @@
}
Itcl_DeleteHierIter(&hier);
+ Tcl_DStringFree(&objName);
+
Itcl_PopContext(interp, &context); /* back to calling context */
+ // special case for unserialize (objc = -1)
+ // don't call any constructor of object :
+ if (objc == -1) {
+ result = TCL_OK;
+ goto wo_constructor;
+ }
+
/*
* Now construct the object. Look for a constructor in the
* most-specific class, and if there is one, invoke it.
@@ -215,15 +228,17 @@
* not called out explicitly in "initCode" code fragments are
* invoked implicitly without arguments.
*/
- result = Itcl_InvokeMethodIfExists(interp, "constructor",
+ entry = Tcl_FindHashEntry(&cdefn->functions, "constructor");
+ if (entry) {
+ result = Itcl_InvokeMethodHashEntry(interp, entry,
cdefn, newObj, objc, objv);
+ } else {
/*
* If there is no constructor, construct the base classes
* in case they have constructors. This will cause the
* same chain reaction.
*/
- if (!Tcl_FindHashEntry(&cdefn->functions, "constructor")) {
result = Itcl_ConstructBase(interp, newObj, cdefn);
}
@@ -249,6 +264,8 @@
result = Itcl_RestoreInterpState(interp, istate);
}
+wo_constructor:
+
/*
* At this point, the object is fully constructed.
* Destroy the "constructed" table in the object data, since
@@ -443,7 +460,8 @@
result = Itcl_InvokeMethodIfExists(interp, "destructor",
contextClass, contextObj, 0, (Tcl_Obj* CONST*)NULL);
- if (result != TCL_OK) {
+ if ((result != TCL_OK)
+ &&((flags & ITCL_IGNORE_ERRS) == 0)) {
return TCL_ERROR;
}
}
@@ -502,7 +520,7 @@
* "namespace inscope <namesp> <command>". If it is,
* decode it.
*/
- if (Itcl_DecodeScopedCommand(interp, name, &contextNs, &cmdName)
+ if (itclDecodeScopedCommand(interp, name, &contextNs, &cmdName)
!= TCL_OK) {
return TCL_ERROR;
}
@@ -520,8 +538,6 @@
*roPtr = NULL;
}
- ckfree(cmdName);
-
return TCL_OK;
}
@@ -675,9 +691,15 @@
* callframe refered to by 'framePtr' will be inconsistent
* ('isProcCallFrame' set, but 'procPtr' not set).
*/
- if (*token == 'i' && strcmp(token,"info") == 0) {
+
+ /*
+ * this error happens also by call of another functions (as info) *1!!!
+ *
+ */
+
+//*1!!! if (*token == 'i' && strcmp(token,"info") == 0) {
framePtr->isProcCallFrame = 0;
- }
+//*1!!! }
result = Itcl_EvalArgs(interp, objc-1, objv+1);
@@ -740,8 +762,60 @@
return val;
}
+/*
+ * ------------------------------------------------------------------------
+ * Itcl_GetInstanceVarObj()
+ *
+ * Returns the current value for an object data member. The member
+ * name is interpreted with respect to the given class scope, which
+ * is usually the most-specific class for the object.
+ *
+ * If successful, this procedure returns a pointer to a string value
+ * which remains alive until the variable changes it value. If
+ * anything goes wrong, this returns NULL.
+ * ------------------------------------------------------------------------
+ */
+Tcl_Obj*
+Itcl_GetInstanceVarObj(interp, name, contextObj, contextClass)
+ Tcl_Interp *interp; /* current interpreter */
+ CONST char *name; /* name of desired instance variable */
+ ItclObject *contextObj; /* current object */
+ ItclClass *contextClass; /* name is interpreted in this scope */
+{
+ ItclContext context;
+ Tcl_Obj *val;
/*
+ * Make sure that the current namespace context includes an
+ * object that is being manipulated.
+ */
+ if (contextObj == NULL) {
+ Tcl_ResetResult(interp);
+ Tcl_SetResult(interp,
+ "cannot access object-specific info without an object context",
+ TCL_STATIC);
+ return NULL;
+ }
+
+ /*
+ * Install the object context and access the data member
+ * like any other variable.
+ */
+ if (Itcl_PushContext(interp, (ItclMember*)NULL, contextClass,
+ contextObj, &context) != TCL_OK) {
+
+ return NULL;
+ }
+
+ val = Tcl_GetVar2Ex(interp, (CONST84 char *)name, (char*)NULL,
+ TCL_LEAVE_ERR_MSG);
+ Itcl_PopContext(interp, &context);
+
+ return val;
+}
+
+
+/*
* ------------------------------------------------------------------------
* ItclReportObjectUsage()
*
@@ -1112,12 +1186,12 @@
* owns the variable, so that we don't have any trouble
* accessing it.
*/
- if (vdefn->init) {
+ if (vdefn->initObj) {
if (Itcl_PushContext(interp, (ItclMember*)NULL,
vdefn->member->classDefn, contextObj, &context) == TCL_OK) {
- Tcl_SetVar2(interp, vdefn->member->fullname,
- (char*)NULL, vdefn->init, 0);
+ Tcl_SetVar2Ex(interp, vdefn->member->fullname,
+ (char*)NULL, vdefn->initObj, 0);
Itcl_PopContext(interp, &context);
}
}
@@ -1196,7 +1270,8 @@
* Look for the command representing the object and extract
* the object context.
*/
- if (!Tcl_GetCommandInfo(interp, namev[1], &cmdInfo)) {
+ if (!Tcl_GetCommandInfo(interp, namev[1], &cmdInfo)
+ || cmdInfo.objProc != Itcl_HandleInstance) {
if (errs) {
Tcl_AppendResult(errs,
"can't resolve scoped variable \"", name, "\": ",
@@ -1225,7 +1300,13 @@
}
vlookup = (ItclVarLookup*)Tcl_GetHashValue(entry);
+ if ((vlookup->vdefn->member->flags & ITCL_COMMON) == 0) {
+ // context variable :
*rPtr = (Tcl_Var) contextObj->data[vlookup->var.index];
+ } else {
+ // common variable :
+ *rPtr = vlookup->var.common;
+ }
ckfree((char*)namev);
return TCL_OK;
Index: generic/itcl_parse.c
===================================================================
--- generic/itcl_parse.c (revision 1)
+++ generic/itcl_parse.c (working copy)
@@ -647,7 +647,8 @@
if (objc == 3) {
body = Tcl_GetString(objv[2]);
} else {
- cdefnPtr->initCode = Tcl_DuplicateObj(objv[2]);
+ //cdefnPtr->initCode = Tcl_DuplicateObj(objv[2]);
+ cdefnPtr->initCode = objv[2];
Tcl_IncrRefCount(cdefnPtr->initCode);
body = Tcl_GetString(objv[3]);
}
Index: generic/itcl_util.c
===================================================================
--- generic/itcl_util.c (revision 1)
+++ generic/itcl_util.c (working copy)
@@ -33,6 +33,7 @@
*/
static Itcl_ListElem *listPool = NULL;
static int listPoolLen = 0;
+TCL_DECLARE_MUTEX(ItclListPoolLock)
#define ITCL_VALID_LIST 0x01face10 /* magic bit pattern for validation */
#define ITCL_LIST_POOL_SIZE 200 /* max number of elements in listPool */
@@ -68,6 +69,7 @@
#define TCL_STATE_VALID 0x01233210 /* magic bit pattern for validation */
+
/*
* ------------------------------------------------------------------------
* Itcl_Assert()
@@ -276,12 +278,15 @@
{
Itcl_ListElem *elemPtr;
+ Tcl_MutexLock(&ItclListPoolLock);
if (listPoolLen > 0) {
elemPtr = listPool;
listPool = elemPtr->next;
--listPoolLen;
+ Tcl_MutexUnlock(&ItclListPoolLock);
}
else {
+ Tcl_MutexUnlock(&ItclListPoolLock);
elemPtr = (Itcl_ListElem*)ckalloc((unsigned)sizeof(Itcl_ListElem));
}
elemPtr->owner = listPtr;
@@ -324,12 +329,15 @@
listPtr->tail = elemPtr->prev;
--listPtr->num;
+ Tcl_MutexLock(&ItclListPoolLock);
if (listPoolLen < ITCL_LIST_POOL_SIZE) {
elemPtr->next = listPool;
listPool = elemPtr;
++listPoolLen;
+ Tcl_MutexUnlock(&ItclListPoolLock);
}
else {
+ Tcl_MutexUnlock(&ItclListPoolLock);
ckfree((char*)elemPtr);
}
return nextPtr;
@@ -1244,8 +1252,8 @@
/*
* ------------------------------------------------------------------------
- * Itcl_DecodeScopedCommand()
- *
+ * itclDecodeScopedCommand()
+ * for INTERN USE ONLY, see for EXTERN USE Itcl_DecodeScopedCommand.
* Decodes a scoped command of the form:
*
* namespace inscope <namesp> <command>
@@ -1259,23 +1267,26 @@
* the interpreter.
* ------------------------------------------------------------------------
*/
+// [SB] cause rCmdPtr could point to const "static" value (name or 3th element of list as string representation)
+// we will use INTERN itclDecodeScopedCommand that rCmdPtr variable should not be freed (with ckfree).
+// The Itcl_DecodeScopedCommand works as specified in 3.4 ChangeLog :
+// - Needed to fix usage of Itcl_DecodeScopedCommand as rCmdPtr always
+// needs to be freed.
int
-Itcl_DecodeScopedCommand(interp, name, rNsPtr, rCmdPtr)
+itclDecodeScopedCommand(interp, name, rNsPtr, rCmdPtr)
Tcl_Interp *interp; /* current interpreter */
CONST char *name; /* string to be decoded */
Tcl_Namespace **rNsPtr; /* returns: namespace for scoped value */
char **rCmdPtr; /* returns: simple command word */
{
Tcl_Namespace *nsPtr = NULL;
- char *cmdName;
+ char *cmdName = (char *)name;
int len = strlen(name);
- CONST char *pos;
+
+ char *pos;
int listc, result;
- CONST char **listv;
+ const char **listv;
- cmdName = ckalloc((unsigned)strlen(name)+1);
- strcpy(cmdName, name);
-
if ((*name == 'n') && (len > 17) && (strncmp(name, "namespace", 9) == 0)) {
for (pos = (name + 9); (*pos == ' '); pos++) {
/* empty body: skip over spaces */
@@ -1283,7 +1294,7 @@
if ((*pos == 'i') && ((pos + 7) <= (name + len))
&& (strncmp(pos, "inscope", 7) == 0)) {
- result = Tcl_SplitList(interp, name, &listc,
+ result = Tcl_SplitList(interp, (CONST84 char *)name, &listc,
&listv);
if (result == TCL_OK) {
if (listc != 4) {
@@ -1292,19 +1303,19 @@
"namespace inscope namesp command\"",
(char*)NULL);
result = TCL_ERROR;
- } else {
+ }
+ else {
nsPtr = Tcl_FindNamespace(interp, listv[2],
(Tcl_Namespace*)NULL, TCL_LEAVE_ERR_MSG);
if (!nsPtr) {
result = TCL_ERROR;
- } else {
- ckfree(cmdName);
- cmdName = ckalloc((unsigned)(strlen(listv[3])+1));
- strcpy(cmdName, listv[3]);
}
+ else {
+ cmdName = listv[3];
}
}
+ }
ckfree((char*)listv);
if (result != TCL_OK) {
@@ -1321,7 +1332,41 @@
return TCL_OK;
}
+/*
+ * ------------------------------------------------------------------------
+ * Itcl_DecodeScopedCommand()
+ *
+ * Decodes a scoped command of the form:
+ *
+ * namespace inscope <namesp> <command>
+ *
+ * If the given string is not a scoped value, this procedure does
+ * nothing and returns TCL_OK. If the string is a scoped value,
+ * then it is decoded, and the namespace, and the simple command
+ * string are returned as arguments; the simple command should
+ * be freed when no longer in use. If anything goes wrong, this
+ * procedure returns TCL_ERROR, along with an error message in
+ * the interpreter.
+ * ------------------------------------------------------------------------
+ */
+ // [SB] in OK fail Itcl_DecodeScopedCommand returns in rCmdPtr always a dynamically allocated string to be freed.
+int
+Itcl_DecodeScopedCommand(interp, name, rNsPtr, rCmdPtr)
+ Tcl_Interp *interp; /* current interpreter */
+ CONST char *name; /* string to be decoded */
+ Tcl_Namespace **rNsPtr; /* returns: namespace for scoped value */
+ char **rCmdPtr; /* returns: simple command word */
+{
+ char * cmdName;
+ int ret = itclDecodeScopedCommand(interp, name, rNsPtr, &cmdName);
+ if (ret == TCL_OK) {
+ *rCmdPtr = ckalloc((unsigned)(strlen(cmdName)+1));
+ strcpy(*rCmdPtr, cmdName);
+ }
+ return TCL_OK;
+}
+
/*
* ------------------------------------------------------------------------
* Itcl_EvalArgs()
Index: generic/itclInt.h
===================================================================
--- generic/itclInt.h (revision 1)
+++ generic/itclInt.h (working copy)
@@ -163,13 +163,13 @@
#define VarInHash Var
-#define TclVarHashTable Tcl_HashTable
+#define ITclVarHashTable Tcl_HashTable
typedef struct ItclShortVar {
int flags;
union {
Tcl_Obj *objPtr;
- TclVarHashTable *tablePtr;
+ ITclVarHashTable *tablePtr;
struct Var *linkPtr;
} value;
} ItclShortVar;
@@ -245,7 +245,7 @@
#define MODULE_SCOPE
#endif
-MODULE_SCOPE Var * ItclVarHashCreateVar (TclVarHashTable * tablePtr,
+MODULE_SCOPE Var * ItclVarHashCreateVar (ITclVarHashTable * tablePtr,
const char * key, int * newPtr);
#endif /* Version dependent defs and macros */
@@ -254,6 +254,13 @@
#define ItclVarHashFindVar(tablePtr, key) \
ItclVarHashCreateVar((tablePtr), (key), NULL)
+extern int
+itclDecodeScopedCommand(
+ Tcl_Interp *interp, /* current interpreter */
+ CONST char *name, /* string to be decoded */
+ Tcl_Namespace **rNsPtr, /* returns: namespace for scoped value */
+ char **rCmdPtr /* returns: simple command word */
+);
/*
* Common info for managing all known objects.
@@ -404,6 +411,7 @@
typedef struct ItclVarDefn {
ItclMember *member; /* basic member info */
char* init; /* initial value */
+ Tcl_Obj* initObj; /* initial value */
} ItclVarDefn;
/*
Index: generic/itclIntDecls.h
===================================================================
--- generic/itclIntDecls.h (revision 1)
+++ generic/itclIntDecls.h (working copy)
@@ -342,6 +342,11 @@
Tcl_Interp * interp, CONST char * name,
ItclObject * contextObj,
ItclClass * contextClass));
+/* 48a */
+TCL_EXTERN(Tcl_Obj*)Itcl_GetInstanceVarObj _ANSI_ARGS_((
+ Tcl_Interp * interp, CONST char * name,
+ ItclObject * contextObj,
+ ItclClass * contextClass));
#endif
#ifndef Itcl_ScopedVarResolver_TCL_DECLARED
#define Itcl_ScopedVarResolver_TCL_DECLARED
@@ -791,6 +796,20 @@
Tcl_Obj *CONST objv[]));
#endif
+// [SB] extended command :
+TCL_EXTERN(int) Itcl_InvokeMethodHashEntry _ANSI_ARGS_((
+ Tcl_Interp *interp, /* interpreter */
+ Tcl_HashEntry *entry, /* hash entry of method */
+ ItclClass *contextClass, /* current class being constructed */
+ ItclObject *contextObj, /* object being constructed */
+ int objc, /* number of arguments */
+ Tcl_Obj *CONST objv[] /* argument objects */
+));
+TCL_EXTERN(int) Itcl_HandleClassIntern _ANSI_ARGS_((ClientData clientData,
+ Tcl_Interp * interp, int objc,
+ Tcl_Obj *CONST objv[]));
+
+
typedef struct ItclIntStubs {
int magic;
struct ItclIntStubHooks *hooks;
