Tcl_Command
TclInitChanCmd(
Tcl_Interp *interp)
{
/*
* Most commands are plugged directly together, but some are done via
* alias-like rewriting; [chan configure] is this way for security reasons
* (want overwriting of [fconfigure] to control that nicely), and [chan
* names] because the functionality isn't available as a separate command
* function at the moment.
*/
static const EnsembleImplMap initMap[] = {
{"blocked", Tcl_FblockedObjCmd},
{"close", Tcl_CloseObjCmd},
{"copy", Tcl_FcopyObjCmd},
{"create", TclChanCreateObjCmd}, /* TIP #219 */
{"eof", Tcl_EofObjCmd},
{"event", Tcl_FileEventObjCmd},
{"flush", Tcl_FlushObjCmd},
{"gets", Tcl_GetsObjCmd},
{"pending", ChanPendingObjCmd}, /* TIP #287 */
{"postevent", TclChanPostEventObjCmd}, /* TIP #219 */
{"puts", Tcl_PutsObjCmd},
{"read", Tcl_ReadObjCmd},
{"seek", Tcl_SeekObjCmd},
{"tell", Tcl_TellObjCmd},
{"truncate", ChanTruncateObjCmd}, /* TIP #208 */
{NULL}
};
static const char *extras[] = {
"configure", "::fconfigure",
"names", "::file channels",
NULL
};
Tcl_Command ensemble;
Tcl_Obj *mapObj;
int i;
ensemble = TclMakeEnsemble(interp, "chan", initMap);
Tcl_GetEnsembleMappingDict(NULL, ensemble, &mapObj);
for (i=0 ; extras[i] ; i+=2) {
/*
* Can assume that reference counts are all incremented.
*/
Tcl_DictObjPut(NULL, mapObj, Tcl_NewStringObj(extras[i], -1),
Tcl_NewStringObj(extras[i+1], -1));
}
Tcl_SetEnsembleMappingDict(interp, ensemble, mapObj);
return ensemble;
}
/*
* ------------------------------------------------------------------------
* ItclFinishCmd()
*
* called when an interp is deleted to free up memory or called explicitly
* to check memory leaks
*
* ------------------------------------------------------------------------
*/
static int
ItclFinishCmd(
ClientData clientData, /* unused */
Tcl_Interp *interp, /* current interpreter */
int objc, /* number of arguments */
Tcl_Obj *const objv[]) /* argument objects */
{
Tcl_HashEntry *hPtr;
Tcl_HashSearch place;
Tcl_Namespace *nsPtr;
Tcl_Obj **newObjv;
Tcl_Obj *objPtr;
Tcl_Obj *ensObjPtr;
Tcl_Command cmdPtr;
Tcl_Obj *mapDict;
ItclObjectInfo *infoPtr;
ItclCmdsInfo *iciPtr;
int checkMemoryLeaks;
int i;
int result;
ItclShowArgs(1, "ItclFinishCmd", objc, objv);
result = TCL_OK;
infoPtr = Tcl_GetAssocData(interp, ITCL_INTERP_DATA, NULL);
if (infoPtr == NULL) {
infoPtr = (ItclObjectInfo *)clientData;
}
checkMemoryLeaks = 0;
if (objc > 1) {
if (strcmp(Tcl_GetString(objv[1]), "checkmemoryleaks") == 0) {
/* if we have that option, the namespace of the Tcl ensembles
* is not teared down, so we have to simulate it here to
* have the correct reference counts for infoPtr->infoVars2Ptr
* infoPtr->infoVars3Ptr and infoPtr->infoVars4Ptr
*/
checkMemoryLeaks = 1;
}
}
newObjv = (Tcl_Obj **)ckalloc(sizeof(Tcl_Obj *) * 2);
newObjv[0] = Tcl_NewStringObj("my", -1);;
for (i = 0; ;i++) {
iciPtr = &itclCmds[i];
if (iciPtr->name == NULL) {
break;
}
if ((iciPtr->flags & ITCL_IS_ENSEMBLE) == 0) {
result = Itcl_RenameCommand(interp, iciPtr->name, "");
} else {
objPtr = Tcl_NewStringObj(iciPtr->name, -1);
newObjv[1] = objPtr;
Itcl_EnsembleDeleteCmd(infoPtr, infoPtr->interp, 2, newObjv);
Tcl_DecrRefCount(objPtr);
}
iciPtr++;
}
Tcl_DecrRefCount(newObjv[0]);
ckfree((char *)newObjv);
/* remove the unknow handler, to free the reference to the
* Tcl_Obj with the name of it */
ensObjPtr = Tcl_NewStringObj("::itcl::builtin::Info::delegated", -1);
cmdPtr = Tcl_FindEnsemble(interp, ensObjPtr, TCL_LEAVE_ERR_MSG);
if (cmdPtr != NULL) {
Tcl_SetEnsembleUnknownHandler(NULL, cmdPtr, NULL);
}
Tcl_DecrRefCount(ensObjPtr);
while (1) {
hPtr = Tcl_FirstHashEntry(&infoPtr->instances, &place);
if (hPtr == NULL) {
break;
}
Tcl_DeleteHashEntry(hPtr);
}
Tcl_DeleteHashTable(&infoPtr->instances);
while (1) {
hPtr = Tcl_FirstHashEntry(&infoPtr->classTypes, &place);
if (hPtr == NULL) {
break;
}
Tcl_DeleteHashEntry(hPtr);
}
Tcl_DeleteHashTable(&infoPtr->classTypes);
nsPtr = Tcl_FindNamespace(interp, "::itcl::parser", NULL, 0);
if (nsPtr != NULL) {
Tcl_DeleteNamespace(nsPtr);
}
mapDict = NULL;
ensObjPtr = Tcl_NewStringObj("::itcl::builtin::Info", -1);
if (Tcl_FindNamespace(interp, Tcl_GetString(ensObjPtr), NULL, 0) != NULL) {
Tcl_SetEnsembleUnknownHandler(NULL,
Tcl_FindEnsemble(interp, ensObjPtr, TCL_LEAVE_ERR_MSG),
NULL);
}
Tcl_DecrRefCount(ensObjPtr);
/* remove the itclinfo and vars entry from the info dict */
/* and replace it by the original one */
cmdPtr = Tcl_FindCommand(interp, "info", NULL, TCL_GLOBAL_ONLY);
if (cmdPtr != NULL && Tcl_IsEnsemble(cmdPtr)) {
Tcl_GetEnsembleMappingDict(NULL, cmdPtr, &mapDict);
if (mapDict != NULL) {
objPtr = Tcl_NewStringObj("vars", -1);
Tcl_DictObjRemove(interp, mapDict, objPtr);
Tcl_DictObjPut(interp, mapDict, objPtr, infoPtr->infoVars4Ptr);
Tcl_DecrRefCount(objPtr);
objPtr = Tcl_NewStringObj("itclinfo", -1);
Tcl_DictObjRemove(interp, mapDict, objPtr);
Tcl_DecrRefCount(objPtr);
Tcl_SetEnsembleMappingDict(interp, cmdPtr, mapDict);
}
}
/* FIXME have to figure out why the refCount of
* ::itcl::builtin::Info
* and ::itcl::builtin::Info::vars and vars is 2 here !! */
/* seems to be as the tclOO commands are not yet deleted ?? */
Tcl_DecrRefCount(infoPtr->infoVars2Ptr);
Tcl_DecrRefCount(infoPtr->infoVars3Ptr);
Tcl_DecrRefCount(infoPtr->infoVars4Ptr);
if (checkMemoryLeaks) {
Tcl_DecrRefCount(infoPtr->infoVars2Ptr);
Tcl_DecrRefCount(infoPtr->infoVars3Ptr);
Tcl_DecrRefCount(infoPtr->infoVars4Ptr);
/* see comment above */
}
Tcl_DecrRefCount(infoPtr->typeDestructorArgumentPtr);
Tcl_EvalEx(infoPtr->interp,
"::oo::define ::itcl::clazz deletemethod unknown", -1, 0);
/* first have to look for the remaining memory leaks, then remove the next ifdef */
#ifdef LATER
Itcl_RenameCommand(infoPtr->interp, "::itcl::clazz", "");
/* tear down ::itcl namespace (this includes ::itcl::parser namespace) */
nsPtr = Tcl_FindNamespace(infoPtr->interp, "::itcl::parser", NULL, 0);
if (nsPtr != NULL) {
Tcl_DeleteNamespace(nsPtr);
}
nsPtr = Tcl_FindNamespace(infoPtr->interp, "::itcl::import", NULL, 0);
if (nsPtr != NULL) {
Tcl_DeleteNamespace(nsPtr);
}
nsPtr = Tcl_FindNamespace(infoPtr->interp, "::itcl::methodset", NULL, 0);
if (nsPtr != NULL) {
Tcl_DeleteNamespace(nsPtr);
}
nsPtr = Tcl_FindNamespace(infoPtr->interp, "::itcl::internal", NULL, 0);
if (nsPtr != NULL) {
Tcl_DeleteNamespace(nsPtr);
}
nsPtr = Tcl_FindNamespace(infoPtr->interp, "::itcl::builtin", NULL, 0);
if (nsPtr != NULL) {
Tcl_DeleteNamespace(nsPtr);
}
#endif
/* remove the unknown method from top class */
if (infoPtr->unknownNamePtr != NULL) {
Tcl_DecrRefCount(infoPtr->unknownNamePtr);
}
if (infoPtr->unknownArgumentPtr != NULL) {
Tcl_DecrRefCount(infoPtr->unknownArgumentPtr);
}
if (infoPtr->unknownBodyPtr != NULL) {
Tcl_DecrRefCount(infoPtr->unknownBodyPtr);
}
/* cleanup ensemble info */
ItclFinishEnsemble(infoPtr);
ckfree((char *)infoPtr->object_meta_type);
ckfree((char *)infoPtr->class_meta_type);
Itcl_DeleteStack(&infoPtr->clsStack);
Itcl_DeleteStack(&infoPtr->contextStack);
Itcl_DeleteStack(&infoPtr->constructorStack);
/* clean up list pool */
Itcl_FinishList();
Itcl_ReleaseData((ClientData)infoPtr);
return result;
}
