itcl_objects.c

linux 下的源代码分析阅读器 red hat公司新版

/*
 * ------------------------------------------------------------------------
 *      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
 *           [e-mail]
 *           http://www.tcltk.com/itcl
 *
 *     RCS:  $Id: itcl_objects.c 144 2003-02-05 10:56:26Z mdejong $
 * ========================================================================
 *           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 "itclInt.h"

/*
 *  FORWARD DECLARATIONS
 */
static void ItclReportObjectUsage _ANSI_ARGS_((Tcl_Interp *interp,
    ItclObject* obj));

static char* ItclTraceThisVar _ANSI_ARGS_((ClientData cdata,
    Tcl_Interp *interp, char *name1, char *name2, int flags));

static void ItclDestroyObject _ANSI_ARGS_((ClientData cdata));
static void ItclFreeObject _ANSI_ARGS_((char* cdata));

static int ItclDestructBase _ANSI_ARGS_((Tcl_Interp *interp,
    ItclObject* obj, ItclClass* cdefn, int flags));

static void ItclCreateObjVar _ANSI_ARGS_((Tcl_Interp *interp,
    ItclVarDefn* vdefn, ItclObject* obj));


/*
 * ------------------------------------------------------------------------
 *  Itcl_CreateObject()
 *
 *  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, along with a pointer
 *  to the new object data in roPtr.
 * ------------------------------------------------------------------------
 */
int
Itcl_CreateObject(interp, name, cdefn, objc, objv, roPtr)
    Tcl_Interp *interp;      /* interpreter mananging new object */
    char* name;              /* name of new object */
    ItclClass *cdefn;        /* class for new object */
    int objc;                /* number of arguments */
    Tcl_Obj *CONST objv[];   /* argument objects */
    ItclObject **roPtr;      /* returns: pointer to object data */
{
    ItclClass *cdefnPtr = (ItclClass*)cdefn;
    int result = TCL_OK;

    char *head, *tail;
    Tcl_DString buffer, objName;
    Tcl_Namespace *parentNs;
    ItclContext context;
    Tcl_Command cmd;
    ItclObject *newObj;
    ItclClass *cdPtr;
    ItclVarDefn *vdefn;
    ItclHierIter hier;
    Tcl_HashEntry *entry;
    Tcl_HashSearch place;
    int newEntry;
    Itcl_InterpState istate;

    /*
     *  If installing an object access command will clobber another
     *  command, signal an error.  Be careful to look for the object
     *  only in the current namespace context.  Otherwise, we might
     *  find a global command, but that wouldn't be clobbered!
     */
    cmd = Tcl_FindCommand(interp, name, (Tcl_Namespace*)NULL,
        TCL_NAMESPACE_ONLY);

    if (cmd != NULL && !Itcl_IsStub(cmd)) {
        Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
            "command \"", name, "\" already exists in namespace \"",
            Tcl_GetCurrentNamespace(interp)->fullName, "\"",
            (char*)NULL);
        return TCL_ERROR;
    }

    /*
     *  Extract the namespace context and the simple object
     *  name for the new object.
     */
    Itcl_ParseNamespPath(name, &buffer, &head, &tail);
    if (head) {
        parentNs = Itcl_FindClassNamespace(interp, head);

        if (!parentNs) {
            Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
                "namespace \"", head, "\" not found in context \"",
                Tcl_GetCurrentNamespace(interp)->fullName, "\"",
                (char*)NULL);
            Tcl_DStringFree(&buffer);
            return TCL_ERROR;
        }
    } else {
        parentNs = Tcl_GetCurrentNamespace(interp);
    }

    Tcl_DStringInit(&objName);
    if (parentNs != Tcl_GetGlobalNamespace(interp)) {
        Tcl_DStringAppend(&objName, parentNs->fullName, -1);
    }
    Tcl_DStringAppend(&objName, "::", -1);
    Tcl_DStringAppend(&objName, tail, -1);

    /*
     *  Create a new object and initialize it.
     */
    newObj = (ItclObject*)ckalloc(sizeof(ItclObject));
    newObj->classDefn = cdefnPtr;
    Itcl_PreserveData((ClientData)cdefnPtr);

    newObj->dataSize = cdefnPtr->numInstanceVars;
    newObj->data = (Var**)ckalloc((unsigned)(newObj->dataSize*sizeof(Var*)));

    newObj->constructed = (Tcl_HashTable*)ckalloc(sizeof(Tcl_HashTable));
    Tcl_InitHashTable(newObj->constructed, TCL_STRING_KEYS);
    newObj->destructed = NULL;

    /*
     *  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((ClientData)newObj);
    newObj->accessCmd = Tcl_CreateObjCommand(interp,
        Tcl_DStringValue(&objName), Itcl_HandleInstance,
        (ClientData)newObj, ItclDestroyObject);

    Itcl_PreserveData((ClientData)newObj);  /* while we're using this... */
    Itcl_EventuallyFree((ClientData)newObj, ItclFreeObject);

    Tcl_DStringFree(&buffer);
    Tcl_DStringFree(&objName);

    /*
     *  Install the class namespace and object context so that
     *  the object's data members can be initialized via simple
     *  "set" commands.
     */
    if (Itcl_PushContext(interp, (ItclMember*)NULL, cdefnPtr, newObj,
        &context) != TCL_OK) {

        return TCL_ERROR;
    }

    Itcl_InitHierIter(&hier, cdefn);

    cdPtr = Itcl_AdvanceHierIter(&hier);
    while (cdPtr != NULL) {
        entry = Tcl_FirstHashEntry(&cdPtr->variables, &place);
        while (entry) {
            vdefn = (ItclVarDefn*)Tcl_GetHashValue(entry);
            if ((vdefn->member->flags & ITCL_THIS_VAR) != 0) {
                if (cdPtr == cdefnPtr) {
                    ItclCreateObjVar(interp, vdefn, newObj);
                    Tcl_SetVar2(interp, "this", (char*)NULL, "", 0);
                    Tcl_TraceVar2(interp, "this", (char*)NULL,
                        TCL_TRACE_READS|TCL_TRACE_WRITES, ItclTraceThisVar,
                        (ClientData)newObj);
                }
            }
            else if ( (vdefn->member->flags & ITCL_COMMON) == 0) {
                ItclCreateObjVar(interp, vdefn, newObj);
            }
            entry = Tcl_NextHashEntry(&place);
        }
        cdPtr = Itcl_AdvanceHierIter(&hier);
    }
    Itcl_DeleteHierIter(&hier);

    Itcl_PopContext(interp, &context);  /* back to calling context */

    /*
     *  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.
     */
    result = Itcl_InvokeMethodIfExists(interp, "constructor",
        cdefn, newObj, objc, objv);

    /*
     *  If there is no constructor, construct the base classes
     *  in case they have constructors.  This will cause the
     *  same chain reaction.
     */
    if (!Tcl_FindHashEntry(&cdefn->functions, "constructor")) {
        result = Itcl_ConstructBase(interp, newObj, cdefn);
    }

    /*
     *  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);

        Tcl_DeleteCommandFromToken(interp, newObj->accessCmd);
        newObj->accessCmd = NULL;

        result = Itcl_RestoreInterpState(interp, istate);
    }

    /*
     *  At this point, the object is fully constructed.
     *  Destroy the "constructed" table in the object data, since
     *  it is no longer needed.
     */
    Tcl_DeleteHashTable(newObj->constructed);
    ckfree((char*)newObj->constructed);
    newObj->constructed = NULL;

    /*
     *  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) && (newObj->accessCmd != NULL)) {
        entry = Tcl_CreateHashEntry(&cdefnPtr->info->objects,
            (char*)newObj->accessCmd, &newEntry);

        Tcl_SetHashValue(entry, (ClientData)newObj);
    }

    /*
     *  Release the object.  If it was destructed above, it will
     *  die at this point.
     */
    Itcl_ReleaseData((ClientData)newObj);

    *roPtr = newObj;
    return result;
}


/*
 * ------------------------------------------------------------------------
 *  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(interp, contextObj)
    Tcl_Interp *interp;      /* interpreter mananging object */
    ItclObject *contextObj;  /* object to be deleted */
{
    ItclClass *cdefnPtr = (ItclClass*)contextObj->classDefn;

    Tcl_HashEntry *entry;
    Command *cmdPtr;

    Itcl_PreserveData((ClientData)contextObj);

    /*
     *  Invoke the object's destructors.
     */
    if (Itcl_DestructObject(interp, contextObj, 0) != TCL_OK) {
        Itcl_ReleaseData((ClientData)contextObj);
        return TCL_ERROR;
    }

    /*
     *  Remove the object from the global list.
     */
    entry = Tcl_FindHashEntry(&cdefnPtr->info->objects,
        (char*)contextObj->accessCmd);

    if (entry) {
        Tcl_DeleteHashEntry(entry);
    }

    /*
     *  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.
     */
    cmdPtr = (Command*)contextObj->accessCmd;
    cmdPtr->deleteProc = Itcl_ReleaseData;

    Tcl_DeleteCommandFromToken(interp, contextObj->accessCmd);
    contextObj->accessCmd = NULL;

    Itcl_ReleaseData((ClientData)contextObj);  /* object should die here */

    return TCL_OK;
}


/*
 * ------------------------------------------------------------------------
 *  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(interp, contextObj, flags)
    Tcl_Interp *interp;      /* interpreter mananging new object */
    ItclObject *contextObj;  /* object to be destructed */
    int flags;               /* flags: ITCL_IGNORE_ERRS */
{
    int result;

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

    /*
     *  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.
     */
    contextObj->destructed = (Tcl_HashTable*)ckalloc(sizeof(Tcl_HashTable));
    Tcl_InitHashTable(contextObj->destructed, TCL_STRING_KEYS);

    /*
     *  Destruct the object starting from the most-specific class.
     *  If all goes well, return the null string as the result.
     */
    result = ItclDestructBase(interp, contextObj, contextObj->classDefn, flags);

    if (result == TCL_OK) {
        Tcl_ResetResult(interp);
    }

    Tcl_DeleteHashTable(contextObj->destructed);
    ckfree((char*)contextObj->destructed);
    contextObj->destructed = NULL;

    return result;
}