/*
 * ------------------------------------------------------------------------
 *      PACKAGE:  [incr Tcl]
 *  DESCRIPTION:  Object-Oriented Extensions to Tcl
 *
 *  [incr Tcl] provides object-oriented extensions to Tcl, much as
 *  C++ provides object-oriented extensions to C.  It provides a means
 *  of encapsulating related procedures together with their shared data
 *  in a local namespace that is hidden from the outside world.  It
 *  promotes code re-use through inheritance.  More than anything else,
 *  it encourages better organization of Tcl applications through the
 *  object-oriented paradigm, leading to code that is easier to
 *  understand and maintain.
 *
 *  This segment handles "objects" which are instantiated from class
 *  definitions.  Objects contain public/protected/private data members
 *  from all classes in a derivation hierarchy.
 *
 * ========================================================================
 *  AUTHOR:  Michael J. McLennan
 *           Bell Labs Innovations for Lucent Technologies
 *           mmclennan@lucent.com
 *           http://www.tcltk.com/itcl
 *
 *  overhauled version author: Arnulf Wiedemann Copyright (c) 2007
 * ========================================================================
 *           Copyright (c) 1993-1998  Lucent Technologies, Inc.
 * ------------------------------------------------------------------------
 * See the file "license.terms" for information on usage and redistribution
 * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
 */
#include <tclInt.h>
#include "itclInt.h"

/*
 *  FORWARD DECLARATIONS
 */
static char* ItclTraceThisVar(void *cdata, Tcl_Interp *interp,
	const char *name1, const char *name2, int flags);
static char* ItclTraceTypeVar(void *cdata, Tcl_Interp *interp,
	const char *name1, const char *name2, int flags);
static char* ItclTraceSelfVar(void *cdata, Tcl_Interp *interp,
	const char *name1, const char *name2, int flags);
static char* ItclTraceSelfnsVar(void *cdata, Tcl_Interp *interp,
	const char *name1, const char *name2, int flags);
static char* ItclTraceWinVar(void *cdata, Tcl_Interp *interp,
	const char *name1, const char *name2, int flags);
static char* ItclTraceOptionVar(void *cdata, Tcl_Interp *interp,
	const char *name1, const char *name2, int flags);
static char* ItclTraceComponentVar(void *cdata, Tcl_Interp *interp,
	const char *name1, const char *name2, int flags);
static char* ItclTraceItclHullVar(void *cdata, Tcl_Interp *interp,
	const char *name1, const char *name2, int flags);

static void ItclDestroyObject(void *clientData);
static void FreeObject(char *cdata);

static int ItclDestructBase(Tcl_Interp *interp, ItclObject *contextObj,
        ItclClass *contextClass, int flags);

static int ItclInitObjectVariables(Tcl_Interp *interp, ItclObject *ioPtr,
        ItclClass *iclsPtr);
static int ItclInitObjectCommands(Tcl_Interp *interp, ItclObject *ioPtr,
        ItclClass *iclsPtr, const char *name);
static int ItclInitExtendedClassOptions(Tcl_Interp *interp, ItclObject *ioPtr);
static int ItclInitObjectOptions(Tcl_Interp *interp, ItclObject *ioPtr,
        ItclClass *iclsPtr);
static const char * GetConstructorVar(Tcl_Interp *interp, ItclClass *iclsPtr,
        const char *varName);
static ItclClass * GetClassFromClassName(Tcl_Interp *interp,
	const char *className, ItclClass *iclsPtr);


/*
 * ------------------------------------------------------------------------
 *  ItclDeleteObjectMetadata()
 *
 *  Delete the metadata data if any
 *-------------------------------------------------------------------------
 */
void
ItclDeleteObjectMetadata(
    void *clientData)
{
    ItclObject *ioPtr = (ItclObject *)clientData;
    Tcl_HashEntry *hPtr;

    if (ioPtr == NULL) return;		/* Safety */
    if (ioPtr->oPtr == NULL) return;	/* Safety */

    hPtr = Tcl_FindHashEntry(&ioPtr->infoPtr->instances,
	(Tcl_GetObjectNamespace(ioPtr->oPtr))->fullName);

    if (hPtr == NULL) return;

    if (clientData != Tcl_GetHashValue(hPtr)) {
	Tcl_Panic("invalid instances entry");
    }
    Tcl_DeleteHashEntry(hPtr);
}

/*
 * ------------------------------------------------------------------------
 *  ObjectRenamedTrace()
 *
 * ------------------------------------------------------------------------
 */

static void
ObjectRenamedTrace(
    void *clientData,           /* The object being deleted. */
    TCL_UNUSED(Tcl_Interp *),   /* The interpreter containing the object. */
    TCL_UNUSED(const char *),   /* What the object was (last) called. */
    const char *newName,        /* Always NULL ??. not for itk!! */
    TCL_UNUSED(int))            /* Why was the object deleted? */
{
    ItclObject *ioPtr = (ItclObject *)clientData;
    Itcl_InterpState istate;

    if (newName != NULL) {
	/* FIXME should enter the new name in the hashtables for objects etc. */
        return;
    }
    if (ioPtr->flags & ITCL_OBJECT_CLASS_DESTRUCTED) {
        return;
    }
    ioPtr->flags |= ITCL_OBJECT_IS_RENAMED;
    if (ioPtr->flags & ITCL_TCLOO_OBJECT_IS_DELETED) {
        ioPtr->oPtr = NULL;
    }
    if (!(ioPtr->flags & ITCL_OBJECT_CLASS_DESTRUCTED)) {
        /*
         *  Attempt to destruct the object, but ignore any errors.
         */
        istate = Itcl_SaveInterpState(ioPtr->interp, 0);
        Itcl_DestructObject(ioPtr->interp, ioPtr, ITCL_IGNORE_ERRS);
        Itcl_RestoreInterpState(ioPtr->interp, istate);
        ioPtr->flags |= ITCL_OBJECT_CLASS_DESTRUCTED;
    }
}

/*
 * ------------------------------------------------------------------------
 *  Itcl_CreateObject()
 *
 */
int
Itcl_CreateObject(
    Tcl_Interp *interp,      /* interpreter mananging new object */
    const char* name,        /* name of new object */
    ItclClass *iclsPtr,      /* class for new object */
    Tcl_Size objc,          /* number of arguments */
    Tcl_Obj *const objv[],   /* argument objects */
    ItclObject **rioPtr)     /* the created object */
{
    int result;
    ItclObjectInfo * infoPtr;

    result = ItclCreateObject(interp, name, iclsPtr, objc, objv);
    if (result == TCL_OK) {
        if (!(iclsPtr->flags & (ITCL_TYPE|ITCL_WIDGET|ITCL_WIDGETADAPTOR))) {
            Tcl_ResetResult(interp);
            Tcl_AppendResult(interp, name, NULL);
        }
    }
    if (rioPtr != NULL) {
        if (result == TCL_OK) {
            infoPtr = (ItclObjectInfo *)Tcl_GetAssocData(interp,
			                    ITCL_INTERP_DATA, NULL);
            *rioPtr = infoPtr->lastIoPtr;
	} else {
            *rioPtr = NULL;
	}
    }
    return result;
}

/*
 * ------------------------------------------------------------------------
 *  ItclCreateObject()
 *
 *  Creates a new object instance belonging to the given class.
 *  Supports complex object names like "namesp::namesp::name" by
 *  following the namespace path and creating the object in the
 *  desired namespace.
 *
 *  Automatically creates and initializes data members, including the
 *  built-in protected "this" variable containing the object name.
 *  Installs an access command in the current namespace, and invokes
 *  the constructor to initialize the object.
 *
 *  If any errors are encountered, the object is destroyed and this
 *  procedure returns TCL_ERROR (along with an error message in the
 *  interpreter).  Otherwise, it returns TCL_OK
 * ------------------------------------------------------------------------
 */
int
ItclCreateObject(
    Tcl_Interp *interp,      /* interpreter mananging new object */
    const char* name,        /* name of new object */
    ItclClass *iclsPtr,        /* class for new object */
    size_t objc,                /* number of arguments */
    Tcl_Obj *const objv[])   /* argument objects */
{
    int result = TCL_OK;

    Tcl_DString buffer;
    Tcl_CmdInfo cmdInfo;
    Tcl_Command cmdPtr;
    Tcl_HashEntry *hPtr;
    Tcl_Obj **newObjv;
    Tcl_Obj *objPtr;
    Tcl_Obj *saveNsNamePtr = NULL;
    ItclObjectInfo *infoPtr;
    ItclObject *saveCurrIoPtr;
    ItclObject *ioPtr;
    Itcl_InterpState istate;
    const char *nsName;
    const char *objName;
    char unique[256];    /* buffer used for unique part of object names */
    int newEntry;
    ItclResolveInfo *resolveInfoPtr;
    /* objv[1]: class name */
    /* objv[2]: class full name */
    /* objv[3]: object name */

    infoPtr = NULL;
    ItclShowArgs(1, "ItclCreateObject", objc, objv);
    saveCurrIoPtr = NULL;
    if (iclsPtr->flags & (ITCL_TYPE|ITCL_WIDGETADAPTOR)) {
        /* check, if the object already exists and if yes delete it silently */
	cmdPtr = Tcl_FindCommand(interp, name, NULL, 0);
	if (cmdPtr != NULL) {
            Tcl_GetCommandInfoFromToken(cmdPtr, &cmdInfo);
	    if (cmdInfo.deleteProc == ItclDestroyObject) {
		Itcl_RenameCommand(interp, name, "");
	    }
        }
    }
    /* just init for the case of none ItclWidget objects */
    newObjv = (Tcl_Obj **)objv;
    infoPtr = iclsPtr->infoPtr;

    if (infoPtr != NULL) {
      infoPtr->lastIoPtr = NULL;
    }
    /*
     *  Create a new object and initialize it.
     */
    ioPtr = (ItclObject*)Itcl_Alloc(sizeof(ItclObject));
    Itcl_EventuallyFree(ioPtr, (Tcl_FreeProc *)FreeObject);
    ioPtr->iclsPtr = iclsPtr;
    ioPtr->interp = interp;
    ioPtr->infoPtr = infoPtr;
    ItclPreserveClass(iclsPtr);

    ioPtr->constructed = (Tcl_HashTable*)ckalloc(sizeof(Tcl_HashTable));
    Tcl_InitObjHashTable(ioPtr->constructed);

    ioPtr->oPtr = Tcl_NewObjectInstance(interp, iclsPtr->clsPtr, NULL,
            /* nsName */ NULL, /* objc */ -1, /* objv */ NULL, /* skip */ 0);
    if (ioPtr->oPtr == NULL) {
	Itcl_Free(ioPtr);
        return TCL_ERROR;
    }

    /*
     *  Add a command to the current namespace with the object name.
     *  This is done before invoking the constructors so that the
     *  command can be used during construction to query info.
     */
    Itcl_PreserveData(ioPtr);

    ioPtr->namePtr = Tcl_NewStringObj(name, TCL_INDEX_NONE);
    Tcl_IncrRefCount(ioPtr->namePtr);
    nsName = Tcl_GetCurrentNamespace(interp)->fullName;
    ioPtr->origNamePtr = Tcl_NewStringObj("", TCL_INDEX_NONE);
    if ((name[0] != ':') && (name[1] != ':')) {
        Tcl_AppendToObj(ioPtr->origNamePtr, nsName, TCL_INDEX_NONE);
        if (strcmp(nsName, "::") != 0) {
            Tcl_AppendToObj(ioPtr->origNamePtr, "::", TCL_INDEX_NONE);
        }
    }
    Tcl_AppendToObj(ioPtr->origNamePtr, name, TCL_INDEX_NONE);
    Tcl_IncrRefCount(ioPtr->origNamePtr);
    Tcl_DStringInit(&buffer);
    Tcl_DStringAppend(&buffer, ITCL_VARIABLES_NAMESPACE, TCL_INDEX_NONE);
    Tcl_DStringAppend(&buffer,
	    (Tcl_GetObjectNamespace(ioPtr->oPtr))->fullName, TCL_INDEX_NONE);
    ioPtr->varNsNamePtr = Tcl_NewStringObj(Tcl_DStringValue(&buffer), TCL_INDEX_NONE);
    Tcl_IncrRefCount(ioPtr->varNsNamePtr);
    Tcl_DStringFree(&buffer);

    Tcl_InitHashTable(&ioPtr->objectVariables, TCL_ONE_WORD_KEYS);
    Tcl_InitObjHashTable(&ioPtr->objectOptions);
    Tcl_InitObjHashTable(&ioPtr->objectComponents);
    Tcl_InitObjHashTable(&ioPtr->objectDelegatedOptions);
    Tcl_InitObjHashTable(&ioPtr->objectDelegatedFunctions);
    Tcl_InitObjHashTable(&ioPtr->objectMethodVariables);
    Tcl_InitHashTable(&ioPtr->contextCache, TCL_ONE_WORD_KEYS);

    Itcl_PreserveData(ioPtr);

    /*
     *  Install the class namespace and object context so that
     *  the object's data members can be initialized via simple
     *  "set" commands.
     */

    /* first create the object's class variables namespaces
     * and set all the init values for variables
     */

    if (ItclInitObjectVariables(interp, ioPtr, iclsPtr) != TCL_OK) {
	ioPtr->hadConstructorError = 11;
	result = TCL_ERROR;
        goto errorReturn;
    }
    if (ItclInitObjectCommands(interp, ioPtr, iclsPtr, name) != TCL_OK) {
	Tcl_AppendResult(interp, "error in ItclInitObjectCommands", NULL);
	ioPtr->hadConstructorError = 12;
	result = TCL_ERROR;
        goto errorReturn;
    }
    if (iclsPtr->flags & (ITCL_ECLASS|ITCL_NWIDGET|ITCL_WIDGET|
            ITCL_TYPE|ITCL_WIDGETADAPTOR)) {
	if (iclsPtr->flags & (ITCL_ECLASS|ITCL_TYPE|ITCL_WIDGET|
	        ITCL_WIDGETADAPTOR)) {
            ItclInitExtendedClassOptions(interp, ioPtr);
            if (ItclInitObjectOptions(interp, ioPtr, iclsPtr) != TCL_OK) {
	        Tcl_AppendResult(interp, "error in ItclInitObjectOptions",
		        NULL);
	        ioPtr->hadConstructorError = 13;
	        result = TCL_ERROR;
                goto errorReturn;
            }
        }
        if (ItclInitObjectMethodVariables(interp, ioPtr, iclsPtr, name)
	        != TCL_OK) {
	    Tcl_AppendResult(interp,
	            "error in ItclInitObjectMethodVariables", NULL);
	    ioPtr->hadConstructorError = 14;
	    result = TCL_ERROR;
            goto errorReturn;
        }

	if (iclsPtr->flags & (ITCL_WIDGET|ITCL_WIDGETADAPTOR)) {
	    saveNsNamePtr = Tcl_GetVar2Ex(interp,
		    "::itcl::internal::varNsName", name, 0);
	    if (saveNsNamePtr) {
		Tcl_IncrRefCount(saveNsNamePtr);
	    }
	    Tcl_SetVar2Ex(interp, "::itcl::internal::varNsName", name,
		    ioPtr->varNsNamePtr, 0);
	}

    }

    saveCurrIoPtr = infoPtr->currIoPtr;
    infoPtr->currIoPtr = ioPtr;
    if (iclsPtr->flags & ITCL_WIDGET) {
        newObjv = (Tcl_Obj **)ckalloc(sizeof(Tcl_Obj *) * (objc + 5));
        newObjv[0] = Tcl_NewStringObj(
                "::itcl::internal::commands::hullandoptionsinstall", TCL_INDEX_NONE);
        newObjv[1] = ioPtr->namePtr;
        Tcl_IncrRefCount(newObjv[1]);
        newObjv[2] = ioPtr->iclsPtr->namePtr;
        Tcl_IncrRefCount(newObjv[2]);
        if (ioPtr->iclsPtr->widgetClassPtr != NULL) {
            newObjv[3] = ioPtr->iclsPtr->widgetClassPtr;
        } else {
            newObjv[3] = Tcl_NewStringObj("", TCL_INDEX_NONE);
        }
        Tcl_IncrRefCount(newObjv[3]);
        if (ioPtr->iclsPtr->hullTypePtr != NULL) {
            newObjv[4] = ioPtr->iclsPtr->hullTypePtr;
        } else {
            newObjv[4] = Tcl_NewStringObj("", TCL_INDEX_NONE);
        }
        Tcl_IncrRefCount(newObjv[4]);
        memcpy(newObjv + 5, objv, (objc * sizeof(Tcl_Obj *)));
        result = Tcl_EvalObjv(interp, objc+5, newObjv, 0);
        Tcl_DecrRefCount(newObjv[0]);
        Tcl_DecrRefCount(newObjv[1]);
        Tcl_DecrRefCount(newObjv[2]);
        Tcl_DecrRefCount(newObjv[3]);
        Tcl_DecrRefCount(newObjv[4]);
        ckfree((char *)newObjv);
        if (result != TCL_OK) {
	    ioPtr->hadConstructorError = 15;
            goto errorReturn;
        }
    }
    objName = name;
    if (iclsPtr->flags & ITCL_WIDGETADAPTOR) {
        /* use a temporary name here as widgetadaptors often hijack the
	 * name for use in installhull. Rename it after the constructor has
	 * been run to the wanted name
	 */
        /*
         *  Add a unique part, and keep
         *  incrementing a counter until a valid name is found.
         */
        do {
	    Tcl_CmdInfo dummy;

            sprintf(unique,"%.200s_%" ITCL_Z_MODIFIER "u", name, iclsPtr->unique++);
            unique[0] = tolower(UCHAR(unique[0]));

            Tcl_DStringSetLength(&buffer, 0);
            Tcl_DStringAppend(&buffer, unique, TCL_INDEX_NONE);
            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);
	ioPtr->createNamePtr = Tcl_NewStringObj(objName, TCL_INDEX_NONE);
    }

    {
	Tcl_Obj *tmp = Tcl_NewObj();

	Tcl_GetCommandFullName(interp, Tcl_GetObjectCommand(ioPtr->oPtr), tmp);
	Itcl_RenameCommand(interp, Tcl_GetString(tmp), objName);
	Tcl_TraceCommand(interp, objName,
            TCL_TRACE_RENAME|TCL_TRACE_DELETE, ObjectRenamedTrace, ioPtr);
	Tcl_DecrRefCount(tmp);
    }
    Tcl_ObjectSetMethodNameMapper(ioPtr->oPtr, ItclMapMethodNameProc);

    ioPtr->accessCmd = Tcl_GetObjectCommand(ioPtr->oPtr);
    Tcl_GetCommandInfoFromToken(ioPtr->accessCmd, &cmdInfo);
    cmdInfo.deleteProc = ItclDestroyObject;
    cmdInfo.deleteData = ioPtr;
    Tcl_SetCommandInfoFromToken(ioPtr->accessCmd, &cmdInfo);
    ioPtr->resolvePtr = (Tcl_Resolve *)ckalloc(sizeof(Tcl_Resolve));
    ioPtr->resolvePtr->cmdProcPtr = Itcl_CmdAliasProc;
    ioPtr->resolvePtr->varProcPtr = Itcl_VarAliasProc;
    resolveInfoPtr = (ItclResolveInfo *)ckalloc(sizeof(ItclResolveInfo));
    memset (resolveInfoPtr, 0, sizeof(ItclResolveInfo));
    resolveInfoPtr->flags = ITCL_RESOLVE_OBJECT;
    resolveInfoPtr->ioPtr = ioPtr;
    ioPtr->resolvePtr->clientData = resolveInfoPtr;

    Tcl_ObjectSetMetadata(ioPtr->oPtr, iclsPtr->infoPtr->object_meta_type,
            ioPtr);

    /* make the object known, if it is used in the constructor already! */
    hPtr = Tcl_CreateHashEntry(&iclsPtr->infoPtr->objectCmds,
        (char*)ioPtr->accessCmd, &newEntry);
    Tcl_SetHashValue(hPtr, ioPtr);

    hPtr = Tcl_CreateHashEntry(&iclsPtr->infoPtr->objects,
        (char*)ioPtr, &newEntry);
    Tcl_SetHashValue(hPtr, ioPtr);

    /* Use the TclOO object namespaces as a unique key in case the
     * object is renamed. Used by mytypemethod, etc. */

    hPtr = Tcl_CreateHashEntry(&iclsPtr->infoPtr->instances,
	(Tcl_GetObjectNamespace(ioPtr->oPtr))->fullName, &newEntry);
    Tcl_SetHashValue(hPtr, ioPtr);

    /*
     *  Now construct the object.  Look for a constructor in the
     *  most-specific class, and if there is one, invoke it.
     *  This will cause a chain reaction, making sure that all
     *  base classes constructors are invoked as well, in order
     *  from least- to most-specific.  Any constructors that are
     *  not called out explicitly in "initCode" code fragments are
     *  invoked implicitly without arguments.
     */
    ItclShowArgs(1, "OBJECTCONSTRUCTOR", objc, objv);
    ioPtr->hadConstructorError = 0;
    result = Itcl_InvokeMethodIfExists(interp, "constructor",
        iclsPtr, ioPtr, objc, objv);
    if (ioPtr->hadConstructorError) {
        result = TCL_ERROR;
    }
    ioPtr->hadConstructorError = TCL_INDEX_NONE;
    if (result != TCL_OK) {
        istate = Itcl_SaveInterpState(interp, result);
	ItclDeleteObjectVariablesNamespace(interp, ioPtr);
	if (ioPtr->accessCmd != (Tcl_Command) NULL) {
	    Tcl_DeleteCommandFromToken(interp, ioPtr->accessCmd);
	    ioPtr->accessCmd = NULL;
	}
        result = Itcl_RestoreInterpState(interp, istate);
	infoPtr->currIoPtr = saveCurrIoPtr;
	/* need this for 2 ReleaseData at errorReturn!! */
	Itcl_PreserveData(ioPtr);
        goto errorReturn;
    } else {
	/* a constructor cannot return a result as the object name
	 * is returned as result */
        Tcl_ResetResult(interp);
    }

    /*
     *  If there is no constructor, construct the base classes
     *  in case they have constructors.  This will cause the
     *  same chain reaction.
     */
    objPtr = Tcl_NewStringObj("constructor", TCL_INDEX_NONE);
    if (Tcl_FindHashEntry(&iclsPtr->functions, (char *)objPtr) == NULL) {
        result = Itcl_ConstructBase(interp, ioPtr, iclsPtr);
    }
    Tcl_DecrRefCount(objPtr);

    if (iclsPtr->flags & ITCL_ECLASS) {
        ItclInitExtendedClassOptions(interp, ioPtr);
        if (ItclInitObjectOptions(interp, ioPtr, iclsPtr) != TCL_OK) {
                Tcl_AppendResult(interp, "error in ItclInitObjectOptions",
	        NULL);
            result = TCL_ERROR;
            goto errorReturn;
        }
    }
    /*
     *  If construction failed, then delete the object access
     *  command.  This will destruct the object and delete the
     *  object data.  Be careful to save and restore the interpreter
     *  state, since the destructors may generate errors of their own.
     */
    if (result != TCL_OK) {
        istate = Itcl_SaveInterpState(interp, result);

	/* Bug 227824.
	 * The constructor may destroy the object, possibly indirectly
	 * through the destruction of the main widget in the iTk
	 * megawidget it tried to construct. If this happens we must
	 * not try to destroy the access command a second time.
	 */
	if (ioPtr->accessCmd != (Tcl_Command) NULL) {
	    Tcl_DeleteCommandFromToken(interp, ioPtr->accessCmd);
	    ioPtr->accessCmd = NULL;
	}
        result = Itcl_RestoreInterpState(interp, istate);
	/* need this for 2 ReleaseData at errorReturn!! */
	Itcl_PreserveData(ioPtr);
        goto errorReturn;
    }

    if (iclsPtr->flags & ITCL_WIDGETADAPTOR) {

	if (saveNsNamePtr) {
	    Tcl_SetVar2Ex(interp, "::itcl::internal::varNsName", name,
		    saveNsNamePtr, 0);
	    Tcl_DecrRefCount(saveNsNamePtr);
	    saveNsNamePtr = NULL;
	}

        Itcl_RenameCommand(interp, objName, name);
        ioPtr->createNamePtr = NULL;
        Tcl_TraceCommand(interp, Tcl_GetString(ioPtr->namePtr),
                TCL_TRACE_RENAME|TCL_TRACE_DELETE, ObjectRenamedTrace, ioPtr);
    }
    if (iclsPtr->flags & (ITCL_WIDGETADAPTOR)) {
        /*
         * set all the init values for options
         */

        objPtr = Tcl_NewStringObj(
	        ITCL_NAMESPACE"::internal::commands::widgetinitobjectoptions ",
		TCL_INDEX_NONE);
	Tcl_AppendToObj(objPtr, Tcl_GetString(ioPtr->varNsNamePtr), TCL_INDEX_NONE);
	Tcl_AppendToObj(objPtr, " ", TCL_INDEX_NONE);
	Tcl_AppendToObj(objPtr, Tcl_GetString(ioPtr->namePtr), TCL_INDEX_NONE);
	Tcl_AppendToObj(objPtr, " ", TCL_INDEX_NONE);
	Tcl_AppendToObj(objPtr, Tcl_GetString(iclsPtr->fullNamePtr), TCL_INDEX_NONE);
	Tcl_IncrRefCount(objPtr);
        result = Tcl_EvalObjEx(interp, objPtr, 0);
	Tcl_DecrRefCount(objPtr);
	if (result != TCL_OK) {
	    infoPtr->currIoPtr = saveCurrIoPtr;
	    result = TCL_ERROR;
            goto errorReturn;
	}
    }
    if (iclsPtr->flags & (ITCL_ECLASS|ITCL_TYPE|ITCL_WIDGETADAPTOR)) {
	/* FIXME have to check for hierarchy if ITCL_ECLASS !! */
	result = ItclCheckForInitializedComponents(interp, ioPtr->iclsPtr,
	        ioPtr);
	if (result != TCL_OK) {
            istate = Itcl_SaveInterpState(interp, result);
	    if (ioPtr->accessCmd != (Tcl_Command) NULL) {
	        Tcl_DeleteCommandFromToken(interp, ioPtr->accessCmd);
	        ioPtr->accessCmd = NULL;
	    }
            result = Itcl_RestoreInterpState(interp, istate);
	    /* need this for 2 ReleaseData at errorReturn!! */
	    Itcl_PreserveData(ioPtr);
            goto errorReturn;
	}
    }

    /*
     *  Add it to the list of all known objects. The only
     *  tricky thing to watch out for is the case where the
     *  object deleted itself inside its own constructor.
     *  In that case, we don't want to add the object to
     *  the list of valid objects. We can determine that
     *  the object deleted itself by checking to see if
     *  its accessCmd member is NULL.
     */
    if (result == TCL_OK && (ioPtr->accessCmd != NULL))  {

	if (!(ioPtr->iclsPtr->flags & ITCL_CLASS)) {
	    result = DelegationInstall(interp, ioPtr, iclsPtr);
	    if (result != TCL_OK) {
		goto errorReturn;
	    }
	}
        hPtr = Tcl_CreateHashEntry(&iclsPtr->infoPtr->objectCmds,
                (char*)ioPtr->accessCmd, &newEntry);
        Tcl_SetHashValue(hPtr, ioPtr);
        hPtr = Tcl_CreateHashEntry(&iclsPtr->infoPtr->objects,
                (char*)ioPtr, &newEntry);
        Tcl_SetHashValue(hPtr, ioPtr);

	/*
	 * This is an inelegant hack, left behind until the need for it
	 * can be eliminated by getting the inheritance tree right.
	 */

        if (iclsPtr->flags
		& (ITCL_ECLASS|ITCL_TYPE|ITCL_WIDGET|ITCL_WIDGETADAPTOR)) {
	    Tcl_NewInstanceMethod(interp, ioPtr->oPtr,
		    Tcl_NewStringObj("unknown", TCL_INDEX_NONE), 0,
		    &itclRootMethodType, (void *)ItclUnknownGuts);
	}

        if (iclsPtr->flags & (ITCL_TYPE|ITCL_WIDGETADAPTOR)) {
            objPtr = Tcl_NewObj();
            Tcl_GetCommandFullName(interp, ioPtr->accessCmd, objPtr);
            if (iclsPtr->flags & ITCL_WIDGETADAPTOR) {
	        /* skip over the leading :: */
		char *objName;
		char *lastObjName;
		lastObjName = Tcl_GetString(objPtr);
		objName = lastObjName;
		while (1) {
		    objName = strstr(objName, "::");
		    if (objName == NULL) {
		        break;
		    }
		    objName += 2;
		    lastObjName = objName;
		}

                Tcl_AppendResult(interp, lastObjName, NULL);
            } else {
                Tcl_AppendResult(interp, Tcl_GetString(objPtr), NULL);
	    }
	    Tcl_DecrRefCount(objPtr);
	}
    } else {
        if (ioPtr->accessCmd != NULL) {
            hPtr = Tcl_FindHashEntry(&iclsPtr->infoPtr->objectCmds,
                (char*)ioPtr->accessCmd);
	    if (hPtr != NULL) {
                Tcl_DeleteHashEntry(hPtr);
	    }
        }
    }

    /*
     *  Release the object.  If it was destructed above, it will
     *  die at this point.
     */
    /*
     *  At this point, the object is fully constructed.
     *  Destroy the "constructed" table in the object data, since
     *  it is no longer needed.
     */
    if (infoPtr != NULL) {
        infoPtr->currIoPtr = saveCurrIoPtr;
    }
    infoPtr->lastIoPtr = ioPtr;
    Tcl_DeleteHashTable(ioPtr->constructed);
    ckfree((char*)ioPtr->constructed);
    ioPtr->constructed = NULL;
    ItclAddObjectsDictInfo(interp, ioPtr);
    Itcl_ReleaseData(ioPtr);
    return result;

errorReturn:
    /*
     *  At this point, the object is not constructed as there was an error.
     *  Destroy the "constructed" table in the object data, since
     *  it is no longer needed.
     */
	if (saveNsNamePtr) {
	    Tcl_SetVar2Ex(interp, "::itcl::internal::varNsName", name,
		    saveNsNamePtr, 0);
	    Tcl_DecrRefCount(saveNsNamePtr);
	    saveNsNamePtr = NULL;
	}
    if (infoPtr != NULL) {
        infoPtr->lastIoPtr = ioPtr;
        infoPtr->currIoPtr = saveCurrIoPtr;
    }
    if (ioPtr->constructed != NULL) {
        Tcl_DeleteHashTable(ioPtr->constructed);
        ckfree((char*)ioPtr->constructed);
        ioPtr->constructed = NULL;
    }
    ItclDeleteObjectVariablesNamespace(interp, ioPtr);
    Itcl_ReleaseData(ioPtr);
    Itcl_ReleaseData(ioPtr);
    return result;
}

/*
 * ------------------------------------------------------------------------
 *  ItclInitObjectCommands()
 *
 *  Init all instance commands.
 *  This is usually invoked automatically
 *  by Itcl_CreateObject(), when an object is created.
 * ------------------------------------------------------------------------
 */
static int
ItclInitObjectCommands(
   TCL_UNUSED(Tcl_Interp *),
   TCL_UNUSED(ItclObject *),
   TCL_UNUSED(ItclClass *),
   TCL_UNUSED(const char *))
{
    return TCL_OK;
}

/*
 * ------------------------------------------------------------------------
 *  ItclInitObjectVariables()
 *
 *  Init all instance variables and create the necessary variable namespaces
 *  for the given object instance.  This is usually invoked automatically
 *  by Itcl_CreateObject(), when an object is created.
 * ------------------------------------------------------------------------
 */
static int
ItclInitObjectVariables(
   Tcl_Interp *interp,
   ItclObject *ioPtr,
   ItclClass *iclsPtr)
{
    Tcl_DString buffer;
    Tcl_DString buffer2;
    Tcl_HashEntry *hPtr;
    Tcl_HashEntry *hPtr2;
    Tcl_HashSearch place;
    Tcl_Namespace *varNsPtr;
    Tcl_Namespace *varNsPtr2;
    Tcl_CallFrame frame;
    Tcl_Var varPtr;
    ItclClass *iclsPtr2;
    ItclHierIter hier;
    ItclVariable *ivPtr;
    ItclComponent *icPtr;
    const char *varName;
    const char *inheritComponentName;
    int itclOptionsIsSet;
    int isNew;

    ivPtr = NULL;
    /*
     * create all the variables for each class in the
     * ::itcl::variables::<object namespace>::<class> namespace as an
     * undefined variable using the Tcl "variable xx" command
     */
    itclOptionsIsSet = 0;
    inheritComponentName = NULL;
    Itcl_InitHierIter(&hier, iclsPtr);
    iclsPtr2 = Itcl_AdvanceHierIter(&hier);
    Tcl_ResetResult(interp);
    while (iclsPtr2 != NULL) {
	Tcl_DStringInit(&buffer);
	Tcl_DStringAppend(&buffer, ITCL_VARIABLES_NAMESPACE, TCL_INDEX_NONE);
	Tcl_DStringAppend(&buffer,
		(Tcl_GetObjectNamespace(ioPtr->oPtr))->fullName, TCL_INDEX_NONE);
	Tcl_DStringAppend(&buffer, iclsPtr2->nsPtr->fullName, TCL_INDEX_NONE);
	varNsPtr = Tcl_FindNamespace(interp, Tcl_DStringValue(&buffer),
	        NULL, 0);
	if (varNsPtr == NULL) {
	    varNsPtr = Tcl_CreateNamespace(interp, Tcl_DStringValue(&buffer),
	            NULL, 0);
	}
	/* now initialize the variables which have an init value */
        if (Itcl_PushCallFrame(interp, &frame, varNsPtr,
                /*isProcCallFrame*/0) != TCL_OK) {
	    goto errorCleanup2;
        }
        hPtr = Tcl_FirstHashEntry(&iclsPtr2->variables, &place);
        while (hPtr) {
            ivPtr = (ItclVariable*)Tcl_GetHashValue(hPtr);
	    varName = Tcl_GetString(ivPtr->namePtr);
            if ((ivPtr->flags & ITCL_OPTIONS_VAR) && !itclOptionsIsSet) {
                /* this is the special code for the "itcl_options" variable */
		itclOptionsIsSet = 1;
                Tcl_DStringInit(&buffer2);
	        Tcl_DStringAppend(&buffer2, ITCL_VARIABLES_NAMESPACE, TCL_INDEX_NONE);
		Tcl_DStringAppend(&buffer,
			(Tcl_GetObjectNamespace(ioPtr->oPtr))->fullName, TCL_INDEX_NONE);
	        varNsPtr2 = Tcl_FindNamespace(interp,
		        Tcl_DStringValue(&buffer2), NULL, 0);
	        if (varNsPtr2 == NULL) {
	            varNsPtr2 = Tcl_CreateNamespace(interp,
		            Tcl_DStringValue(&buffer2), NULL, 0);
	        }
                Tcl_DStringFree(&buffer2);
	        Itcl_PopCallFrame(interp);
	        /* now initialize the variables which have an init value */
                if (Itcl_PushCallFrame(interp, &frame, varNsPtr2,
                        /*isProcCallFrame*/0) != TCL_OK) {
		    goto errorCleanup2;
                }
                Tcl_TraceVar2(interp, "itcl_options",
                        NULL,
                        TCL_TRACE_READS|TCL_TRACE_WRITES,
                        ItclTraceOptionVar, ioPtr);
	        Itcl_PopCallFrame(interp);
                if (Itcl_PushCallFrame(interp, &frame, varNsPtr,
                        /*isProcCallFrame*/0) != TCL_OK) {
		    goto errorCleanup2;
                }
                hPtr = Tcl_NextHashEntry(&place);
	        continue;
            }
            if (ivPtr->flags & ITCL_COMPONENT_VAR) {
		hPtr2 = Tcl_FindHashEntry(&ivPtr->iclsPtr->components,
		        (char *)ivPtr->namePtr);
		if (hPtr2 == NULL) {
		    Tcl_AppendResult(interp, "cannot find component \"",
		            Tcl_GetString(ivPtr->namePtr), "\" in class \"",
			    Tcl_GetString(ivPtr->iclsPtr->namePtr), NULL);
		    goto errorCleanup;
		}
		icPtr = (ItclComponent *)Tcl_GetHashValue(hPtr2);
		if (icPtr->flags & ITCL_COMPONENT_INHERIT) {
		    if (inheritComponentName != NULL) {
		        Tcl_AppendResult(interp, "object \"",
			        Tcl_GetString(ioPtr->namePtr),
				"\" can only have one component with inherit.",
				" Had already component \"",
				inheritComponentName,
				"\" now component \"",
				Tcl_GetString(icPtr->namePtr), "\"", NULL);
		        goto errorCleanup;

		    } else {
		        inheritComponentName = Tcl_GetString(icPtr->namePtr);
		    }
		}
                hPtr2 = Tcl_CreateHashEntry(&ioPtr->objectComponents,
                        (char *)ivPtr->namePtr, &isNew);
		if (isNew) {
		    Tcl_SetHashValue(hPtr2, icPtr);
		}
                /* this is a component variable */
		/* FIXME initialize it to the empty string */
		/* the initialization  is arguable, should it be done? */
                if (Tcl_SetVar2(interp, varName, NULL,
	                "", TCL_NAMESPACE_ONLY) == NULL) {
                    Tcl_AppendResult(interp, "INTERNAL ERROR cannot set",
		            " variable \"", varName, "\"\n", NULL);
		    goto errorCleanup;
                }
	    }
            hPtr2 = ItclResolveVarEntry(ivPtr->iclsPtr, varName);
            if (hPtr2 == NULL) {
                hPtr = Tcl_NextHashEntry(&place);
	        continue;
            }
	    if ((ivPtr->flags & ITCL_COMMON) == 0) {
                varPtr = Tcl_NewNamespaceVar(interp, varNsPtr,
                        Tcl_GetString(ivPtr->namePtr));
	        hPtr2 = Tcl_CreateHashEntry(&ioPtr->objectVariables,
		        (char *)ivPtr, &isNew);
	        if (isNew) {
		    Itcl_PreserveVar(varPtr);
		    Tcl_SetHashValue(hPtr2, varPtr);
		}
	        if (ivPtr->flags & (ITCL_THIS_VAR|ITCL_TYPE_VAR|
		        ITCL_SELF_VAR|ITCL_SELFNS_VAR|ITCL_WIN_VAR)) {
                    int isDone = 0;
		    if (Tcl_SetVar2(interp, varName, NULL,
		        "", TCL_NAMESPACE_ONLY) == NULL) {
                        Tcl_AppendResult(interp, "INTERNAL ERROR cannot set",
			        " variable \"", varNsPtr->fullName, "::",
				varName, "\"\n", NULL);
		        goto errorCleanup;
	            }
	        if (ivPtr->flags & ITCL_THIS_VAR) {
	            Tcl_TraceVar2(interp, varName, NULL,
		        TCL_TRACE_READS|TCL_TRACE_WRITES, ItclTraceThisVar,
		        ioPtr);
                    isDone = 1;
		}
	        if (!isDone && ivPtr->flags & ITCL_TYPE_VAR) {
	            Tcl_TraceVar2(interp, varName, NULL,
		        TCL_TRACE_READS|TCL_TRACE_WRITES, ItclTraceTypeVar,
		        ioPtr);
                    isDone = 1;
		}
	        if (!isDone && ivPtr->flags & ITCL_SELF_VAR) {
	            Tcl_TraceVar2(interp, varName, NULL,
		        TCL_TRACE_READS|TCL_TRACE_WRITES, ItclTraceSelfVar,
		        ioPtr);
                    isDone = 1;
		}
	        if (!isDone && ivPtr->flags & ITCL_SELFNS_VAR) {
	            Tcl_TraceVar2(interp, varName, NULL,
		        TCL_TRACE_READS|TCL_TRACE_WRITES, ItclTraceSelfnsVar,
		        ioPtr);
                    isDone = 1;
		}
	        if (!isDone && ivPtr->flags & ITCL_WIN_VAR) {
	            Tcl_TraceVar2(interp, varName, NULL,
		        TCL_TRACE_READS|TCL_TRACE_WRITES, ItclTraceWinVar,
		        ioPtr);
                    isDone = 1;
		}
		} else {
	            if (ivPtr->flags & ITCL_HULL_VAR) {
	                Tcl_TraceVar2(interp, varName, NULL,
		            TCL_TRACE_READS|TCL_TRACE_WRITES,
			    ItclTraceItclHullVar,
		            ioPtr);
		    } else {
	              if (ivPtr->init != NULL) {
			if (Tcl_SetVar2(interp,
			        Tcl_GetString(ivPtr->namePtr), NULL,
			        Tcl_GetString(ivPtr->init),
				TCL_NAMESPACE_ONLY) == NULL) {
			    goto errorCleanup;
	                }
	              }
	              if (ivPtr->arrayInitPtr != NULL) {
			Tcl_DString buffer3;
	                Tcl_Size i;
	                Tcl_Size argc;
	                const char **argv;
	                const char *val;

			Tcl_DStringInit(&buffer3);
                        Tcl_DStringAppend(&buffer3, varNsPtr->fullName, TCL_INDEX_NONE);
                        Tcl_DStringAppend(&buffer3, "::", TCL_INDEX_NONE);
                        Tcl_DStringAppend(&buffer3,
			        Tcl_GetString(ivPtr->namePtr), TCL_INDEX_NONE);
	                Tcl_SplitList(interp,
			        Tcl_GetString(ivPtr->arrayInitPtr),
	                        &argc, &argv);
	                for (i = 0; i < argc; i += 2) {
                            val = Tcl_SetVar2(interp,
			            Tcl_DStringValue(&buffer3), argv[i],
                                    argv[i + 1], TCL_NAMESPACE_ONLY);
                            if (!val) {
                                Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
                                    "cannot initialize variable \"",
                                    Tcl_GetString(ivPtr->namePtr), "\"",
                                    NULL);
                                return TCL_ERROR;
                            }
                        }
			Tcl_DStringFree(&buffer3);
		        ckfree((char *)argv);
		        }
		      }
		    }
	        } else {
	            if (ivPtr->flags & ITCL_HULL_VAR) {
	                Tcl_TraceVar2(interp, varName, NULL,
		            TCL_TRACE_READS|TCL_TRACE_WRITES,
			    ItclTraceItclHullVar,
		            ioPtr);
		    }
	            hPtr2 = Tcl_FindHashEntry(&iclsPtr2->classCommons,
		            (char *)ivPtr);
		    if (hPtr2 == NULL) {
		        goto errorCleanup;
		    }
		    varPtr = (Tcl_Var)Tcl_GetHashValue(hPtr2);
	            hPtr2 = Tcl_CreateHashEntry(&ioPtr->objectVariables,
		            (char *)ivPtr, &isNew);
	            if (isNew) {
			Itcl_PreserveVar(varPtr);
		        Tcl_SetHashValue(hPtr2, varPtr);
	        }
	        if (ivPtr->flags & ITCL_COMPONENT_VAR) {
	            if (ivPtr->flags & ITCL_COMMON) {
                        Tcl_Obj *objPtr2;
		        objPtr2 = Tcl_NewStringObj(ITCL_VARIABLES_NAMESPACE,
			        TCL_INDEX_NONE);
			Tcl_AppendToObj(objPtr2, (Tcl_GetObjectNamespace(
				ivPtr->iclsPtr->oPtr))->fullName, TCL_INDEX_NONE);
                        Tcl_AppendToObj(objPtr2, "::", TCL_INDEX_NONE);
                        Tcl_AppendToObj(objPtr2, varName, TCL_INDEX_NONE);
			/* itcl_hull is traced in itclParse.c */
			if (strcmp(varName, "itcl_hull") == 0) {
                            Tcl_TraceVar2(interp,
                                    Tcl_GetString(objPtr2), NULL,
	                            TCL_TRACE_WRITES, ItclTraceItclHullVar,
	                            ioPtr);
			} else {
                            Tcl_TraceVar2(interp,
                                    Tcl_GetString(objPtr2), NULL,
	                            TCL_TRACE_WRITES, ItclTraceComponentVar,
	                            ioPtr);
		        }
		        Tcl_DecrRefCount(objPtr2);
		    } else {
                        Tcl_TraceVar2(interp,
		                varName, NULL,
	                        TCL_TRACE_WRITES, ItclTraceComponentVar,
	                        ioPtr);
	            }
	        }
	    }
            hPtr = Tcl_NextHashEntry(&place);
        }
	Itcl_PopCallFrame(interp);
        iclsPtr2 = Itcl_AdvanceHierIter(&hier);
    }
    Tcl_DStringFree(&buffer);
    Itcl_DeleteHierIter(&hier);
    return TCL_OK;
errorCleanup:
    Itcl_PopCallFrame(interp);
errorCleanup2:
    varNsPtr = Tcl_FindNamespace(interp, Tcl_GetString(ioPtr->varNsNamePtr),
            NULL, 0);
    if (varNsPtr != NULL) {
        Tcl_DeleteNamespace(varNsPtr);
    }
    return TCL_ERROR;
}

/*
 * ------------------------------------------------------------------------
 *  ItclInitObjectOptions()
 *
 *  Collect all instance options for the given object instance to allow
 *  faster runtime access to the options.
 *  if the same option name is used in more than one class the first one
 *  found is used (for initializing and for the class name)!!
 *  # It is assumed, that an option can only exist in one class??
 *  # So no duplicates allowed??
 *  This is usually invoked automatically by Itcl_CreateObject(),
 *  when an object is created.
 * ------------------------------------------------------------------------
 */
int
ItclInitObjectOptions(
   Tcl_Interp *interp,
   ItclObject *ioPtr,
   ItclClass *iclsPtr)
{
    Tcl_DString buffer;
    Tcl_HashEntry *hPtr;
    Tcl_HashEntry *hPtr2;
    Tcl_HashSearch place;
    Tcl_CallFrame frame;
    Tcl_Namespace *varNsPtr;
    ItclClass *iclsPtr2;
    ItclHierIter hier;
    ItclOption *ioptPtr;
    ItclDelegatedOption *idoPtr;
    int isNew;

    ioptPtr = NULL;
    Itcl_InitHierIter(&hier, iclsPtr);
    iclsPtr2 = Itcl_AdvanceHierIter(&hier);
    while (iclsPtr2 != NULL) {
	/* now initialize the options which have an init value */
        hPtr = Tcl_FirstHashEntry(&iclsPtr2->options, &place);
        while (hPtr) {
            ioptPtr = (ItclOption*)Tcl_GetHashValue(hPtr);
	    hPtr2 = Tcl_CreateHashEntry(&ioPtr->objectOptions,
	            (char *)ioptPtr->namePtr, &isNew);
	    if (isNew) {
		Tcl_SetHashValue(hPtr2, ioptPtr);
                Tcl_DStringInit(&buffer);
	        Tcl_DStringAppend(&buffer, ITCL_VARIABLES_NAMESPACE, TCL_INDEX_NONE);
		Tcl_DStringAppend(&buffer,
			(Tcl_GetObjectNamespace(ioPtr->oPtr)->fullName), TCL_INDEX_NONE);
	        varNsPtr = Tcl_FindNamespace(interp,
		        Tcl_DStringValue(&buffer), NULL, 0);
	        if (varNsPtr == NULL) {
	            varNsPtr = Tcl_CreateNamespace(interp,
		            Tcl_DStringValue(&buffer), NULL, 0);
		}
                Tcl_DStringFree(&buffer);
	        /* now initialize the options which have an init value */
                if (Itcl_PushCallFrame(interp, &frame, varNsPtr,
                        /*isProcCallFrame*/0) != TCL_OK) {
                    return TCL_ERROR;
                }
		if ((ioptPtr != NULL) && (ioptPtr->namePtr != NULL) &&
		        (ioptPtr->defaultValuePtr != NULL)) {
                    if (Tcl_SetVar2(interp, "itcl_options",
		            Tcl_GetString(ioptPtr->namePtr),
	                    Tcl_GetString(ioptPtr->defaultValuePtr),
			    TCL_NAMESPACE_ONLY) == NULL) {
	                Itcl_PopCallFrame(interp);
		        return TCL_ERROR;
                    }
                    Tcl_TraceVar2(interp, "itcl_options",
                            NULL,
                            TCL_TRACE_READS|TCL_TRACE_WRITES,
                            ItclTraceOptionVar, ioPtr);
		}
	        Itcl_PopCallFrame(interp);
            }
            hPtr = Tcl_NextHashEntry(&place);
        }
	/* now check for options which are delegated */
        hPtr = Tcl_FirstHashEntry(&iclsPtr2->delegatedOptions, &place);
        while (hPtr) {
            idoPtr = (ItclDelegatedOption*)Tcl_GetHashValue(hPtr);
	    hPtr2 = Tcl_CreateHashEntry(&ioPtr->objectDelegatedOptions,
	            (char *)idoPtr->namePtr, &isNew);
	    if (isNew) {
		Tcl_SetHashValue(hPtr2, idoPtr);
	    }
            hPtr = Tcl_NextHashEntry(&place);
        }
        iclsPtr2 = Itcl_AdvanceHierIter(&hier);
    }
    Itcl_DeleteHierIter(&hier);
    return TCL_OK;
}

/*
 * ------------------------------------------------------------------------
 *  ItclInitObjectMethodVariables()
 *
 *  Collect all instance methdovariables for the given object instance to allow
 *  faster runtime access to the methdovariables.
 *  This is usually invoked automatically by Itcl_CreateObject(),
 *  when an object is created.
 * ------------------------------------------------------------------------
 */
int
ItclInitObjectMethodVariables(
   TCL_UNUSED(Tcl_Interp *),
   ItclObject *ioPtr,
   ItclClass *iclsPtr,
   TCL_UNUSED(const char *))
{
    ItclClass *iclsPtr2;
    ItclHierIter hier;
    ItclMethodVariable *imvPtr;
    Tcl_HashEntry *hPtr;
    Tcl_HashEntry *hPtr2;
    Tcl_HashSearch place;
    int isNew;

    imvPtr = NULL;
    Itcl_InitHierIter(&hier, iclsPtr);
    iclsPtr2 = Itcl_AdvanceHierIter(&hier);
    while (iclsPtr2 != NULL) {
        hPtr = Tcl_FirstHashEntry(&iclsPtr2->methodVariables, &place);
        while (hPtr) {
            imvPtr = (ItclMethodVariable*)Tcl_GetHashValue(hPtr);
	    hPtr2 = Tcl_CreateHashEntry(&ioPtr->objectMethodVariables,
	            (char *)imvPtr->namePtr, &isNew);
	    if (isNew) {
		Tcl_SetHashValue(hPtr2, imvPtr);
            }
            hPtr = Tcl_NextHashEntry(&place);
        }
        iclsPtr2 = Itcl_AdvanceHierIter(&hier);
    }
    Itcl_DeleteHierIter(&hier);
    return TCL_OK;
}

/*
 * ------------------------------------------------------------------------
 *  Itcl_DeleteObject()
 *
 *  Attempts to delete an object by invoking its destructor.
 *
 *  If the destructor is successful, then the object is deleted by
 *  removing its access command, and this procedure returns TCL_OK.
 *  Otherwise, the object will remain alive, and this procedure
 *  returns TCL_ERROR (along with an error message in the interpreter).
 * ------------------------------------------------------------------------
 */
int
Itcl_DeleteObject(
    Tcl_Interp *interp,      /* interpreter mananging object */
    ItclObject *contextIoPtr)  /* object to be deleted */
{
    Tcl_CmdInfo cmdInfo;
    Tcl_HashEntry *hPtr;


    Tcl_GetCommandInfoFromToken(contextIoPtr->accessCmd, &cmdInfo);

    contextIoPtr->flags |= ITCL_OBJECT_IS_DELETED;
    Itcl_PreserveData(contextIoPtr);

    /*
     *  Invoke the object's destructors.
     */
    if (Itcl_DestructObject(interp, contextIoPtr, 0) != TCL_OK) {
	Itcl_ReleaseData(contextIoPtr);
	contextIoPtr->flags |=
	        ITCL_TCLOO_OBJECT_IS_DELETED|ITCL_OBJECT_DESTRUCT_ERROR;
        return TCL_ERROR;
    }
    /*
     *  Remove the object from the global list.
     */
    hPtr = Tcl_FindHashEntry(&contextIoPtr->infoPtr->objects,
        (char*)contextIoPtr);

    if (hPtr) {
        Tcl_DeleteHashEntry(hPtr);
    }

    /*
     *  Change the object's access command so that it can be
     *  safely deleted without attempting to destruct the object
     *  again.  Then delete the access command.  If this is
     *  the last use of the object data, the object will die here.
     */
    if ((contextIoPtr->accessCmd != NULL) && (!(contextIoPtr->flags &
            (ITCL_OBJECT_IS_RENAMED)))) {
    if (Tcl_GetCommandInfoFromToken(contextIoPtr->accessCmd, &cmdInfo) == 1) {
        cmdInfo.deleteProc = (Tcl_CmdDeleteProc *)Itcl_ReleaseData;
	Tcl_SetCommandInfoFromToken(contextIoPtr->accessCmd, &cmdInfo);

        Tcl_DeleteCommandFromToken(interp, contextIoPtr->accessCmd);
    }
    }
    contextIoPtr->oPtr = NULL;
    contextIoPtr->accessCmd = NULL;

    Itcl_ReleaseData(contextIoPtr);

    return TCL_OK;
}

/*
 * ------------------------------------------------------------------------
 *  ItclDeleteObjectVariablesNamespace()
 *
 * ------------------------------------------------------------------------
 */
void
ItclDeleteObjectVariablesNamespace(
    Tcl_Interp *interp,
    ItclObject *ioPtr)
{
    Tcl_Namespace *varNsPtr;

    if (ioPtr->callRefCount < 1) {
        /* free the object's variables namespace and variables in it */
	ioPtr->flags &= ~ITCL_OBJECT_SHOULD_VARNS_DELETE;
        varNsPtr = Tcl_FindNamespace(interp, Tcl_GetString(ioPtr->varNsNamePtr),
	        NULL, 0);
        if (varNsPtr != NULL) {
            Tcl_DeleteNamespace(varNsPtr);
        }
    } else {
        ioPtr->flags |= ITCL_OBJECT_SHOULD_VARNS_DELETE;
    }
}

static int
FinalizeDeleteObject(
    void *data[],
    Tcl_Interp *interp,
    int result)
{
    ItclObject *contextIoPtr = (ItclObject *)data[0];
    if (result == TCL_OK) {
	ItclDeleteObjectVariablesNamespace(interp, contextIoPtr);
        Tcl_ResetResult(interp);
    }

    Tcl_DeleteHashTable(contextIoPtr->destructed);
    ckfree((char*)contextIoPtr->destructed);
    contextIoPtr->destructed = NULL;
    return result;
}

static int
CallDestructBase(
    void *data[],
    Tcl_Interp *interp,
    int result)
{
    Tcl_Obj *objPtr;
    ItclObject *contextIoPtr = (ItclObject *)data[0];
    int flags = PTR2INT(data[1]);

    if (result != TCL_OK) {
        return result;
    }
    result = ItclDestructBase(interp, contextIoPtr, contextIoPtr->iclsPtr,
            flags);
    if (result != TCL_OK) {
        return result;
    }
    /* destroy the hull */
    if (contextIoPtr->hullWindowNamePtr != NULL) {
        objPtr = Tcl_NewStringObj("destroy ", TCL_INDEX_NONE);
        Tcl_AppendToObj(objPtr,
	        Tcl_GetString(contextIoPtr->hullWindowNamePtr), TCL_INDEX_NONE);
        result = Tcl_EvalObjEx(interp, objPtr, 0);
    }
    return result;
}
/*
 * ------------------------------------------------------------------------
 *  Itcl_DestructObject()
 *
 *  Invokes the destructor for a particular object.  Usually invoked
 *  by Itcl_DeleteObject() or Itcl_DestroyObject() as a part of the
 *  object destruction process.  If the ITCL_IGNORE_ERRS flag is
 *  included, all destructors are invoked even if errors are
 *  encountered, and the result will always be TCL_OK.
 *
 *  Returns TCL_OK on success, or TCL_ERROR (along with an error
 *  message in the interpreter) if anything goes wrong.
 * ------------------------------------------------------------------------
 */
int
Itcl_DestructObject(
    Tcl_Interp *interp,      /* interpreter mananging new object */
    ItclObject *contextIoPtr,  /* object to be destructed */
    int flags)               /* flags: ITCL_IGNORE_ERRS */
{
    int result;

    if ((contextIoPtr->flags & (ITCL_OBJECT_IS_DESTRUCTED))) {
            return TCL_OK;
    }
    contextIoPtr->flags |= ITCL_OBJECT_IS_DESTRUCTED;
    /*
     *  If there is a "destructed" table, then this object is already
     *  being destructed.  Flag an error, unless errors are being
     *  ignored.
     */
    if (contextIoPtr->destructed) {
        if ((flags & ITCL_IGNORE_ERRS) == 0) {
            Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
                "can't delete an object while it is being destructed",
                NULL);
            return TCL_ERROR;
        }
        return TCL_OK;
    }

    result = TCL_OK;
    if (contextIoPtr->oPtr != NULL) {
        void *callbackPtr;
        /*
         *  Create a "destructed" table to keep track of which destructors
         *  have been invoked.  This is used in ItclDestructBase to make
         *  sure that all base class destructors have been called,
         *  explicitly or implicitly.
         */
        contextIoPtr->destructed = (Tcl_HashTable*)ckalloc(sizeof(Tcl_HashTable));
        Tcl_InitObjHashTable(contextIoPtr->destructed);

        /*
         *  Destruct the object starting from the most-specific class.
         *  If all goes well, return the null string as the result.
         */
        callbackPtr = Itcl_GetCurrentCallbackPtr(interp);
        Tcl_NRAddCallback(interp, FinalizeDeleteObject, contextIoPtr,
	        NULL, NULL, NULL);
        Tcl_NRAddCallback(interp, CallDestructBase, contextIoPtr,
	        INT2PTR(flags), NULL, NULL);
        result = Itcl_NRRunCallbacks(interp, callbackPtr);
    }
    return result;
}

/*
 * ------------------------------------------------------------------------
 *  ItclDestructBase()
 *
 *  Invoked by Itcl_DestructObject() to recursively destruct an object
 *  from the specified class level.  Finds and invokes the destructor
 *  for the specified class, and then recursively destructs all base
 *  classes.  If the ITCL_IGNORE_ERRS flag is included, all destructors
 *  are invoked even if errors are encountered, and the result will
 *  always be TCL_OK.
 *
 *  Returns TCL_OK on success, or TCL_ERROR (along with an error message
 *  in interp->result) on error.
 * ------------------------------------------------------------------------
 */
static int
ItclDestructBase(
    Tcl_Interp *interp,         /* interpreter */
    ItclObject *contextIoPtr,   /* object being destructed */
    ItclClass *contextIclsPtr,  /* current class being destructed */
    int flags)                  /* flags: ITCL_IGNORE_ERRS */
{
    int result;
    Itcl_ListElem *elem;
    ItclClass *iclsPtr;

    if (contextIoPtr->flags & ITCL_OBJECT_CLASS_DESTRUCTED) {
        return TCL_OK;
    }
    /*
     *  Look for a destructor in this class, and if found,
     *  invoke it.
     */
    if (Tcl_FindHashEntry(contextIoPtr->destructed,
            (char *)contextIclsPtr->namePtr) == NULL) {
        result = Itcl_InvokeMethodIfExists(interp, "destructor",
            contextIclsPtr, contextIoPtr, 0, NULL);
        if (result != TCL_OK) {
            return TCL_ERROR;
        }
    }

    /*
     *  Scan through the list of base classes recursively and destruct
     *  them.  Traverse the list in normal order, so that we destruct
     *  from most- to least-specific.
     */
    elem = Itcl_FirstListElem(&contextIclsPtr->bases);
    while (elem) {
        iclsPtr = (ItclClass*)Itcl_GetListValue(elem);

        if (ItclDestructBase(interp, contextIoPtr, iclsPtr, flags) != TCL_OK) {
            return TCL_ERROR;
        }
        elem = Itcl_NextListElem(elem);
    }

    /*
     *  Throw away any result from the destructors and return.
     */
    Tcl_ResetResult(interp);
    return TCL_OK;
}

/*
 * ------------------------------------------------------------------------
 *  Itcl_FindObject()
 *
 *  Searches for an object with the specified name, which have
 *  namespace scope qualifiers like "namesp::namesp::name", or may
 *  be a scoped value such as "namespace inscope ::foo obj".
 *
 *  If an error is encountered, this procedure returns TCL_ERROR
 *  along with an error message in the interpreter.  Otherwise, it
 *  returns TCL_OK.  If an object was found, "roPtr" returns a
 *  pointer to the object data.  Otherwise, it returns NULL.
 * ------------------------------------------------------------------------
 */
int
Itcl_FindObject(
    Tcl_Interp *interp,      /* interpreter containing this object */
    const char *name,        /* name of the object */
    ItclObject **roPtr)      /* returns: object data or NULL */
{
    Tcl_Command cmd;
    Tcl_CmdInfo cmdInfo;
    Tcl_Namespace *contextNs;
    char *cmdName;

    contextNs = NULL;
    cmdName = NULL;
    /*
     *  The object name may be a scoped value of the form
     *  "namespace inscope <namesp> <command>".  If it is,
     *  decode it.
     */
    if (Itcl_DecodeScopedCommand(interp, name, &contextNs, &cmdName)
            != TCL_OK) {
        return TCL_ERROR;
    }

    /*
     *  Look for the object's access command, and see if it has
     *  the appropriate command handler.
     */
    cmd = Tcl_FindCommand(interp, cmdName, contextNs, /* flags */ 0);
    if (cmd != NULL && Itcl_IsObject(cmd)) {
        if (Tcl_GetCommandInfoFromToken(cmd, &cmdInfo) != 1) {
            *roPtr = NULL;
        }
        *roPtr = (ItclObject *)cmdInfo.deleteData;
    } else {
        *roPtr = NULL;
    }

    ckfree(cmdName);

    return TCL_OK;
}


/*
 * ------------------------------------------------------------------------
 *  Itcl_IsObject()
 *
 *  Checks the given Tcl command to see if it represents an itcl object.
 *  Returns non-zero if the command is associated with an object.
 * ------------------------------------------------------------------------
 */
int
Itcl_IsObject(
    Tcl_Command cmd)         /* command being tested */
{
    Tcl_CmdInfo cmdInfo;

    if (Tcl_GetCommandInfoFromToken(cmd, &cmdInfo) != 1) {
        return 0;
    }

    if ((void *)cmdInfo.deleteProc == (void *)ItclDestroyObject) {
        return 1;
    }

    /*
     *  This may be an imported command.  Try to get the real
     *  command and see if it represents an object.
     */
    cmd = Tcl_GetOriginalCommand(cmd);
    if (cmd != NULL) {
        if (Tcl_GetCommandInfoFromToken(cmd, &cmdInfo) != 1) {
            return 0;
        }

        if ((void *)cmdInfo.deleteProc == (void *)ItclDestroyObject) {
            return 1;
        }
    }
    return 0;
}


/*
 * ------------------------------------------------------------------------
 *  Itcl_ObjectIsa()
 *
 *  Checks to see if an object belongs to the given class.  An object
 *  "is-a" member of the class if the class appears anywhere in its
 *  inheritance hierarchy.  Returns non-zero if the object belongs to
 *  the class, and zero otherwise.
 * ------------------------------------------------------------------------
 */
int
Itcl_ObjectIsa(
    ItclObject *contextIoPtr, /* object being tested */
    ItclClass *iclsPtr)       /* class to test for "is-a" relationship */
{
    Tcl_HashEntry *entry;

    if (contextIoPtr == NULL) {
        return 0;
    }
    entry = Tcl_FindHashEntry(&contextIoPtr->iclsPtr->heritage, (char*)iclsPtr);
    return (entry != NULL);
}

/*
 * ------------------------------------------------------------------------
 *  ItclGetInstanceVar()
 *
 *  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.
 * ------------------------------------------------------------------------
 */
const char*
ItclGetInstanceVar(
    Tcl_Interp *interp,        /* current interpreter */
    const char *name1,         /* name of desired instance variable */
    const char *name2,         /* array element or NULL */
    ItclObject *contextIoPtr,  /* current object */
    ItclClass *contextIclsPtr) /* name is interpreted in this scope */
{
    Tcl_HashEntry *hPtr;
    Tcl_CallFrame frame;
    Tcl_CallFrame *framePtr;
    Tcl_Namespace *nsPtr;
    Tcl_DString buffer;
    ItclClass *iclsPtr;
    ItclVariable *ivPtr;
    ItclVarLookup *vlookup;
    const char *val;
    int isItclOptions;
    int doAppend;

    /*
     *  Make sure that the current namespace context includes an
     *  object that is being manipulated.
     */
    if (contextIoPtr == NULL) {
        Tcl_ResetResult(interp);
        Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
            "cannot access object-specific info without an object context",
            NULL);
        return NULL;
    }

    /* get the variable definition to check if that is an ITCL_COMMON */
    if (contextIclsPtr == NULL) {
        iclsPtr = contextIoPtr->iclsPtr;
    } else {
        iclsPtr = contextIclsPtr;
    }
    ivPtr = NULL;
    hPtr = ItclResolveVarEntry(iclsPtr, (char *)name1);
    if (hPtr != NULL) {
        vlookup = (ItclVarLookup *)Tcl_GetHashValue(hPtr);
        ivPtr = vlookup->ivPtr;
    /*
     *  Install the object context and access the data member
     *  like any other variable.
     */
    hPtr = Tcl_FindHashEntry(&contextIoPtr->objectVariables, (char *)ivPtr);
    if (hPtr) {
	Tcl_Obj *varName = Tcl_NewObj();
	Tcl_Var varPtr = (Tcl_Var)Tcl_GetHashValue(hPtr);
	Tcl_GetVariableFullName(interp, varPtr, varName);

	val = Tcl_GetVar2(interp, Tcl_GetString(varName), name2,
		TCL_LEAVE_ERR_MSG | TCL_GLOBAL_ONLY);
	Tcl_DecrRefCount(varName);
	if (val) {
	    return val;
	}
    }
    }

    isItclOptions = 0;
    if (strcmp(name1, "itcl_options") == 0) {
        isItclOptions = 1;
    }
    if (strcmp(name1, "itcl_option_components") == 0) {
        isItclOptions = 1;
    }
    Tcl_DStringInit(&buffer);
    Tcl_DStringAppend(&buffer, Tcl_GetString(contextIoPtr->varNsNamePtr), TCL_INDEX_NONE);
    doAppend = 1;
    if ((contextIclsPtr == NULL) || (contextIclsPtr->flags &
            (ITCL_ECLASS|ITCL_TYPE|ITCL_WIDGET|ITCL_WIDGETADAPTOR))) {
        if (isItclOptions) {
	    doAppend = 0;
        }
    }
    if ((ivPtr != NULL) && (ivPtr->flags & ITCL_COMMON)) {
	if (!isItclOptions) {
            Tcl_DStringSetLength(&buffer, 0);
	    if (ivPtr->protection != ITCL_PUBLIC) {
	        Tcl_DStringAppend(&buffer, ITCL_VARIABLES_NAMESPACE, TCL_INDEX_NONE);
	    }
	    doAppend = 1;
        }
    }
    if (doAppend) {
        Tcl_DStringAppend(&buffer, (Tcl_GetObjectNamespace(
		contextIclsPtr->oPtr))->fullName, TCL_INDEX_NONE);
    }
    nsPtr = Tcl_FindNamespace(interp, Tcl_DStringValue(&buffer), NULL, 0);
    Tcl_DStringFree(&buffer);
    val = NULL;
    if (nsPtr != NULL) {
	framePtr = &frame;
	Itcl_PushCallFrame(interp, framePtr, nsPtr, /*isProcCallFrame*/0);
        val = Tcl_GetVar2(interp, (const char *)name1, (char*)name2,
	        TCL_LEAVE_ERR_MSG);
        Itcl_PopCallFrame(interp);
    }

    return val;
}

/*
 * ------------------------------------------------------------------------
 *  ItclGetCommonInstanceVar()
 *
 *  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.
 * ------------------------------------------------------------------------
 */
const char*
ItclGetCommonInstanceVar(
    Tcl_Interp *interp,        /* current interpreter */
    const char *name1,         /* name of desired instance variable */
    const char *name2,         /* array element or NULL */
    ItclObject *contextIoPtr,  /* current object */
    ItclClass *contextIclsPtr) /* name is interpreted in this scope */
{
    Tcl_CallFrame frame;
    Tcl_CallFrame *framePtr;
    Tcl_Namespace *nsPtr;
    Tcl_DString buffer;
    const char *val;
    int doAppend;

    /*
     *  Make sure that the current namespace context includes an
     *  object that is being manipulated.
     */
    if (contextIoPtr == NULL) {
        Tcl_ResetResult(interp);
        Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
            "cannot access object-specific info without an object context",
            NULL);
        return NULL;
    }

    /*
     *  Install the object context and access the data member
     *  like any other variable.
     */
    Tcl_DStringInit(&buffer);
    Tcl_DStringAppend(&buffer, ITCL_VARIABLES_NAMESPACE, TCL_INDEX_NONE);
    doAppend = 1;
    if ((contextIclsPtr == NULL) || (contextIclsPtr->flags &
            (ITCL_ECLASS|ITCL_TYPE|ITCL_WIDGETADAPTOR))) {
        if (strcmp(name1, "itcl_options") == 0) {
	    doAppend = 0;
        }
        if (strcmp(name1, "itcl_option_components") == 0) {
	    doAppend = 0;
        }
    }
    if (doAppend) {
        Tcl_DStringAppend(&buffer, (Tcl_GetObjectNamespace(
		contextIclsPtr->oPtr))->fullName, TCL_INDEX_NONE);
    }
    nsPtr = Tcl_FindNamespace(interp, Tcl_DStringValue(&buffer), NULL, 0);
    Tcl_DStringFree(&buffer);
    val = NULL;
    if (nsPtr != NULL) {
	framePtr = &frame;
	Itcl_PushCallFrame(interp, framePtr, nsPtr, /*isProcCallFrame*/0);
        val = Tcl_GetVar2(interp, (const char *)name1, (char*)name2,
	        TCL_LEAVE_ERR_MSG);
        Itcl_PopCallFrame(interp);
    }

    return val;
}

/*
 * ------------------------------------------------------------------------
 *  Itcl_GetInstanceVar()
 *
 *  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.
 * ------------------------------------------------------------------------
 */
const char*
Itcl_GetInstanceVar(
    Tcl_Interp *interp,        /* current interpreter */
    const char *name,          /* name of desired instance variable */
    ItclObject *contextIoPtr,  /* current object */
    ItclClass *contextIclsPtr) /* name is interpreted in this scope */
{
    return ItclGetInstanceVar(interp, name, NULL, contextIoPtr,
            contextIclsPtr);
}

/*
 * ------------------------------------------------------------------------
 *  ItclSetInstanceVar()
 *
 *  Sets 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.
 * ------------------------------------------------------------------------
 */
const char*
ItclSetInstanceVar(
    Tcl_Interp *interp,        /* current interpreter */
    const char *name1,         /* name of desired instance variable */
    const char *name2,         /* array member or NULL */
    const char *value,         /* the value to set */
    ItclObject *contextIoPtr,  /* current object */
    ItclClass *contextIclsPtr) /* name is interpreted in this scope */
{
    Tcl_HashEntry *hPtr;
    Tcl_CallFrame frame;
    Tcl_CallFrame *framePtr;
    Tcl_Namespace *nsPtr;
    Tcl_DString buffer;
    ItclVariable *ivPtr;
    ItclVarLookup *vlookup;
    ItclClass *iclsPtr;
    const char *val;
    int isItclOptions;
    int doAppend;

    ivPtr = NULL;
    /*
     *  Make sure that the current namespace context includes an
     *  object that is being manipulated.
     */
    if (contextIoPtr == NULL) {
        Tcl_ResetResult(interp);
        Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
            "cannot access object-specific info without an object context",
            NULL);
        return NULL;
    }
    /* get the variable definition to check if that is an ITCL_COMMON */
    if (contextIclsPtr == NULL) {
        iclsPtr = contextIoPtr->iclsPtr;
    } else {
        iclsPtr = contextIclsPtr;
    }
    hPtr = ItclResolveVarEntry(iclsPtr, (char *)name1);
    if (hPtr != NULL) {
        vlookup = (ItclVarLookup *)Tcl_GetHashValue(hPtr);
        ivPtr = vlookup->ivPtr;
    } else {
        return NULL;
    }
    /*
     *  Install the object context and access the data member
     *  like any other variable.
     */

    hPtr = Tcl_FindHashEntry(&contextIoPtr->objectVariables, (char *)ivPtr);
    if (hPtr) {
	Tcl_Obj *varName = Tcl_NewObj();
	Tcl_Var varPtr = (Tcl_Var)Tcl_GetHashValue(hPtr);
	Tcl_GetVariableFullName(interp, varPtr, varName);

	val = Tcl_SetVar2(interp, Tcl_GetString(varName), name2, value,
		TCL_LEAVE_ERR_MSG);
	Tcl_DecrRefCount(varName);
	return val;
    }

    isItclOptions = 0;
    if (strcmp(name1, "itcl_options") == 0) {
        isItclOptions = 1;
    }
    if (strcmp(name1, "itcl_option_components") == 0) {
        isItclOptions = 1;
    }
    Tcl_DStringInit(&buffer);
    Tcl_DStringAppend(&buffer, Tcl_GetString(contextIoPtr->varNsNamePtr), TCL_INDEX_NONE);
    doAppend = 1;
    if ((contextIclsPtr == NULL) ||
            (contextIclsPtr->flags & (ITCL_ECLASS|ITCL_TYPE|
	    ITCL_WIDGET|ITCL_WIDGETADAPTOR))) {
        if (isItclOptions) {
	    doAppend = 0;
        }
    }
    if (ivPtr->flags & ITCL_COMMON) {
	if (!isItclOptions) {
            Tcl_DStringSetLength(&buffer, 0);
	    if (ivPtr->protection != ITCL_PUBLIC) {
	        Tcl_DStringAppend(&buffer, ITCL_VARIABLES_NAMESPACE, TCL_INDEX_NONE);
	    }
	    doAppend = 1;
        }
    }
    if (doAppend) {
        Tcl_DStringAppend(&buffer, (Tcl_GetObjectNamespace(
		contextIclsPtr->oPtr))->fullName, TCL_INDEX_NONE);
    }
    nsPtr = Tcl_FindNamespace(interp, Tcl_DStringValue(&buffer), NULL, 0);
    Tcl_DStringFree(&buffer);
    val = NULL;
    if (nsPtr != NULL) {
	framePtr = &frame;
	Itcl_PushCallFrame(interp, framePtr, nsPtr, /*isProcCallFrame*/0);
        val = Tcl_SetVar2(interp, (const char *)name1, (char*)name2,
	        value, TCL_LEAVE_ERR_MSG);
        Itcl_PopCallFrame(interp);
    }

    return val;
}

/*
 * ------------------------------------------------------------------------
 *  ItclReportObjectUsage()
 *
 *  Appends information to the given interp summarizing the usage
 *  for all of the methods available for this object.  Useful when
 *  reporting errors in Itcl_HandleInstance().
 * ------------------------------------------------------------------------
 */
void
ItclReportObjectUsage(
    Tcl_Interp *interp,           /* current interpreter */
    ItclObject *contextIoPtr,     /* current object */
    TCL_UNUSED(Tcl_Namespace *),
    Tcl_Namespace *contextNsPtr)  /* the context namespace */
{
    Tcl_Obj *namePtr;
    Tcl_HashEntry *entry;
    Tcl_HashSearch place;
    Tcl_Obj *resultPtr;
    ItclClass *iclsPtr = NULL;
    Itcl_List cmdList;
    Itcl_ListElem *elem;
    ItclMemberFunc *imPtr;
    ItclMemberFunc *cmpFunc;
    ItclCmdLookup *clookup;
    ItclObjectInfo * infoPtr = NULL;
    char *name;
    int ignore;
    int cmp;

    if (contextIoPtr == NULL) {
        resultPtr = Tcl_GetObjResult(interp);
        infoPtr = (ItclObjectInfo *)Tcl_GetAssocData(interp, ITCL_INTERP_DATA, NULL);
        if (infoPtr == NULL) {
            Tcl_AppendResult(interp, " PANIC cannot get Itcl AssocData in ItclReportObjectUsage", NULL);
	    return;
        }
	if (contextNsPtr == NULL) {
            Tcl_AppendResult(interp, " PANIC cannot get contextNsPtr in ItclReportObjectUsage", NULL);
	    return;
	}

	entry = Tcl_FindHashEntry(&infoPtr->namespaceClasses,
		(char *)contextNsPtr);
	if (entry) {
	    iclsPtr = (ItclClass *)Tcl_GetHashValue(entry);
	}

        if (iclsPtr == NULL) {
          Tcl_AppendResult(interp, " PANIC cannot get class from contextNsPtr ItclReportObjectUsage", NULL);
          return;
        }
    } else {
        iclsPtr = (ItclClass*)contextIoPtr->iclsPtr;
    }
    ignore = ITCL_CONSTRUCTOR | ITCL_DESTRUCTOR | ITCL_COMMON;
    /*
     *  Scan through all methods in the virtual table and sort
     *  them in alphabetical order.  Report only the methods
     *  that have simple names (no ::'s) and are accessible.
     */
    Itcl_InitList(&cmdList);
    entry = Tcl_FirstHashEntry(&iclsPtr->resolveCmds, &place);
    while (entry) {
        namePtr  = (Tcl_Obj *)Tcl_GetHashKey(&iclsPtr->resolveCmds, entry);
	name = Tcl_GetString(namePtr);
	clookup = (ItclCmdLookup *)Tcl_GetHashValue(entry);
	imPtr = clookup->imPtr;

        if (strstr(name,"::") || (imPtr->flags & ignore) != 0) {
            imPtr = NULL;
        } else {
	    if (imPtr->protection != ITCL_PUBLIC) {
		if (contextNsPtr != NULL) {
                    if (!Itcl_CanAccessFunc(imPtr, contextNsPtr)) {
                        imPtr = NULL;
                    }
                }
	    }
        }
        if ((imPtr != NULL) && (imPtr->codePtr != NULL)) {
	    if (imPtr->codePtr->flags & ITCL_BUILTIN) {
	        char *body;
	        if (imPtr->codePtr != NULL) {
	            body = Tcl_GetString(imPtr->codePtr->bodyPtr);
	            if (*body == '@') {
                        if (strcmp(body, "@itcl-builtin-setget") == 0) {
			    if (!(imPtr->iclsPtr->flags & ITCL_ECLASS)) {
	                        imPtr = NULL;
			    }
		        }
                        if (strcmp(body, "@itcl-builtin-installcomponent")
			        == 0) {
			    if (!(imPtr->iclsPtr->flags &
			            (ITCL_WIDGET|ITCL_WIDGETADAPTOR))) {
	                        imPtr = NULL;
			    }
		        }
	            }
	        }
	    }
	}

        if (imPtr) {
            elem = Itcl_FirstListElem(&cmdList);
            while (elem) {
                cmpFunc = (ItclMemberFunc*)Itcl_GetListValue(elem);
                cmp = strcmp(Tcl_GetString(imPtr->namePtr),
		        Tcl_GetString(cmpFunc->namePtr));
                if (cmp < 0) {
                    Itcl_InsertListElem(elem, imPtr);
                    imPtr = NULL;
                    break;
                } else {
		    if (cmp == 0) {
                        imPtr = NULL;
                        break;
		    }
                }
                elem = Itcl_NextListElem(elem);
            }
            if (imPtr) {
                Itcl_AppendList(&cmdList, imPtr);
            }
        }
        entry = Tcl_NextHashEntry(&place);
    }

    /*
     *  Add a series of statements showing usage info.
     */
    resultPtr = Tcl_GetObjResult(interp);
    elem = Itcl_FirstListElem(&cmdList);
    while (elem) {
        imPtr = (ItclMemberFunc*)Itcl_GetListValue(elem);
        Tcl_AppendToObj(resultPtr, "\n  ", TCL_INDEX_NONE);
        Itcl_GetMemberFuncUsage(imPtr, contextIoPtr, resultPtr);

        elem = Itcl_NextListElem(elem);
    }
    Itcl_DeleteList(&cmdList);
}

/*
 * ------------------------------------------------------------------------
 *  ItclTraceThisVar()
 *
 *  Invoked to handle read/write traces on the "this" variable built
 *  into each object.
 *
 *  On read, this procedure updates the "this" variable to contain the
 *  current object name.  This is done dynamically, since an object's
 *  identity can change if its access command is renamed.
 *
 *  On write, this procedure returns an error string, warning that
 *  the "this" variable cannot be set.
 * ------------------------------------------------------------------------
 */

static char*
ItclTraceThisVar(
    void *cdata,	      /* object instance data */
    Tcl_Interp *interp,	  /* interpreter managing this variable */
    const char *name1,    /* variable name */
    TCL_UNUSED(const char *),/* unused */
    int flags)		      /* flags indicating read/write */
{
    ItclObject *contextIoPtr = (ItclObject*)cdata;
    Tcl_Obj *objPtr;
    const char *objName;

    /* because of SF bug #187 use a different trace handler for "this", "win", "type"
     * *self" and "selfns"
     */

    /*
     *  Handle read traces on "this"
     */
    if ((flags & TCL_TRACE_READS) != 0) {
        objPtr = Tcl_NewStringObj("", TCL_INDEX_NONE);
        if (contextIoPtr->accessCmd) {
            Tcl_GetCommandFullName(contextIoPtr->iclsPtr->interp,
                contextIoPtr->accessCmd, objPtr);
        }
        objName = Tcl_GetString(objPtr);
        Tcl_SetVar2(interp, name1, NULL, objName, 0);

        Tcl_DecrRefCount(objPtr);
        return NULL;
    }

    /*
     *  Handle write traces on "this"
     */
    if ((flags & TCL_TRACE_WRITES) != 0) {
        return (char *)"variable \"this\" cannot be modified";
    }
    return NULL;
}

/*
 * ------------------------------------------------------------------------
 *  ItclTraceWinVar()
 *
 *  Invoked to handle read/write traces on the "win" variable built
 *  into each object.
 *
 *  On read, this procedure updates the "win" variable to contain the
 *  current object name.  This is done dynamically, since an object's
 *  identity can change if its access command is renamed.
 *
 *  On write, this procedure returns an error string, warning that
 *  the "win" variable cannot be set.
 * ------------------------------------------------------------------------
 */

static char*
ItclTraceWinVar(
    void *cdata,          /* object instance data */
    Tcl_Interp *interp,	  /* interpreter managing this variable */
    const char *name1,    /* variable name */
    TCL_UNUSED(const char *),/* unused */
    int flags)            /* flags indicating read/write */
{
    ItclObject *contextIoPtr = (ItclObject*)cdata;
    Tcl_DString buffer;
    Tcl_Obj *objPtr;
    const char *objName;
    const char *head;
    const char *tail;

    /*
     *  Handle read traces on "win"
     */
    if ((flags & TCL_TRACE_READS) != 0) {
        objPtr = Tcl_NewStringObj("", TCL_INDEX_NONE);
        /* a window path name must not contain namespace parts !! */
        Itcl_ParseNamespPath(Tcl_GetString(contextIoPtr->origNamePtr), &buffer, &head, &tail);
	if (tail == NULL) {
	    return (char *)" INTERNAL ERROR tail == NULL in ItclTraceThisVar for win";
	}
        Tcl_SetStringObj(objPtr, tail, TCL_INDEX_NONE);
        objName = Tcl_GetString(objPtr);
        Tcl_SetVar2(interp, name1, NULL, objName, 0);

        Tcl_DecrRefCount(objPtr);
        return NULL;
    }

    /*
     *  Handle write traces on "win"
     */
    if ((flags & TCL_TRACE_WRITES) != 0) {
        if (!(contextIoPtr->iclsPtr->flags & ITCL_ECLASS)) {
            return (char *)"variable \"win\" cannot be modified";
        }
    }
    return NULL;
}

/*
 * ------------------------------------------------------------------------
 *  ItclTraceTypeVar()
 *
 *  Invoked to handle read/write traces on the "type" variable built
 *  into each object.
 *
 *  On read, this procedure updates the "type" variable to contain the
 *  current object name.  This is done dynamically, since an object's
 *  identity can change if its access command is renamed.
 *
 *  On write, this procedure returns an error string, warning that
 *  the "type" variable cannot be set.
 * ------------------------------------------------------------------------
 */

static char*
ItclTraceTypeVar(
    void *cdata,          /* object instance data */
    Tcl_Interp *interp,	  /* interpreter managing this variable */
    const char *name1,    /* variable name */
    TCL_UNUSED(const char *),/* unused */
    int flags)            /* flags indicating read/write */
{
    ItclObject *contextIoPtr = (ItclObject*)cdata;
    Tcl_Obj *objPtr;
    const char *objName;

    /*
     *  Handle read traces on "type"
     */
    if ((flags & TCL_TRACE_READS) != 0) {
        objPtr = Tcl_NewStringObj("", TCL_INDEX_NONE);
        Tcl_SetStringObj(objPtr,
        Tcl_GetCurrentNamespace(contextIoPtr->iclsPtr->interp)->fullName, TCL_INDEX_NONE);
        objName = Tcl_GetString(objPtr);
        Tcl_SetVar2(interp, name1, NULL, objName, 0);

        Tcl_DecrRefCount(objPtr);
        return NULL;
    }

    /*
     *  Handle write traces on "type"
     */
    if ((flags & TCL_TRACE_WRITES) != 0) {
        return (char *)"variable \"type\" cannot be modified";
    }
    return NULL;
}

/*
 * ------------------------------------------------------------------------
 *  ItclTraceSelfVar()
 *
 *  Invoked to handle read/write traces on the "self" variable built
 *  into each object.
 *
 *  On read, this procedure updates the "self" variable to contain the
 *  current object name.  This is done dynamically, since an object's
 *  identity can change if its access command is renamed.
 *
 *  On write, this procedure returns an error string, warning that
 *  the "self" variable cannot be set.
 * ------------------------------------------------------------------------
 */

static char*
ItclTraceSelfVar(
    void *cdata,          /* object instance data */
    Tcl_Interp *interp,	  /* interpreter managing this variable */
    const char *name1,    /* variable name */
    TCL_UNUSED(const char *),/* unused */
    int flags)            /* flags indicating read/write */
{
    ItclObject *contextIoPtr = (ItclObject*)cdata;
    Tcl_Obj *objPtr;
    const char *objName;

    /*
     *  Handle read traces on "self"
     */
    if ((flags & TCL_TRACE_READS) != 0) {
        objPtr = Tcl_NewStringObj("", TCL_INDEX_NONE);
        if (contextIoPtr->iclsPtr->flags &
                (ITCL_WIDGET|ITCL_WIDGETADAPTOR)) {
            const char *objectName;

            objectName = ItclGetInstanceVar(
                    contextIoPtr->iclsPtr->interp,
                    "itcl_hull", NULL, contextIoPtr,
                    contextIoPtr->iclsPtr);
            if (strlen(objectName) == 0) {
	        objPtr = contextIoPtr->namePtr;
	        Tcl_IncrRefCount(objPtr);
            } else {
                Tcl_SetStringObj(objPtr, objectName, TCL_INDEX_NONE);
            }
        } else {
            Tcl_GetCommandFullName(contextIoPtr->iclsPtr->interp,
                    contextIoPtr->accessCmd, objPtr);
        }
        objName = Tcl_GetString(objPtr);
        Tcl_SetVar2(interp, name1, NULL, objName, 0);

        Tcl_DecrRefCount(objPtr);
        return NULL;
    }

    /*
     *  Handle write traces on "self"
     */
    if ((flags & TCL_TRACE_WRITES) != 0) {
        return (char *)"variable \"self\" cannot be modified";
    }
    return NULL;
}

/*
 * ------------------------------------------------------------------------
 *  ItclTraceSelfnsVar()
 *
 *  Invoked to handle read/write traces on the "selfns" variable built
 *  into each object.
 *
 *  On read, this procedure updates the "selfns" variable to contain the
 *  current object name.  This is done dynamically, since an object's
 *  identity can change if its access command is renamed.
 *
 *  On write, this procedure returns an error string, warning that
 *  the "selfns" variable cannot be set.
 * ------------------------------------------------------------------------
 */

static char*
ItclTraceSelfnsVar(
    void *cdata,          /* object instance data */
    Tcl_Interp *interp,	  /* interpreter managing this variable */
    const char *name1,    /* variable name */
    TCL_UNUSED(const char *),/* unused */
    int flags)	          /* flags indicating read/write */
{
    ItclObject *contextIoPtr = (ItclObject*)cdata;
    Tcl_Obj *objPtr;
    const char *objName;

    /*
     *  Handle read traces on "selfns"
     */
    if ((flags & TCL_TRACE_READS) != 0) {
        objPtr = Tcl_NewStringObj("", TCL_INDEX_NONE);
        Tcl_SetStringObj(objPtr, Tcl_GetString(contextIoPtr->varNsNamePtr), TCL_INDEX_NONE);
        Tcl_AppendToObj(objPtr,
                Tcl_GetString(contextIoPtr->iclsPtr->fullNamePtr), TCL_INDEX_NONE);
        objName = Tcl_GetString(objPtr);
        Tcl_SetVar2(interp, name1, NULL, objName, 0);

        Tcl_DecrRefCount(objPtr);
        return NULL;
    }

    /*
     *  Handle write traces on "selfns"
     */
    if ((flags & TCL_TRACE_WRITES) != 0) {
        return (char *)"variable \"selfns\" cannot be modified";
    }
    return NULL;
}

/*
 * ------------------------------------------------------------------------
 *  ItclTraceOptionVar()
 *
 *  Invoked to handle read/write traces on "option" variables
 *
 *  On read, this procedure checks if there is a cgetMethodPtr and calls it
 *  On write, this procedure checks if there is a configureMethodPtr
 *  or validateMethodPtr and calls it
 * ------------------------------------------------------------------------
 */

static char*
ItclTraceOptionVar(
    void *cdata,            /* object instance data */
    TCL_UNUSED(Tcl_Interp *),/* interpreter managing this variable */
    TCL_UNUSED(const char *),/* variable name */
    TCL_UNUSED(const char *),/* unused */
    int flags)              /* flags indicating read/write */
{
    ItclObject *ioPtr;
    ItclOption *ioptPtr;

/* FIXME !!! */
/* don't know yet if ItclTraceOptionVar is really needed !! */
/* FIXME should free memory on unset or rename!! */
    if (cdata != NULL) {
        ioPtr = (ItclObject*)cdata;
	if (ioPtr == NULL) {
	}
    } else {
        ioptPtr = (ItclOption*)cdata;
	if (ioptPtr == NULL) {
	}
        /*
         *  Handle read traces "itcl_options"
         */
        if ((flags & TCL_TRACE_READS) != 0) {
            return NULL;
        }

        /*
         *  Handle write traces "itcl_options"
         */
        if ((flags & TCL_TRACE_WRITES) != 0) {
            return NULL;
        }
    }
    return NULL;
}

/*
 * ------------------------------------------------------------------------
 *  ItclTraceComponentVar()
 *
 *  Invoked to handle read/write traces on "component" variables
 *
 * ------------------------------------------------------------------------
 */

static char*
ItclTraceComponentVar(
    void *cdata,            /* object instance data */
    Tcl_Interp *interp,	    /* interpreter managing this variable */
    const char *name1,      /* variable name */
    TCL_UNUSED(const char *),/* unused */
    int flags)              /* flags indicating read/write */
{
    FOREACH_HASH_DECLS;
    Tcl_HashEntry *hPtr2;
    Tcl_Obj *objPtr;
    Tcl_Obj *namePtr;
    Tcl_Obj *componentValuePtr;
    ItclObjectInfo *infoPtr;
    ItclObject *ioPtr;
    ItclComponent *icPtr;
    ItclDelegatedFunction *idmPtr;
    const char *val;

/* FIXME should free memory on unset or rename!! */
    if (cdata != NULL) {
        ioPtr = (ItclObject*)cdata;
        infoPtr = (ItclObjectInfo *)Tcl_GetAssocData(interp,
                ITCL_INTERP_DATA, NULL);
        hPtr = Tcl_FindHashEntry(&infoPtr->objects, (char *)ioPtr);
	if (hPtr == NULL) {
	    /* object does no longer exist or is being destructed */
	    return NULL;
	}
        objPtr = Tcl_NewStringObj(name1, TCL_INDEX_NONE);
	hPtr = Tcl_FindHashEntry(&ioPtr->objectComponents, (char *)objPtr);
        Tcl_DecrRefCount(objPtr);

        /*
         *  Handle write traces
         */
        if ((flags & TCL_TRACE_WRITES) != 0) {
	    if (ioPtr->noComponentTrace) {
	        return NULL;
	    }
            /* need to redo the delegation for this component !! */
            if (hPtr == NULL) {
                return (char *)" INTERNAL ERROR cannot get component to write to";
            }
            icPtr = (ItclComponent *)Tcl_GetHashValue(hPtr);
	    val = ItclGetInstanceVar(interp, name1, NULL, ioPtr,
                    ioPtr->iclsPtr);
	    if ((val == NULL) || (strlen(val) == 0)) {
	        return (char *)" INTERNAL ERROR cannot get value for component";
	    }
	    componentValuePtr = Tcl_NewStringObj(val, TCL_INDEX_NONE);
            Tcl_IncrRefCount(componentValuePtr);
	    namePtr = Tcl_NewStringObj(name1, TCL_INDEX_NONE);
            FOREACH_HASH_VALUE(idmPtr, &ioPtr->iclsPtr->delegatedFunctions) {
                if (idmPtr->icPtr == icPtr) {
		    hPtr2 = Tcl_FindHashEntry(&idmPtr->exceptions,
		            (char *)namePtr);
                    if (hPtr2 == NULL) {
                        DelegateFunction(interp, ioPtr, ioPtr->iclsPtr,
                                  componentValuePtr, idmPtr);
		     }
	        }
	    }
	    Tcl_DecrRefCount(componentValuePtr);
	    Tcl_DecrRefCount(namePtr);
            return NULL;
        }
        /*
         *  Handle read traces
         */
        if ((flags & TCL_TRACE_READS) != 0) {
        }

    } else {
        icPtr = (ItclComponent *)cdata;
        /*
         *  Handle read traces
         */
        if ((flags & TCL_TRACE_READS) != 0) {
            return NULL;
        }

        /*
         *  Handle write traces
         */
        if ((flags & TCL_TRACE_WRITES) != 0) {
            return NULL;
        }
    }
    return NULL;
}
/*
 * ------------------------------------------------------------------------
 *  ItclTraceItclHullVar()
 *
 *  Invoked to handle read/write traces on "itcl_hull" variables
 *
 *  On write, this procedure returns an error as "itcl_hull" may not be modfied
 *  after the first initialization
 * ------------------------------------------------------------------------
 */

static char*
ItclTraceItclHullVar(
    void *cdata,            /* object instance data */
    Tcl_Interp *interp,	    /* interpreter managing this variable */
    const char *name1,      /* variable name */
    TCL_UNUSED(const char *),/* unused */
    int flags)              /* flags indicating read/write */
{
    Tcl_HashEntry *hPtr;
    Tcl_Obj *objPtr;
    ItclObjectInfo *infoPtr;
    ItclObject *ioPtr;
    ItclVariable *ivPtr;

/* FIXME !!! */
/* FIXME should free memory on unset or rename!! */
    if (cdata != NULL) {
        ioPtr = (ItclObject*)cdata;
        infoPtr = (ItclObjectInfo *)Tcl_GetAssocData(interp,
                ITCL_INTERP_DATA, NULL);
        hPtr = Tcl_FindHashEntry(&infoPtr->objects, (char *)ioPtr);
	if (hPtr == NULL) {
	    /* object does no longer exist or is being destructed */
	    return NULL;
	}
        objPtr = Tcl_NewStringObj(name1, TCL_INDEX_NONE);
	hPtr = Tcl_FindHashEntry(&ioPtr->iclsPtr->variables, (char *)objPtr);
        Tcl_DecrRefCount(objPtr);
	if (hPtr == NULL) {
	    return (char *)"INTERNAL ERROR cannot find itcl_hull variable in class definition!!";
	}
	ivPtr = (ItclVariable *)Tcl_GetHashValue(hPtr);
        /*
         *  Handle write traces
         */
        if ((flags & TCL_TRACE_WRITES) != 0) {
	    if (ivPtr->initted == 0) {
		ivPtr->initted = 1;
                return NULL;
	    } else {
	        return (char *)"The itcl_hull component cannot be redefined";
	    }
        }

    } else {
        ivPtr = (ItclVariable *)cdata;
        /*
         *  Handle read traces
         */
        if ((flags & TCL_TRACE_READS) != 0) {
            return NULL;
        }

        /*
         *  Handle write traces
         */
        if ((flags & TCL_TRACE_WRITES) != 0) {
            return NULL;
        }
    }
    return NULL;
}

/*
 * ------------------------------------------------------------------------
 *  ItclDestroyObject()
 *
 *  Invoked when the object access command is deleted to implicitly
 *  destroy the object.  Invokes the object's destructors, ignoring
 *  any errors encountered along the way.  Removes the object from
 *  the list of all known objects and releases the access command's
 *  claim to the object data.
 *
 *  Note that the usual way to delete an object is via Itcl_DeleteObject().
 *  This procedure is provided as a back-up, to handle the case when
 *  an object is deleted by removing its access command.
 * ------------------------------------------------------------------------
 */
static void
ItclDestroyObject(
    void *cdata)  /* object instance data */
{
    ItclObject *contextIoPtr = (ItclObject*)cdata;
    Tcl_HashEntry *hPtr;
    Itcl_InterpState istate;

    if (contextIoPtr->flags & ITCL_OBJECT_IS_DESTROYED) {
        return;
    }
    contextIoPtr->flags |= ITCL_OBJECT_IS_DESTROYED;

    if (!(contextIoPtr->flags & ITCL_OBJECT_IS_DESTRUCTED)) {
        /*
         *  Attempt to destruct the object, but ignore any errors.
         */
        istate = Itcl_SaveInterpState(contextIoPtr->interp, 0);
        Itcl_DestructObject(contextIoPtr->interp, contextIoPtr,
                ITCL_IGNORE_ERRS);
        Itcl_RestoreInterpState(contextIoPtr->interp, istate);
    }

    /*
     *  Now, remove the object from the global object list.
     *  We're careful to do this here, after calling the destructors.
     *  Once the access command is nulled out, the "this" variable
     *  won't work properly.
     */
    if (contextIoPtr->accessCmd != NULL) {
        hPtr = Tcl_FindHashEntry(&contextIoPtr->infoPtr->objects,
            (char*)contextIoPtr);

        if (hPtr) {
            Tcl_DeleteHashEntry(hPtr);
        }
        contextIoPtr->accessCmd = NULL;
    }
    Itcl_ReleaseData(contextIoPtr);
}

/*
 * ------------------------------------------------------------------------
 *  FreeObject()
 *
 *  Deletes all instance variables and frees all memory associated with
 *  the given object instance.  Called when releases match preserves.
 * ------------------------------------------------------------------------
 */
static void
FreeObject(
    char * cdata)  /* object instance data */
{
    FOREACH_HASH_DECLS;
    Tcl_HashSearch place;
    ItclCallContext *callContextPtr;
    ItclObject *ioPtr;
    Tcl_Var var;

    ioPtr = (ItclObject*)cdata;

    /*
     *  Install the class namespace and object context so that
     *  the object's data members can be destroyed via simple
     *  "unset" commands.  This makes sure that traces work properly
     *  and all memory gets cleaned up.
     *
     *  NOTE:  Be careful to save and restore the interpreter state.
     *    Data can get freed in the middle of any operation, and
     *    we can't affort to clobber the interpreter with any errors
     *    from below.
     */

    ItclReleaseClass(ioPtr->iclsPtr);
    if (ioPtr->constructed) {
        Tcl_DeleteHashTable(ioPtr->constructed);
        ckfree((char*)ioPtr->constructed);
    }
    if (ioPtr->destructed) {
        Tcl_DeleteHashTable(ioPtr->destructed);
        ckfree((char*)ioPtr->destructed);
    }
    ItclDeleteObjectsDictInfo(ioPtr->interp, ioPtr);
    /*
     *  Delete all context definitions.
     */
    while (1) {
	hPtr = Tcl_FirstHashEntry(&ioPtr->contextCache, &place);
	if (hPtr == NULL) {
	    break;
	}
	callContextPtr = (ItclCallContext *)Tcl_GetHashValue(hPtr);
	Tcl_DeleteHashEntry(hPtr);
	ckfree((char *)callContextPtr);
    }
    FOREACH_HASH_VALUE(var, &ioPtr->objectVariables) {
	Itcl_ReleaseVar(var);
    }

    Tcl_DeleteHashTable(&ioPtr->contextCache);
    Tcl_DeleteHashTable(&ioPtr->objectVariables);
    Tcl_DeleteHashTable(&ioPtr->objectOptions);
    Tcl_DeleteHashTable(&ioPtr->objectComponents);
    Tcl_DeleteHashTable(&ioPtr->objectMethodVariables);
    Tcl_DeleteHashTable(&ioPtr->objectDelegatedOptions);
    Tcl_DeleteHashTable(&ioPtr->objectDelegatedFunctions);
    Tcl_DecrRefCount(ioPtr->namePtr);
    Tcl_DecrRefCount(ioPtr->origNamePtr);
    if (ioPtr->createNamePtr != NULL) {
        Tcl_DecrRefCount(ioPtr->createNamePtr);
    }
    if (ioPtr->hullWindowNamePtr != NULL) {
        Tcl_DecrRefCount(ioPtr->hullWindowNamePtr);
    }
    Tcl_DecrRefCount(ioPtr->varNsNamePtr);
    if (ioPtr->resolvePtr != NULL) {
	ckfree((char *)ioPtr->resolvePtr->clientData);
        ckfree((char*)ioPtr->resolvePtr);
    }
    Itcl_Free(ioPtr);
}

/*
 * ------------------------------------------------------------------------
 *  ItclObjectCmd()
 *
 * ------------------------------------------------------------------------
 */

static int
CallPublicObjectCmd(
    void *data[],
    Tcl_Interp *interp,
    int result)
{
    Tcl_Object *oPtr = (Tcl_Object *)data[0];
    Tcl_Class clsPtr = (Tcl_Class)data[1];
    Tcl_Obj *const *objv = (Tcl_Obj *const *)data[3];
    size_t objc = PTR2INT(data[2]);

    ItclShowArgs(1, "CallPublicObjectCmd", objc, objv);
    result = Itcl_PublicObjectCmd(oPtr, interp, clsPtr, objc, objv);
    ItclShowArgs(1, "CallPublicObjectCmd DONE", objc, objv);
    return result;
}

int
ItclObjectCmd(
    void *clientData,
    Tcl_Interp *interp,
    Tcl_Object oPtr,
    Tcl_Class clsPtr,
    size_t objc,
    Tcl_Obj *const *objv)
{
    Tcl_Obj *methodNamePtr;
    Tcl_Obj **newObjv;
    Tcl_DString buffer;
    Tcl_Obj *myPtr;
    ItclMemberFunc *imPtr;
    ItclClass *iclsPtr;
    Itcl_ListElem *elem;
    ItclClass *basePtr;
    void *callbackPtr;
    const char *className;
    const char *tail;
    const char *cp;
    int isDirectCall;
    int incr;
    int result;
    int found;

    ItclShowArgs(1, "ItclObjectCmd", objc, objv);

    incr = 0;
    found = 0;
    isDirectCall = 0;
    myPtr = NULL;
    imPtr = (ItclMemberFunc *)clientData;
    iclsPtr = imPtr->iclsPtr;
    if (oPtr == NULL) {
	ItclClass *icPtr = NULL;
	ItclObject *ioPtr = NULL;

	isDirectCall = (clsPtr == NULL);

	if ((imPtr->flags & ITCL_COMMON)
	        && (imPtr->codePtr != NULL)
	        && !(imPtr->codePtr->flags & ITCL_BUILTIN)) {
	    result = Itcl_InvokeProcedureMethod(imPtr->tmPtr, interp,
	            objc, objv);
            return result;
	}

	if (TCL_OK == Itcl_GetContext(interp, &icPtr, &ioPtr)) {
	    oPtr = ioPtr ? ioPtr->oPtr : icPtr->oPtr;
	} else {
	    Tcl_Panic("No Context");
	}
    }
    methodNamePtr = NULL;
    if (objv[0] != NULL) {
        Itcl_ParseNamespPath(Tcl_GetString(objv[0]), &buffer,
	        &className, &tail);
        if (className != NULL) {
            methodNamePtr = Tcl_NewStringObj(tail, TCL_INDEX_NONE);
	    /* look for the class in the hierarchy */
	    cp = className;
	    if ((*cp == ':') && (*(cp+1) == ':')) {
	        cp += 2;
	    }
            elem = Itcl_FirstListElem(&iclsPtr->bases);
	    if (elem == NULL) {
	        /* check the class itself */
		if (strcmp((const char *)cp,
		        (const char *)Tcl_GetString(iclsPtr->namePtr)) == 0) {
		    found = 1;
		    clsPtr = iclsPtr->clsPtr;
		}
	    }
            while (elem != NULL) {
                basePtr = (ItclClass*)Itcl_GetListValue(elem);
		if (strcmp((const char *)cp,
		        (const char *)Tcl_GetString(basePtr->namePtr)) == 0) {
		    clsPtr = basePtr->clsPtr;
		    found = 1;
		    break;
		}
                elem = Itcl_NextListElem(elem);
	    }
	    if (!found) {
		found = 1;
		clsPtr = iclsPtr->clsPtr;
	    }
        }
        Tcl_DStringFree(&buffer);
    } else {
	/* Can this happen? */
	Tcl_Panic("objv[0] is NULL?!");
	/* Panic above replaces obviously broken line below.  Creating
	 * a string value from uninitialized memory cannot possibly be
	 * a correct thing to do.

        methodNamePtr = Tcl_NewStringObj(tail, TCL_INDEX_NONE);
	 */
    }
    if (isDirectCall) {
	if (!found) {
	    if (methodNamePtr != NULL) {
	        Tcl_DecrRefCount(methodNamePtr);
	    }
            methodNamePtr = objv[0];
        }
    }
    callbackPtr = Itcl_GetCurrentCallbackPtr(interp);
    newObjv = NULL;
    if (methodNamePtr != NULL) {
	if (iclsPtr->flags & (ITCL_TYPE|ITCL_WIDGETADAPTOR)) {
	    char *myName;
	    /* special handling for mytypemethod, mymethod, myproc */
	    myName = Tcl_GetString(methodNamePtr);
	    if (strcmp(myName, "mytypemethod") == 0) {
                result = Itcl_BiMyTypeMethodCmd(iclsPtr, interp, objc, objv);
		return result;
	    }
	    if (strcmp(myName, "mymethod") == 0) {
                result = Itcl_BiMyMethodCmd(iclsPtr, interp, objc, objv);
		return result;
	    }
	    if (strcmp(myName, "myproc") == 0) {
                result = Itcl_BiMyProcCmd(iclsPtr, interp, objc, objv);
		return result;
	    }
	    if (strcmp(myName, "mytypevar") == 0) {
                result = Itcl_BiMyTypeVarCmd(iclsPtr, interp, objc, objv);
		return result;
	    }
	    if (strcmp(myName, "myvar") == 0) {
                result = Itcl_BiMyVarCmd(iclsPtr, interp, objc, objv);
		return result;
	    }
	    if (strcmp(myName, "itcl_hull") == 0) {
                result = Itcl_BiItclHullCmd(iclsPtr, interp, objc, objv);
		return result;
	    }
	    if (strcmp(myName, "callinstance") == 0) {
                result = Itcl_BiCallInstanceCmd(iclsPtr, interp, objc, objv);
		return result;
	    }
	    if (strcmp(myName, "getinstancevar") == 0) {
                result = Itcl_BiGetInstanceVarCmd(iclsPtr, interp, objc, objv);
		return result;
	    }
	    if (strcmp(myName, "installcomponent") == 0) {
                result = Itcl_BiInstallComponentCmd(iclsPtr, interp, objc, objv);
		return result;
	    }
	}
        incr = 1;
        newObjv = (Tcl_Obj **)ckalloc(sizeof(Tcl_Obj *)*(objc+incr));
        myPtr = Tcl_NewStringObj("my", 2);
        Tcl_IncrRefCount(myPtr);
        Tcl_IncrRefCount(methodNamePtr);
        newObjv[0] = myPtr;
        newObjv[1] = methodNamePtr;
        memcpy(newObjv+incr+1, objv+1, (sizeof(Tcl_Obj*)*(objc-1)));
	ItclShowArgs(1, "run CallPublicObjectCmd1", objc+incr, newObjv);
	Tcl_NRAddCallback(interp, CallPublicObjectCmd, oPtr, clsPtr,
	        INT2PTR(objc+incr), newObjv);

    } else {
	ItclShowArgs(1, "run CallPublicObjectCmd2", objc, objv);
	Tcl_NRAddCallback(interp, CallPublicObjectCmd, oPtr, clsPtr,
		INT2PTR(objc), (void *)objv);
    }

    result = Itcl_NRRunCallbacks(interp, callbackPtr);
    if (methodNamePtr != NULL) {
        ckfree((char *)newObjv);
        Tcl_DecrRefCount(methodNamePtr);
    }
    if (myPtr != NULL) {
        Tcl_DecrRefCount(myPtr);
    }
    return result;
}

/*
 * ------------------------------------------------------------------------
 *  GetClassFromClassName()
 * ------------------------------------------------------------------------
 */

ItclClass *
GetClassFromClassName(
    Tcl_Interp *interp,
    const char *className,
    ItclClass *iclsPtr)
{
    Tcl_Obj *objPtr;
    Tcl_HashEntry *hPtr;
    ItclObjectInfo *infoPtr;
    ItclClass *basePtr;
    Itcl_ListElem *elem;
    const char *chkPtr;
    int chkLgth;
    int lgth;

    /* look for the class in the hierarchy */
    /* first check the class itself */
    if (iclsPtr != NULL) {
        if (strcmp(className,
                (const char *)Tcl_GetString(iclsPtr->namePtr)) == 0) {
	    return iclsPtr;
	}
        elem = Itcl_FirstListElem(&iclsPtr->bases);
        while (elem != NULL) {
            basePtr = (ItclClass*)Itcl_GetListValue(elem);
	    basePtr = GetClassFromClassName(interp, className, basePtr);
	    if (basePtr != NULL) {
	        return basePtr;
	    }
            elem = Itcl_NextListElem(elem);
        }
        /* now try to match the classes full name last part with the className */
        lgth = strlen(className);
        elem = Itcl_FirstListElem(&iclsPtr->bases);
        while (elem != NULL) {
            basePtr = (ItclClass*)Itcl_GetListValue(elem);
	    chkPtr = basePtr->nsPtr->fullName;
	    chkLgth = strlen(chkPtr);
	    if (chkLgth >= lgth) {
	        chkPtr = chkPtr + chkLgth - lgth;
	        if (strcmp(chkPtr, className) == 0) {
	            return basePtr;
	        }
	    }
            elem = Itcl_NextListElem(elem);
        }
        infoPtr = iclsPtr->infoPtr;
    } else {
        infoPtr = (ItclObjectInfo *)Tcl_GetAssocData(interp,
                ITCL_INTERP_DATA, NULL);
    }
    /* as a last chance try with className in hash table */
    objPtr = Tcl_NewStringObj(className, TCL_INDEX_NONE);
    Tcl_IncrRefCount(objPtr);
    hPtr = Tcl_FindHashEntry(&infoPtr->nameClasses, (char *)objPtr);
    if (hPtr != NULL) {
        iclsPtr = (ItclClass *)Tcl_GetHashValue(hPtr);
    } else {
        iclsPtr = NULL;
    }
    Tcl_DecrRefCount(objPtr);
    return iclsPtr;
}

/*
 * ------------------------------------------------------------------------
 *  ItclMapMethodNameProc()
 * ------------------------------------------------------------------------
 */

int
ItclMapMethodNameProc(
    Tcl_Interp *interp,
    Tcl_Object oPtr,
    Tcl_Class *startClsPtr,
    Tcl_Obj *methodObj)
{
    Tcl_Obj *methodName;
    Tcl_Obj *className;
    Tcl_DString buffer;
    Tcl_HashEntry *hPtr;
    Tcl_Namespace * myNsPtr;
    ItclObject *ioPtr;
    ItclClass *iclsPtr;
    ItclClass *iclsPtr2;
    ItclObjectInfo *infoPtr;
    const char *head;
    const char *tail;
    const char *sp;

    iclsPtr = NULL;
    iclsPtr2 = NULL;
    methodName = NULL;
    infoPtr = (ItclObjectInfo *)Tcl_GetAssocData(interp,
            ITCL_INTERP_DATA, NULL);
    ioPtr = (ItclObject *)Tcl_ObjectGetMetadata(oPtr,
            infoPtr->object_meta_type);
    hPtr = Tcl_FindHashEntry(&infoPtr->objects, (char *)ioPtr);
    if ((hPtr == NULL) || (ioPtr == NULL)) {
        /* try to get the class (if a class is creating an object) */
        iclsPtr = (ItclClass *)Tcl_ObjectGetMetadata(oPtr,
            infoPtr->class_meta_type);
        hPtr = Tcl_FindHashEntry(&infoPtr->classes, (char *)iclsPtr);
	if (hPtr == NULL) {
	    char str[20];
	    sprintf(str, "%p", iclsPtr);
	    Tcl_AppendResult(interp, "context class has vanished 1", str, NULL);
            return TCL_ERROR;
	}
    } else {
        hPtr = Tcl_FindHashEntry(&infoPtr->classes, (char *)ioPtr->iclsPtr);
	if (hPtr == NULL) {
	    char str[20];
	    sprintf(str, "%p", ioPtr->iclsPtr);
	    Tcl_AppendResult(interp, "context class has vanished 2", str, NULL);
            return TCL_ERROR;
	}
        iclsPtr = ioPtr->iclsPtr;
    }
    sp = Tcl_GetString(methodObj);
    Itcl_ParseNamespPath(sp, &buffer, &head, &tail);
    if (head == NULL) {
        /* itcl bug #3600923 call private method in class
	 * without namespace
	 */
        myNsPtr = Tcl_GetCurrentNamespace(iclsPtr->interp);
	hPtr = Tcl_FindHashEntry(&infoPtr->namespaceClasses, (char *) myNsPtr);
	if (hPtr) {
	    iclsPtr2 = (ItclClass *) Tcl_GetHashValue(hPtr);
	    if (Itcl_IsMethodCallFrame(iclsPtr->interp) > 0) {
		iclsPtr = iclsPtr2;
	    }
	}
    }
    if (head != NULL) {
        className = NULL;
        methodName = Tcl_NewStringObj(tail, TCL_INDEX_NONE);
        Tcl_IncrRefCount(methodName);
        className = Tcl_NewStringObj(head, TCL_INDEX_NONE);
        Tcl_IncrRefCount(className);
	if (strlen(head) > 0) {
	    iclsPtr2 = GetClassFromClassName(interp, head, iclsPtr);
	} else {
	    iclsPtr2 = NULL;
	}
	if (iclsPtr2 != NULL) {
	    *startClsPtr = iclsPtr2->clsPtr;
	    Tcl_SetStringObj(methodObj, Tcl_GetString(methodName), TCL_INDEX_NONE);
	}
        Tcl_DecrRefCount(className);
        Tcl_DecrRefCount(methodName);
    }
    hPtr = Tcl_FindHashEntry(&iclsPtr->resolveCmds, (char *)methodObj);
    if (hPtr == NULL) {
        /* special case: we found the class for the class command,
	 * for a relative or absolute class path name
	 * but we have no method in that class that fits.
	 * Problem of Rene Zaumseil when having the object
	 * for a class in a child namespace of the class
	 * fossil ticket id: 36577626c340ad59615f0a0238d67872c009a8c9
	 */
        *startClsPtr = NULL;
    } else {
	ItclMemberFunc *imPtr;
	Tcl_Namespace *nsPtr;
	ItclCmdLookup *clookup;

	nsPtr = Tcl_GetCurrentNamespace(interp);
	clookup = (ItclCmdLookup *)Tcl_GetHashValue(hPtr);
	imPtr = clookup->imPtr;
        if (!Itcl_CanAccessFunc(imPtr, nsPtr)) {
	    char *token = Tcl_GetString(imPtr->namePtr);
	    if ((*token != 'i') || (strcmp(token, "info") != 0)) {
		/* needed for test protect-2.5 */
	        ItclMemberFunc *imPtr2 = NULL;
                Tcl_HashEntry *hPtr;
	        Tcl_ObjectContext context;
	        context = (Tcl_ObjectContext)Itcl_GetCallFrameClientData(interp);
                if (context != NULL) {
	            hPtr = Tcl_FindHashEntry(
		            &imPtr->iclsPtr->infoPtr->procMethods,
	                    (char *)Tcl_ObjectContextMethod(context));
	            if (hPtr != NULL) {
	                imPtr2 = (ItclMemberFunc *)Tcl_GetHashValue(hPtr);
	            }
		    if ((imPtr->protection & ITCL_PRIVATE) &&
		            (imPtr2 != NULL) &&
		            (imPtr->iclsPtr->nsPtr != imPtr2->iclsPtr->nsPtr)) {
                        Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
		                "invalid command name \"",
			        token,
			        "\"", NULL);
		        return TCL_ERROR;
		    }
                }
		/* END needed for test protect-2.5 */
                if (ioPtr == NULL) {
                    /* itcl in fossil ticket: 2cd667f270b68ef66d668338e09d144e20405e23 */
                    Tcl_HashEntry *hPtr;
                    Tcl_Obj * objPtr;
	            ItclMemberFunc *imPtr2 = NULL;
                    ItclCmdLookup *clookupPtr;

                    objPtr = Tcl_NewStringObj(token, TCL_INDEX_NONE);
                    hPtr = Tcl_FindHashEntry(&iclsPtr->resolveCmds, (char *)objPtr);
	            if (hPtr != NULL) {
	                clookupPtr = (ItclCmdLookup *)Tcl_GetHashValue(hPtr);
                        imPtr2 = clookupPtr->imPtr;
                    }
		    if ((imPtr->protection & ITCL_PRIVATE) &&
		            (imPtr2 != NULL) &&
		            (imPtr->iclsPtr->nsPtr == imPtr2->iclsPtr->nsPtr)) {
                        Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
		                "invalid command name \"",
			        token,
			        "\"", NULL);
		        return TCL_ERROR;
		    }
                } else {
                    Tcl_AppendResult(interp,
                           "bad option \"", token, "\": should be one of...",
                        NULL);
	            ItclReportObjectUsage(interp, ioPtr, nsPtr, nsPtr);
                    return TCL_ERROR;

                }
            }
        }
    }
    Tcl_DStringFree(&buffer);
    return TCL_OK;
}

int
ExpandDelegateAs(
    Tcl_Interp *interp,
    ItclObject *ioPtr,
    ItclClass *iclsPtr,
    ItclDelegatedFunction *idmPtr,
    const char *funcName,
    Tcl_Obj *listPtr)
{
    Tcl_Obj *componentNamePtr;
    Tcl_Obj *objPtr;
    const char **argv;
    const char *val;
    Tcl_Size argc;
    Tcl_Size j;


    if (idmPtr->icPtr == NULL) {
        componentNamePtr = NULL;
    } else {
        componentNamePtr = idmPtr->icPtr->namePtr;
    }
    if (idmPtr->asPtr != NULL) {
        Tcl_SplitList(interp, Tcl_GetString(idmPtr->asPtr),
	        &argc, &argv);
        for(j=0;j<argc;j++) {
            Tcl_ListObjAppendElement(interp, listPtr,
                    Tcl_NewStringObj(argv[j], TCL_INDEX_NONE));
        }
	ckfree((char *)argv);
    } else {
	if (idmPtr->usingPtr != NULL) {
	    char *cp;
	    char *ep;
	    int hadDoublePercent;
            Tcl_Obj *strPtr;

	    strPtr = NULL;
	    hadDoublePercent = 0;
	    cp = Tcl_GetString(idmPtr->usingPtr);
	    ep = cp;
	    strPtr = Tcl_NewStringObj("", TCL_INDEX_NONE);
	    while (*ep != '\0') {
	        if (*ep == '%') {
		    if (*(ep+1) == '%') {
			cp++;
			cp++;
		        ep++;
		        ep++;
			hadDoublePercent = 1;
			Tcl_AppendToObj(strPtr, "%", TCL_INDEX_NONE);
		        continue;
		    }
		    switch (*(ep+1)) {
		    case 'c':
			if (componentNamePtr == NULL) {
			    ep++;
			    continue;
			}
			if (ep-cp-1 > 0) {
		            Tcl_ListObjAppendElement(interp, listPtr,
			            Tcl_NewStringObj(cp, ep-cp-1));
			}
                        objPtr = Tcl_NewStringObj(ITCL_VARIABLES_NAMESPACE, TCL_INDEX_NONE);
			Tcl_AppendToObj(objPtr, (Tcl_GetObjectNamespace(
				iclsPtr->oPtr))->fullName, TCL_INDEX_NONE);
                        Tcl_AppendToObj(objPtr, "::", TCL_INDEX_NONE);
                        Tcl_AppendToObj(objPtr,
			        Tcl_GetString(componentNamePtr), TCL_INDEX_NONE);
                        val = Tcl_GetVar2(interp, Tcl_GetString(objPtr),
			        NULL, 0);
			Tcl_DecrRefCount(objPtr);
			Tcl_AppendToObj(strPtr,
			        val, TCL_INDEX_NONE);
		        break;
		    case 'j':
		    case 'm':
		    case 'M':
			if (ep-cp-1 > 0) {
		            Tcl_ListObjAppendElement(interp, listPtr,
			            Tcl_NewStringObj(cp, ep-cp-1));
			}
			if (strcmp(Tcl_GetString(idmPtr->namePtr), "*") == 0) {
			    Tcl_AppendToObj(strPtr, funcName, TCL_INDEX_NONE);
			} else {
			    Tcl_AppendToObj(strPtr,
			            Tcl_GetString(idmPtr->namePtr), TCL_INDEX_NONE);
			}
		        break;
		    case 'n':
			if (iclsPtr->flags & ITCL_TYPE) {
			    ep++;
			    continue;
			} else {
			    if (ep-cp-1 > 0) {
		                Tcl_ListObjAppendElement(interp, listPtr,
			                Tcl_NewStringObj(cp, ep-cp-1));
			    }
			    Tcl_AppendToObj(strPtr, iclsPtr->nsPtr->name, TCL_INDEX_NONE);
			}
		        break;
		    case 's':
			if (iclsPtr->flags & ITCL_TYPE) {
			    ep++;
			    continue;
			} else {
			    if (ep-cp-1 > 0) {
		                Tcl_ListObjAppendElement(interp, listPtr,
			                Tcl_NewStringObj(cp, ep-cp-1));
			    }
                            Tcl_AppendToObj(strPtr,
			            Tcl_GetString(ioPtr->namePtr), TCL_INDEX_NONE);
			}
		        break;
		    case 't':
			if (ep-cp-1 > 0) {
		            Tcl_ListObjAppendElement(interp, listPtr,
			            Tcl_NewStringObj(cp, ep-cp-1));
			}
                        Tcl_AppendToObj(strPtr, iclsPtr->nsPtr->fullName, TCL_INDEX_NONE);
		        break;
		    case 'w':
			if (iclsPtr->flags & ITCL_TYPE) {
			    ep++;
			    continue;
			} else {
			    if (ep-cp-1 > 0) {
		                Tcl_ListObjAppendElement(interp, listPtr,
			                Tcl_NewStringObj(cp, ep-cp-1));
			    }
		        }
		        break;
		    case ':':
		        /* substitute with contents of variable after ':' */
			if (iclsPtr->flags & ITCL_ECLASS) {
			    if (ep-cp-1 > 0) {
		                Tcl_ListObjAppendElement(interp, listPtr,
			                Tcl_NewStringObj(cp, ep-cp-1));
			    }
			    ep++;
			    cp = ep + 1;
			    while (*ep && (*ep != ' ')) {
			        ep++;
			    }
			    if (ep-cp > 0) {
				Tcl_Obj *my_obj;
				const char *cp2;

                                my_obj = Tcl_NewStringObj(cp, ep-cp);
				if (iclsPtr->infoPtr->currIoPtr != NULL) {
				  cp2 = GetConstructorVar(interp, iclsPtr,
				      Tcl_GetString(my_obj));
				} else {
                                  cp2 = ItclGetInstanceVar(interp,
                                      Tcl_GetString(my_obj), NULL, ioPtr,
				      iclsPtr);
				}
				if (cp2 != NULL) {
                                    Tcl_AppendToObj(strPtr, cp2, TCL_INDEX_NONE);
				}
			        ep -= 2; /* to fit for code after default !! */
			    }
		            break;
		        } else {
			}
		    /* FALLTHRU */
		    default:
		      {
			char buf[2];
			buf[1] = '\0';
			sprintf(buf, "%c", *(ep+1));
			Tcl_AppendResult(interp,
			        "there is no %%", buf, " substitution",
				NULL);
			if (strPtr != NULL) {
			    Tcl_DecrRefCount(strPtr);
			}
			return TCL_ERROR;
		      }
		    }
		    Tcl_ListObjAppendElement(interp, listPtr, strPtr);
		    hadDoublePercent = 0;
		    strPtr = Tcl_NewStringObj("", TCL_INDEX_NONE);
		    ep +=2;
		    cp = ep;
		} else {
		    if (*ep == ' ') {
                        if (strlen(Tcl_GetString(strPtr)) > 0) {
			    if (ep-cp == 0) {
			        Tcl_ListObjAppendElement(interp, listPtr,
				        strPtr);
			        strPtr = Tcl_NewStringObj("", TCL_INDEX_NONE);
			    }
			}
			if (ep-cp > 0) {
			    Tcl_AppendToObj(strPtr, cp, ep-cp);
		            Tcl_ListObjAppendElement(interp, listPtr, strPtr);
	                    strPtr = Tcl_NewStringObj("", TCL_INDEX_NONE);
			}
		        while((*ep != '\0') && (*ep == ' ')) {
			    ep++;
			}
			cp = ep;
		    } else {
		        ep++;
		    }
		}
	    }
	    if (hadDoublePercent) {
		    /* FIXME need code here */
	    }
	    if (cp != ep) {
		if (*ep == '\0') {
                    Tcl_ListObjAppendElement(interp, listPtr,
	                    Tcl_NewStringObj(cp, ep-cp));
		} else {
                    Tcl_ListObjAppendElement(interp, listPtr,
	                    Tcl_NewStringObj(cp, ep-cp-1));
	        }
	    }
	    if (strPtr != NULL) {
	        Tcl_DecrRefCount(strPtr);
	    }
	} else {
            Tcl_ListObjAppendElement(interp, listPtr, idmPtr->namePtr);
        }
    }
    return TCL_OK;
}

/*
 * ------------------------------------------------------------------------
 *  DelegationFunction()
 * ------------------------------------------------------------------------
 */

int
DelegateFunction(
    Tcl_Interp *interp,
    ItclObject *ioPtr,
    ItclClass *iclsPtr,
    Tcl_Obj *componentValuePtr,
    ItclDelegatedFunction *idmPtr)
{
    Tcl_Obj *listPtr;
    const char *val;
    int result;
    Tcl_Method mPtr;

    listPtr = Tcl_NewListObj(0, NULL);
    if (componentValuePtr != NULL) {
	if (idmPtr->usingPtr == NULL) {
            Tcl_ListObjAppendElement(interp, listPtr, componentValuePtr);
        }
    }
    result = ExpandDelegateAs(interp, ioPtr, iclsPtr, idmPtr,
            Tcl_GetString(idmPtr->namePtr), listPtr);
    if (result != TCL_OK) {
	Tcl_DecrRefCount(listPtr);
        return result;
    }
    val = Tcl_GetString(listPtr);
    if (val == NULL) {
        /* FIXME need code here */
    }
    if (componentValuePtr != NULL) {
        mPtr = Itcl_NewForwardClassMethod(interp, iclsPtr->clsPtr, 1,
                idmPtr->namePtr, listPtr);
        if (mPtr != NULL) {
            return TCL_OK;
        }
    }
    if (idmPtr->usingPtr != NULL) {
        mPtr = Itcl_NewForwardClassMethod(interp, iclsPtr->clsPtr, 1,
                idmPtr->namePtr, listPtr);
        if (mPtr != NULL) {
            return TCL_OK;
        }
    }
    return TCL_ERROR;
}

/*
 * ------------------------------------------------------------------------
 *  DelegatedOptionsInstall()
 * ------------------------------------------------------------------------
 */

int
DelegatedOptionsInstall(
    TCL_UNUSED(Tcl_Interp *),
    ItclClass *iclsPtr)
{
    Tcl_HashEntry *hPtr2;
    Tcl_HashSearch search2;
    ItclDelegatedOption *idoPtr;
    ItclOption *ioptPtr;
    FOREACH_HASH_DECLS;
    char *optionName;

    FOREACH_HASH_VALUE(idoPtr, &iclsPtr->delegatedOptions) {
	optionName = Tcl_GetString(idoPtr->namePtr);
	if (*optionName == '*') {
	    /* allow nested FOREACH */
	    search2 = search;
	    FOREACH_HASH_VALUE(ioptPtr, &iclsPtr->options) {
	        if (Tcl_FindHashEntry(&idoPtr->exceptions,
		        (char *)idoPtr->namePtr) == NULL) {
		    ioptPtr->idoPtr = idoPtr;
		    Itcl_PreserveData(ioptPtr->idoPtr);
		}
	    }
	    search = search2;
	} else {
            hPtr2 = Tcl_FindHashEntry(&iclsPtr->options,
	            (char *)idoPtr->namePtr);
	    if (hPtr2 == NULL) {
		ioptPtr = NULL;
	    } else {
	        ioptPtr = (ItclOption *)Tcl_GetHashValue(hPtr2);
	        ioptPtr->idoPtr = idoPtr;
	    }
	    idoPtr->ioptPtr = ioptPtr;
        }
    }
    return TCL_OK;
}

/*
 * ------------------------------------------------------------------------
 *  GetConstructorVar()
 *  get an object variable when in executing the constructor
 * ------------------------------------------------------------------------
 */

static const char *
GetConstructorVar(
    Tcl_Interp *interp,
    ItclClass *iclsPtr,
    const char *varName)

{
    Tcl_HashEntry *hPtr;
    Tcl_Obj *objPtr;
    Tcl_DString buffer;
    ItclVarLookup *vlookup;
    ItclVariable *ivPtr;
    const char *val;

    hPtr = ItclResolveVarEntry(iclsPtr, (char *)varName);
    if (hPtr == NULL) {
	/* no such variable */
        return NULL;
    }
    vlookup = (ItclVarLookup *)Tcl_GetHashValue(hPtr);
    if (vlookup == NULL) {
        return NULL;
    }
    ivPtr = vlookup->ivPtr;
    if (ivPtr == NULL) {
        return NULL;
    }
    if (ivPtr->flags & ITCL_COMMON) {
        /* look for a common variable */
        objPtr = Tcl_NewStringObj(ITCL_VARIABLES_NAMESPACE, TCL_INDEX_NONE);
        Tcl_AppendToObj(objPtr, (Tcl_GetObjectNamespace(
		iclsPtr->oPtr))->fullName, TCL_INDEX_NONE);
        Tcl_AppendToObj(objPtr, "::", TCL_INDEX_NONE);
        Tcl_AppendToObj(objPtr, varName, TCL_INDEX_NONE);
        val = Tcl_GetVar2(interp, Tcl_GetString(objPtr), NULL, 0);
        Tcl_DecrRefCount(objPtr);
    } else {
        /* look for a normal variable */
        Tcl_DStringInit(&buffer);
        Tcl_DStringAppend(&buffer,
                Tcl_GetString(iclsPtr->infoPtr->currIoPtr->varNsNamePtr), TCL_INDEX_NONE);
        Tcl_DStringAppend(&buffer, ivPtr->iclsPtr->nsPtr->fullName, TCL_INDEX_NONE);
        Tcl_DStringAppend(&buffer, "::", TCL_INDEX_NONE);
        Tcl_DStringAppend(&buffer, varName, TCL_INDEX_NONE);
        val = Tcl_GetVar2(interp, Tcl_DStringValue(&buffer), NULL, 0);
        Tcl_DStringFree(&buffer);
    }
    return val;
}

/*
 * ------------------------------------------------------------------------
 *  DelegationInstall()
 * ------------------------------------------------------------------------
 */

int
DelegationInstall(
    Tcl_Interp *interp,
    ItclObject *ioPtr,
    ItclClass *iclsPtr)
{
    Tcl_HashEntry *hPtr2;
    Tcl_HashSearch search2;
    Tcl_Obj *componentValuePtr;
    Tcl_DString buffer;
    ItclDelegatedFunction *idmPtr;
    ItclMemberFunc *imPtr;
    ItclVariable *ivPtr;
    FOREACH_HASH_DECLS;
    char *methodName;
    const char *val;
    int result;
    int noDelegate;
    int delegateAll;

    result = TCL_OK;
    delegateAll = 0;
    ioPtr->noComponentTrace = 1;
    noDelegate = ITCL_CONSTRUCTOR|ITCL_DESTRUCTOR|ITCL_COMPONENT;
    componentValuePtr = NULL;
    FOREACH_HASH_VALUE(idmPtr, &iclsPtr->delegatedFunctions) {
	methodName = Tcl_GetString(idmPtr->namePtr);
	if (*methodName == '*') {
	    delegateAll = 1;
	}
	if (idmPtr->icPtr != NULL) {
	    Tcl_Obj *objPtr;
	    /* we cannot use Itcl_GetInstanceVar here as the object is not
	     * yet completely built. So use the varNsNamePtr
	     */
	    ivPtr = idmPtr->icPtr->ivPtr;
            if (ivPtr->flags & ITCL_COMMON) {
	        objPtr = Tcl_NewStringObj(ITCL_VARIABLES_NAMESPACE, TCL_INDEX_NONE);

	        Tcl_AppendToObj(objPtr, (Tcl_GetObjectNamespace(
			ivPtr->iclsPtr->oPtr))->fullName, TCL_INDEX_NONE);
	        Tcl_AppendToObj(objPtr, "::", TCL_INDEX_NONE);
	        Tcl_AppendToObj(objPtr,
		        Tcl_GetString(idmPtr->icPtr->namePtr), TCL_INDEX_NONE);
	        val = Tcl_GetVar2(interp, Tcl_GetString(objPtr), NULL, 0);
	        Tcl_DecrRefCount(objPtr);
	    } else {
                Tcl_DStringInit(&buffer);
                Tcl_DStringAppend(&buffer,
                        Tcl_GetString(ioPtr->varNsNamePtr), TCL_INDEX_NONE);
                Tcl_DStringAppend(&buffer,
                        Tcl_GetString(ivPtr->fullNamePtr), TCL_INDEX_NONE);
                val = Tcl_GetVar2(interp,
                            Tcl_DStringValue(&buffer), NULL, 0);
                Tcl_DStringFree(&buffer);
	    }
	    componentValuePtr = Tcl_NewStringObj(val, TCL_INDEX_NONE);
            Tcl_IncrRefCount(componentValuePtr);
	} else {
	    componentValuePtr = NULL;
	}
	if (!delegateAll) {
	    result = DelegateFunction(interp, ioPtr, iclsPtr,
	            componentValuePtr, idmPtr);
	    if (result != TCL_OK) {
                ioPtr->noComponentTrace = 0;
	        return result;
	    }
	} else {
	    /* save to allow nested FOREACH */
            search2 = search;
            FOREACH_HASH_VALUE(imPtr, &iclsPtr->functions) {
	        methodName = Tcl_GetString(imPtr->namePtr);
                if (imPtr->flags & noDelegate) {
		    continue;
		}
                if (strcmp(methodName, "info") == 0) {
	            continue;
	        }
                if (strcmp(methodName, "isa") == 0) {
	            continue;
	        }
                if (strcmp(methodName, "createhull") == 0) {
	            continue;
	        }
                if (strcmp(methodName, "keepcomponentoption") == 0) {
	            continue;
	        }
                if (strcmp(methodName, "ignorecomponentoption") == 0) {
	            continue;
	        }
                if (strcmp(methodName, "renamecomponentoption") == 0) {
	            continue;
	        }
                if (strcmp(methodName, "setupcomponent") == 0) {
	            continue;
	        }
                if (strcmp(methodName, "itcl_initoptions") == 0) {
	            continue;
	        }
                if (strcmp(methodName, "mytypemethod") == 0) {
	            continue;
	        }
                if (strcmp(methodName, "mymethod") == 0) {
	            continue;
	        }
                if (strcmp(methodName, "myproc") == 0) {
	            continue;
	        }
                if (strcmp(methodName, "mytypevar") == 0) {
	            continue;
	        }
                if (strcmp(methodName, "myvar") == 0) {
	            continue;
	        }
                if (strcmp(methodName, "itcl_hull") == 0) {
	            continue;
	        }
                if (strcmp(methodName, "callinstance") == 0) {
	            continue;
	        }
                if (strcmp(methodName, "getinstancevar") == 0) {
	            continue;
	        }
                hPtr2 = Tcl_FindHashEntry(&idmPtr->exceptions,
		        (char *)imPtr->namePtr);
                if (hPtr2 != NULL) {
		    continue;
		}
	        result = DelegateFunction(interp, ioPtr, iclsPtr,
	                componentValuePtr, idmPtr);
	        if (result != TCL_OK) {
	            break;
	        }
            }
            search = search2;
        }
	if (componentValuePtr != NULL) {
            Tcl_DecrRefCount(componentValuePtr);
        }
    }
    ioPtr->noComponentTrace = 0;
    result = DelegatedOptionsInstall(interp, iclsPtr);
    return result;
}

/*
 * ------------------------------------------------------------------------
 *  ItclInitExtendedClassOptions()
 * ------------------------------------------------------------------------
 */

static int
ItclInitExtendedClassOptions(
    Tcl_Interp *interp,
    ItclObject *ioPtr)
{
    ItclClass *iclsPtr;
    ItclOption *ioptPtr;
    ItclHierIter hier;
    FOREACH_HASH_DECLS;

    iclsPtr = ioPtr->iclsPtr;
    Itcl_InitHierIter(&hier, iclsPtr);
    while ((iclsPtr = Itcl_AdvanceHierIter(&hier)) != NULL) {
        FOREACH_HASH_VALUE(ioptPtr, &iclsPtr->options) {
            if (ioptPtr->defaultValuePtr != NULL) {
		if (ItclGetInstanceVar(interp, "itcl_options",
		        Tcl_GetString(ioptPtr->namePtr), ioPtr, iclsPtr)
			== NULL) {
	        }
            }
	}
    }
    Itcl_DeleteHierIter(&hier);
    return TCL_OK;
}

ItclClass *
ItclNamespace2Class(Tcl_Namespace *nsPtr)
{
    ItclObjectInfo * infoPtr;
    Tcl_HashEntry *hPtr;
    infoPtr = (ItclObjectInfo *)Tcl_GetAssocData(((Namespace *)nsPtr)->interp,
	ITCL_INTERP_DATA, NULL);
    hPtr = Tcl_FindHashEntry(&(infoPtr->namespaceClasses), nsPtr);
    if (hPtr == NULL) {
	return NULL;
    }
    return (ItclClass *)Tcl_GetHashValue(hPtr);
}
