URL https://opencores.org/ocsvn/or1k/or1k/trunk
Subversion Repositories or1k

[/] [or1k/] [trunk/] [insight/] [itcl/] [itcl/] [generic/] [itcl_objects.c] - Blame information for rev 1773

Go to most recent revision | Details | Compare with Previous | View Log

/*
 * ------------------------------------------------------------------------
 *      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
 *
 *     RCS:  $Id: itcl_objects.c,v 1.1.1.1 2002-01-16 10:24:46 markom Exp $
 * ========================================================================
 *           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.
     */
    cmd = Tcl_FindCommand(interp, name, (Tcl_Namespace*)NULL, /* flags */ 0);
    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);
        if (newObj->accessCmd != NULL) {
            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;
}
 
/*
 * ------------------------------------------------------------------------
 *  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(interp, contextObj, contextClass, flags)
    Tcl_Interp *interp;       /* interpreter */
    ItclObject *contextObj;   /* object being destructed */
    ItclClass *contextClass;  /* current class being destructed */
    int flags;                /* flags: ITCL_IGNORE_ERRS */
{
    int result;
    Itcl_ListElem *elem;
    ItclClass *cdefn;
 
    /*
     *  Look for a destructor in this class, and if found,
     *  invoke it.
     */
    if (!Tcl_FindHashEntry(contextObj->destructed, contextClass->name)) {
 
        result = Itcl_InvokeMethodIfExists(interp, "destructor",
            contextClass, contextObj, 0, (Tcl_Obj* CONST*)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(&contextClass->bases);
    while (elem) {
        cdefn = (ItclClass*)Itcl_GetListValue(elem);
 
        if (ItclDestructBase(interp, contextObj, cdefn, 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(interp, name, roPtr)
    Tcl_Interp *interp;      /* interpreter containing this object */
    char *name;              /* name of the object */
    ItclObject **roPtr;      /* returns: object data or NULL */
{
    Tcl_Namespace *contextNs = NULL;
 
    char *cmdName;
    Tcl_Command cmd;
    Command *cmdPtr;
 
    /*
     *  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)) {
        cmdPtr = (Command*)cmd;
        *roPtr = (ItclObject*)cmdPtr->objClientData;
    }
    else {
        *roPtr = NULL;
    }
 
    if (cmdName != name) {
        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(cmd)
    Tcl_Command cmd;         /* command being tested */
{
    Command *cmdPtr = (Command*)cmd;
 
    if (cmdPtr->deleteProc == ItclDestroyObject) {
        return 1;
    }
 
    /*
     *  This may be an imported command.  Try to get the real
     *  command and see if it represents an object.
     */
    cmdPtr = (Command*)TclGetOriginalCommand(cmd);
    if (cmdPtr && cmdPtr->deleteProc == 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(contextObj, cdefn)
    ItclObject *contextObj;   /* object being tested */
    ItclClass *cdefn;         /* class to test for "is-a" relationship */
{
    Tcl_HashEntry *entry;
    entry = Tcl_FindHashEntry(&contextObj->classDefn->heritage, (char*)cdefn);
    return (entry != NULL);
}
 
 
/*
 * ------------------------------------------------------------------------
 *  Itcl_HandleInstance()
 *
 *  Invoked by Tcl whenever the user issues a command associated with
 *  an object instance.  Handles the following syntax:
 *
 *    <objName> <method> <args>...
 *
 * ------------------------------------------------------------------------
 */
int
Itcl_HandleInstance(clientData, interp, objc, objv)
    ClientData clientData;   /* object definition */
    Tcl_Interp *interp;      /* current interpreter */
    int objc;                /* number of arguments */
    Tcl_Obj *CONST objv[];   /* argument objects */
{
    ItclObject *contextObj = (ItclObject*)clientData;
 
    int result;
    char *token;
    Tcl_HashEntry *entry;
    ItclMemberFunc *mfunc;
    ItclObjectInfo *info;
    ItclContext context;
    CallFrame *framePtr;
 
    if (objc < 2) {
        Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
            "wrong # args: should be one of...",
            (char*)NULL);
        ItclReportObjectUsage(interp, contextObj);
        return TCL_ERROR;
    }
 
    /*
     *  Make sure that the specified operation is really an
     *  object method, and it is accessible.  If not, return usage
     *  information for the object.
     */
    token = Tcl_GetStringFromObj(objv[1], (int*)NULL);
    mfunc = NULL;
 
    entry = Tcl_FindHashEntry(&contextObj->classDefn->resolveCmds, token);
    if (entry) {
        mfunc = (ItclMemberFunc*)Tcl_GetHashValue(entry);
 
        if ((mfunc->member->flags & ITCL_COMMON) != 0) {
            mfunc = NULL;
        }
        else if (mfunc->member->protection != ITCL_PUBLIC) {
            Tcl_Namespace *contextNs = Itcl_GetTrueNamespace(interp,
                mfunc->member->classDefn->info);
 
            if (!Itcl_CanAccessFunc(mfunc, contextNs)) {
                mfunc = NULL;
            }
        }
    }
 
    if ( !mfunc && (*token != 'i' || strcmp(token,"info") != 0) ) {
        Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
            "bad option \"", token, "\": should be one of...",
            (char*)NULL);
        ItclReportObjectUsage(interp, contextObj);
        return TCL_ERROR;
    }
 
    /*
     *  Install an object context and invoke the method.
     *
     *  TRICKY NOTE:  We need to pass the object context into the
     *    method, but activating the context here puts us one level
     *    down, and when the method is called, it will activate its
     *    own context, putting us another level down.  If anyone
     *    were to execute an "uplevel" command in the method, they
     *    would notice the extra call frame.  So we mark this frame
     *    as "transparent" and Itcl_EvalMemberCode will automatically
     *    do an "uplevel" operation to correct the problem.
     */
    info = contextObj->classDefn->info;
 
    if (Itcl_PushContext(interp, (ItclMember*)NULL, contextObj->classDefn,
        contextObj, &context) != TCL_OK) {
 
        return TCL_ERROR;
    }
 
    framePtr = &context.frame;
    Itcl_PushStack((ClientData)framePtr, &info->transparentFrames);
 
    result = Itcl_EvalArgs(interp, objc-1, objv+1);
 
    Itcl_PopStack(&info->transparentFrames);
    Itcl_PopContext(interp, &context);
 
    return result;
}
 
 
/*
 * ------------------------------------------------------------------------
 *  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.
 * ------------------------------------------------------------------------
 */
char*
Itcl_GetInstanceVar(interp, name, contextObj, contextClass)
    Tcl_Interp *interp;       /* current interpreter */
    char *name;               /* name of desired instance variable */
    ItclObject *contextObj;   /* current object */
    ItclClass *contextClass;  /* name is interpreted in this scope */
{
    ItclContext context;
    char *val;
 
    /*
     *  Make sure that the current namespace context includes an
     *  object that is being manipulated.
     */
    if (contextObj == NULL) {
        Tcl_ResetResult(interp);
        Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
            "cannot access object-specific info without an object context",
            (char*)NULL);
        return NULL;
    }
 
    /*
     *  Install the object context and access the data member
     *  like any other variable.
     */
    if (Itcl_PushContext(interp, (ItclMember*)NULL, contextClass,
        contextObj, &context) != TCL_OK) {
 
        return NULL;
    }
 
    val = Tcl_GetVar2(interp, name, (char*)NULL, TCL_LEAVE_ERR_MSG);
    Itcl_PopContext(interp, &context);
 
    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().
 * ------------------------------------------------------------------------
 */
static void
ItclReportObjectUsage(interp, contextObj)
    Tcl_Interp *interp;      /* current interpreter */
    ItclObject *contextObj;  /* current object */
{
    ItclClass *cdefnPtr = (ItclClass*)contextObj->classDefn;
    int ignore = ITCL_CONSTRUCTOR | ITCL_DESTRUCTOR | ITCL_COMMON;
 
    int cmp;
    char *name;
    Itcl_List cmdList;
    Itcl_ListElem *elem;
    Tcl_HashEntry *entry;
    Tcl_HashSearch place;
    ItclMemberFunc *mfunc, *cmpDefn;
    Tcl_Obj *resultPtr;
 
    /*
     *  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(&cdefnPtr->resolveCmds, &place);
    while (entry) {
        name  = Tcl_GetHashKey(&cdefnPtr->resolveCmds, entry);
        mfunc = (ItclMemberFunc*)Tcl_GetHashValue(entry);
 
        if (strstr(name,"::") || (mfunc->member->flags & ignore) != 0) {
            mfunc = NULL;
        }
        else if (mfunc->member->protection != ITCL_PUBLIC) {
            Tcl_Namespace *contextNs = Itcl_GetTrueNamespace(interp,
                mfunc->member->classDefn->info);
 
            if (!Itcl_CanAccessFunc(mfunc, contextNs)) {
                mfunc = NULL;
            }
        }
 
        if (mfunc) {
            elem = Itcl_FirstListElem(&cmdList);
            while (elem) {
                cmpDefn = (ItclMemberFunc*)Itcl_GetListValue(elem);
                cmp = strcmp(mfunc->member->name, cmpDefn->member->name);
                if (cmp < 0) {
                    Itcl_InsertListElem(elem, (ClientData)mfunc);
                    mfunc = NULL;
                    break;
                }
                else if (cmp == 0) {
                    mfunc = NULL;
                    break;
                }
                elem = Itcl_NextListElem(elem);
            }
            if (mfunc) {
                Itcl_AppendList(&cmdList, (ClientData)mfunc);
            }
        }
        entry = Tcl_NextHashEntry(&place);
    }
 
    /*
     *  Add a series of statements showing usage info.
     */
    resultPtr = Tcl_GetObjResult(interp);
    elem = Itcl_FirstListElem(&cmdList);
    while (elem) {
        mfunc = (ItclMemberFunc*)Itcl_GetListValue(elem);
        Tcl_AppendToObj(resultPtr, "\n  ", -1);
        Itcl_GetMemberFuncUsage(mfunc, contextObj, 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.
 * ------------------------------------------------------------------------
 */
/* ARGSUSED */
static char*
ItclTraceThisVar(cdata, interp, name1, name2, flags)
    ClientData cdata;        /* object instance data */
    Tcl_Interp *interp;      /* interpreter managing this variable */
    char *name1;             /* variable name */
    char *name2;             /* unused */
    int flags;               /* flags indicating read/write */
{
    ItclObject *contextObj = (ItclObject*)cdata;
    char *objName;
    Tcl_Obj *objPtr;
 
    /*
     *  Handle read traces on "this"
     */
    if ((flags & TCL_TRACE_READS) != 0) {
        objPtr = Tcl_NewStringObj("", -1);
        Tcl_IncrRefCount(objPtr);
 
        if (contextObj->accessCmd) {
            Tcl_GetCommandFullName(contextObj->classDefn->interp,
                contextObj->accessCmd, objPtr);
        }
 
        objName = Tcl_GetStringFromObj(objPtr, (int*)NULL);
        Tcl_SetVar(interp, name1, objName, 0);
 
        Tcl_DecrRefCount(objPtr);
        return NULL;
    }
 
    /*
     *  Handle write traces on "this"
     */
    if ((flags & TCL_TRACE_WRITES) != 0) {
        return "variable \"this\" cannot be modified";
    }
    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(cdata)
    ClientData cdata;  /* object instance data */
{
    ItclObject *contextObj = (ItclObject*)cdata;
    ItclClass *cdefnPtr = (ItclClass*)contextObj->classDefn;
    Tcl_HashEntry *entry;
    Itcl_InterpState istate;
 
    /*
     *  Attempt to destruct the object, but ignore any errors.
     */
    istate = Itcl_SaveInterpState(cdefnPtr->interp, 0);
    Itcl_DestructObject(cdefnPtr->interp, contextObj, ITCL_IGNORE_ERRS);
    Itcl_RestoreInterpState(cdefnPtr->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 (contextObj->accessCmd) {
        entry = Tcl_FindHashEntry(&cdefnPtr->info->objects,
            (char*)contextObj->accessCmd);
 
        if (entry) {
            Tcl_DeleteHashEntry(entry);
        }
        contextObj->accessCmd = NULL;
    }
 
    Itcl_ReleaseData((ClientData)contextObj);
}
 
 
/*
 * ------------------------------------------------------------------------
 *  ItclFreeObject()
 *
 *  Deletes all instance variables and frees all memory associated with
 *  the given object instance.  This is usually invoked automatically
 *  by Itcl_ReleaseData(), when an object's data is no longer being used.
 * ------------------------------------------------------------------------
 */
static void
ItclFreeObject(cdata)
    char* cdata;  /* object instance data */
{
    ItclObject *contextObj = (ItclObject*)cdata;
    Tcl_Interp *interp = contextObj->classDefn->interp;
 
    int i;
    ItclClass *cdPtr;
    ItclHierIter hier;
    Tcl_HashSearch place;
    Tcl_HashEntry *entry;
    ItclVarDefn *vdefn;
    ItclContext context;
    Itcl_InterpState istate;
 
    /*
     *  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.
     */
    istate = Itcl_SaveInterpState(interp, 0);
 
    /*
     *  Scan through all object-specific data members and destroy the
     *  actual variables that maintain the object state.  Do this
     *  by unsetting each variable, so that traces are fired off
     *  correctly.  Make sure that the built-in "this" variable is
     *  only destroyed once.  Also, be careful to activate the
     *  namespace for each class, so that private variables can
     *  be accessed.
     */
    Itcl_InitHierIter(&hier, contextObj->classDefn);
    cdPtr = Itcl_AdvanceHierIter(&hier);
    while (cdPtr != NULL) {
 
        if (Itcl_PushContext(interp, (ItclMember*)NULL, cdPtr,
            contextObj, &context) == TCL_OK) {
 
            entry = Tcl_FirstHashEntry(&cdPtr->variables, &place);
            while (entry) {
                vdefn = (ItclVarDefn*)Tcl_GetHashValue(entry);
                if ((vdefn->member->flags & ITCL_THIS_VAR) != 0) {
                    if (cdPtr == contextObj->classDefn) {
                        Tcl_UnsetVar2(interp, vdefn->member->fullname,
                            (char*)NULL, 0);
                    }
                }
                else if ((vdefn->member->flags & ITCL_COMMON) == 0) {
                    Tcl_UnsetVar2(interp, vdefn->member->fullname,
                        (char*)NULL, 0);
                }
                entry = Tcl_NextHashEntry(&place);
            }
            Itcl_PopContext(interp, &context);
        }
 
        cdPtr = Itcl_AdvanceHierIter(&hier);
    }
    Itcl_DeleteHierIter(&hier);
 
    /*
     *  Free the memory associated with object-specific variables.
     *  For normal variables this would be done automatically by
     *  CleanupVar() when the variable is unset.  But object-specific
     *  variables are protected by an extra reference count, and they
     *  must be deleted explicitly here.
     */
    for (i=0; i < contextObj->dataSize; i++) {
        if (contextObj->data[i]) {
            ckfree((char*)contextObj->data[i]);
        }
    }
 
    Itcl_RestoreInterpState(interp, istate);
 
    /*
     *  Free any remaining memory associated with the object.
     */
    ckfree((char*)contextObj->data);
 
    if (contextObj->constructed) {
        Tcl_DeleteHashTable(contextObj->constructed);
        ckfree((char*)contextObj->constructed);
    }
    if (contextObj->destructed) {
        Tcl_DeleteHashTable(contextObj->destructed);
        ckfree((char*)contextObj->destructed);
    }
    Itcl_ReleaseData((ClientData)contextObj->classDefn);
 
    ckfree((char*)contextObj);
}
 
 
/*
 * ------------------------------------------------------------------------
 *  ItclCreateObjVar()
 *
 *  Creates one variable acting as a data member for a specific
 *  object.  Initializes the variable according to its definition,
 *  and sets up its reference count so that it cannot be deleted
 *  by ordinary means.  Installs the new variable directly into
 *  the data array for the specified object.
 * ------------------------------------------------------------------------
 */
static void
ItclCreateObjVar(interp, vdefn, contextObj)
    Tcl_Interp* interp;       /* interpreter managing this object */
    ItclVarDefn* vdefn;       /* variable definition */
    ItclObject* contextObj;   /* object being updated */
{
    Var *varPtr;
    Tcl_HashEntry *entry;
    ItclVarLookup *vlookup;
    ItclContext context;
 
    varPtr = _TclNewVar();
    varPtr->name = vdefn->member->name;
    varPtr->nsPtr = (Namespace*)vdefn->member->classDefn->namesp;
 
    /*
     *  NOTE:  Tcl reports a "dangling upvar" error for variables
     *         with a null "hPtr" field.  Put something non-zero
     *         in here to keep Tcl_SetVar2() happy.  The only time
     *         this field is really used is it remove a variable
     *         from the hash table that contains it in CleanupVar,
     *         but since these variables are protected by their
     *         higher refCount, they will not be deleted by CleanupVar
     *         anyway.  These variables are unset and removed in
     *         ItclFreeObject().
     */
    varPtr->hPtr = (Tcl_HashEntry*)0x1;
    varPtr->refCount = 1;  /* protect from being deleted */
 
    /*
     *  Install the new variable in the object's data array.
     *  Look up the appropriate index for the object using
     *  the data table in the class definition.
     */
    entry = Tcl_FindHashEntry(&contextObj->classDefn->resolveVars,
        vdefn->member->fullname);
 
    if (entry) {
        vlookup = (ItclVarLookup*)Tcl_GetHashValue(entry);
        contextObj->data[vlookup->var.index] = varPtr;
    }
 
    /*
     *  If this variable has an initial value, initialize it
     *  here using a "set" command.
     *
     *  TRICKY NOTE:  We push an object context for the class that
     *    owns the variable, so that we don't have any trouble
     *    accessing it.
     */
    if (vdefn->init) {
        if (Itcl_PushContext(interp, (ItclMember*)NULL,
            vdefn->member->classDefn, contextObj, &context) == TCL_OK) {
 
            Tcl_SetVar2(interp, vdefn->member->fullname,
                (char*)NULL, vdefn->init, 0);
            Itcl_PopContext(interp, &context);
        }
    }
}
 
 
/*
 * ------------------------------------------------------------------------
 *  Itcl_ScopedVarResolver()
 *
 *  This procedure is installed to handle variable resolution throughout
 *  an entire interpreter.  It looks for scoped variable references of
 *  the form:
 *
 *    @itcl ::namesp::namesp::object variable
 *
 *  If a reference like this is recognized, this procedure finds the
 *  desired variable in the object and returns the variable, along with
 *  the status code TCL_OK.  If the variable does not start with
 *  "@itcl", this procedure returns TCL_CONTINUE, and variable
 *  resolution continues using the normal rules.  If anything goes
 *  wrong, this procedure returns TCL_ERROR, and access to the
 *  variable is denied.
 * ------------------------------------------------------------------------
 */
int
Itcl_ScopedVarResolver(interp, name, contextNs, flags, rPtr)
    Tcl_Interp *interp;        /* current interpreter */
    char *name;                /* variable name being resolved */
    Tcl_Namespace *contextNs;  /* current namespace context */
    int flags;                 /* TCL_LEAVE_ERR_MSG => leave error message */
    Tcl_Var *rPtr;             /* returns: resolved variable */
{
    int namec;
    char **namev;
    Tcl_Interp *errs;
    Tcl_CmdInfo cmdInfo;
    ItclObject *contextObj;
    ItclVarLookup *vlookup;
    Tcl_HashEntry *entry;
 
    /*
     *  See if the variable starts with "@itcl".  If not, then
     *  let the variable resolution process continue.
     */
    if (*name != '@' || strncmp(name, "@itcl", 5) != 0) {
        return TCL_CONTINUE;
    }
 
    /*
     *  Break the variable name into parts and extract the object
     *  name and the variable name.
     */
    if (flags & TCL_LEAVE_ERR_MSG) {
        errs = interp;
    } else {
        errs = NULL;
    }
 
    if (Tcl_SplitList(errs, name, &namec, &namev) != TCL_OK) {
        return TCL_ERROR;
    }
    if (namec != 3) {
        if (errs) {
            Tcl_AppendStringsToObj(Tcl_GetObjResult(errs),
                "scoped variable \"", name, "\" is malformed: ",
                "should be: @itcl object variable",
                (char*)NULL);
        }
        ckfree((char*)namev);
        return TCL_ERROR;
    }
 
    /*
     *  Look for the command representing the object and extract
     *  the object context.
     */
    if (!Tcl_GetCommandInfo(interp, namev[1], &cmdInfo)) {
        if (errs) {
            Tcl_AppendStringsToObj(Tcl_GetObjResult(errs),
                "can't resolve scoped variable \"", name, "\": ",
                "can't find object ", namev[1],
                (char*)NULL);
        }
        ckfree((char*)namev);
        return TCL_ERROR;
    }
    contextObj = (ItclObject*)cmdInfo.objClientData;
 
    /*
     *  Resolve the variable with respect to the most-specific
     *  class definition.
     */
    entry = Tcl_FindHashEntry(&contextObj->classDefn->resolveVars, namev[2]);
    if (!entry) {
        if (errs) {
            Tcl_AppendStringsToObj(Tcl_GetObjResult(errs),
                "can't resolve scoped variable \"", name, "\": ",
                "no such data member ", namev[2],
                (char*)NULL);
        }
        ckfree((char*)namev);
        return TCL_ERROR;
    }
 
    vlookup = (ItclVarLookup*)Tcl_GetHashValue(entry);
    *rPtr = (Tcl_Var) contextObj->data[vlookup->var.index];
 
    ckfree((char*)namev);
    return TCL_OK;
}
Browse

Tools

Subversion Repositories or1k

[/] [or1k/] [trunk/] [insight/] [itcl/] [itcl/] [generic/] [itcl_objects.c] - Blame information for rev 1773

Line No.	Rev	Author	Line
1	578	markom	`/*`
2			`* ------------------------------------------------------------------------`
3			`* PACKAGE: [incr Tcl]`
4			`* DESCRIPTION: Object-Oriented Extensions to Tcl`
5			`*`
6			`* [incr Tcl] provides object-oriented extensions to Tcl, much as`
7			`* C++ provides object-oriented extensions to C. It provides a means`
8			`* of encapsulating related procedures together with their shared data`
9			`* in a local namespace that is hidden from the outside world. It`
10			`* promotes code re-use through inheritance. More than anything else,`
11			`* it encourages better organization of Tcl applications through the`
12			`* object-oriented paradigm, leading to code that is easier to`
13			`* understand and maintain.`
14			`*`
15			`* This segment handles "objects" which are instantiated from class`
16			`* definitions. Objects contain public/protected/private data members`
17			`* from all classes in a derivation hierarchy.`
18			`*`
19			`* ========================================================================`
20			`* AUTHOR: Michael J. McLennan`
21			`* Bell Labs Innovations for Lucent Technologies`
22			`* mmclennan@lucent.com`
23			`* http://www.tcltk.com/itcl`
24			`*`
25			`* RCS: $Id: itcl_objects.c,v 1.1.1.1 2002-01-16 10:24:46 markom Exp $`
26			`* ========================================================================`
27			`* Copyright (c) 1993-1998 Lucent Technologies, Inc.`
28			`* ------------------------------------------------------------------------`
29			`* See the file "license.terms" for information on usage and redistribution`
30			`* of this file, and for a DISCLAIMER OF ALL WARRANTIES.`
31			`*/`
32			`#include "itclInt.h"`
33
34			`/*`
35			`* FORWARD DECLARATIONS`
36			`*/`
37			`static void ItclReportObjectUsage _ANSI_ARGS_((Tcl_Interp *interp,`
38			`ItclObject* obj));`
39
40			`static char* ItclTraceThisVar _ANSI_ARGS_((ClientData cdata,`