itcl_class.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.
 *
 *  These procedures handle class definitions.  Classes are composed of
 *  data members (public/protected/common) and the member functions
 *  (methods/procs) that operate on them.  Each class has its own
 *  namespace which manages the class scope.
 *
 * ========================================================================
 *  AUTHOR:  Michael J. McLennan
 *           Bell Labs Innovations for Lucent Technologies
 *           [e-mail]
 *           http://www.tcltk.com/itcl
 *
 *     RCS:  $Id: itcl_class.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"

/*
 * This structure is a subclass of Tcl_ResolvedVarInfo that contains the
 * ItclVarLookup info needed at runtime.
 */
typedef struct ItclResolvedVarInfo {
    Tcl_ResolvedVarInfo vinfo;        /* This must be the first element. */
    ItclVarLookup *vlookup;           /* Pointer to lookup info. */
} ItclResolvedVarInfo;

/*
 *  FORWARD DECLARATIONS
 */
static void ItclDestroyClass _ANSI_ARGS_((ClientData cdata));
static void ItclDestroyClassNamesp _ANSI_ARGS_((ClientData cdata));
static void ItclFreeClass _ANSI_ARGS_((char* cdata));

static Tcl_Var ItclClassRuntimeVarResolver _ANSI_ARGS_((
    Tcl_Interp *interp, Tcl_ResolvedVarInfo *vinfoPtr));


/*
 * ------------------------------------------------------------------------
 *  Itcl_CreateClass()
 *
 *  Creates a namespace and its associated class definition data.
 *  If a namespace already exists with that name, then this routine
 *  returns TCL_ERROR, along with an error message in the interp.
 *  If successful, it returns TCL_OK and a pointer to the new class
 *  definition.
 * ------------------------------------------------------------------------
 */
int
Itcl_CreateClass(interp, path, info, rPtr)
    Tcl_Interp* interp;      /* interpreter that will contain new class */
    char* path;              /* name of new class */
    ItclObjectInfo *info;    /* info for all known objects */
    ItclClass **rPtr;        /* returns: pointer to class definition */
{
    char *head, *tail;
    Tcl_DString buffer;
    Tcl_Command cmd;
    Tcl_Namespace *classNs;
    ItclClass *cdPtr;
    ItclVarDefn *vdefn;
    Tcl_HashEntry *entry;
    int newEntry;

    /*
     *  Make sure that a class with the given name does not
     *  already exist in the current namespace context.  If a
     *  namespace exists, that's okay.  It may have been created
     *  to contain stubs during a "namespace import" operation.
     *  We'll just replace the namespace data below with the
     *  proper class data.
     */
    classNs = Tcl_FindNamespace(interp, path, (Tcl_Namespace*)NULL,
        /* flags */ 0);

    if (classNs != NULL && Itcl_IsClassNamespace(classNs)) {
        Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
            "class \"", path, "\" already exists",
            (char*)NULL);
        return TCL_ERROR;
    }

    /*
     *  Make sure that a command with the given class name does not
     *  already exist in the current namespace.  This prevents the
     *  usual Tcl commands from being clobbered when a programmer
     *  makes a bogus call like "class info".
     */
    cmd = Tcl_FindCommand(interp, path, (Tcl_Namespace*)NULL,
        /* flags */ TCL_NAMESPACE_ONLY);

    if (cmd != NULL && !Itcl_IsStub(cmd)) {
        Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
            "command \"", path, "\" already exists",
            (char*)NULL);

        if (strstr(path,"::") == NULL) {
            Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
                " in namespace \"",
                Tcl_GetCurrentNamespace(interp)->fullName, "\"",
                (char*)NULL);
        }
        return TCL_ERROR;
    }

    /*
     *  Make sure that the class name does not have any goofy
     *  characters:
     *
     *    .  =>  reserved for member access like:  class.publicVar
     */
    Itcl_ParseNamespPath(path, &buffer, &head, &tail);

    if (strstr(tail,".")) {
        Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
            "bad class name \"", tail, "\"",
            (char*)NULL);
        Tcl_DStringFree(&buffer);
        return TCL_ERROR;
    }
    Tcl_DStringFree(&buffer);

    /*
     *  Allocate class definition data.
     */
    cdPtr = (ItclClass*)ckalloc(sizeof(ItclClass));
    cdPtr->name = NULL;
    cdPtr->fullname = NULL;
    cdPtr->interp = interp;
    cdPtr->info = info;  Itcl_PreserveData((ClientData)info);
    cdPtr->namesp = NULL;
    cdPtr->accessCmd = NULL;

    Tcl_InitHashTable(&cdPtr->variables, TCL_STRING_KEYS);
    Tcl_InitHashTable(&cdPtr->functions, TCL_STRING_KEYS);

    cdPtr->numInstanceVars = 0;
    Tcl_InitHashTable(&cdPtr->resolveVars, TCL_STRING_KEYS);
    Tcl_InitHashTable(&cdPtr->resolveCmds, TCL_STRING_KEYS);

    Itcl_InitList(&cdPtr->bases);
    Itcl_InitList(&cdPtr->derived);

    cdPtr->initCode = NULL;
    cdPtr->unique   = 0;
    cdPtr->flags    = 0;

    /*
     *  Initialize the heritage info--each class starts with its
     *  own class definition in the heritage.  Base classes are
     *  added to the heritage from the "inherit" statement.
     */
    Tcl_InitHashTable(&cdPtr->heritage, TCL_ONE_WORD_KEYS);
    (void) Tcl_CreateHashEntry(&cdPtr->heritage, (char*)cdPtr, &newEntry);

    /*
     *  Create a namespace to represent the class.  Add the class
     *  definition info as client data for the namespace.  If the
     *  namespace already exists, then replace any existing client
     *  data with the class data.
     */
    Itcl_PreserveData((ClientData)cdPtr);

    if (classNs == NULL) {
        classNs = Tcl_CreateNamespace(interp, path,
            (ClientData)cdPtr, ItclDestroyClassNamesp);
    }
    else {
        if (classNs->clientData && classNs->deleteProc) {
            (*classNs->deleteProc)(classNs->clientData);
        }
        classNs->clientData = (ClientData)cdPtr;
        classNs->deleteProc = ItclDestroyClassNamesp;
    }

    Itcl_EventuallyFree((ClientData)cdPtr, ItclFreeClass);

    if (classNs == NULL) {
        Itcl_ReleaseData((ClientData)cdPtr);
        return TCL_ERROR;
    }

    cdPtr->namesp = classNs;

    cdPtr->name = (char*)ckalloc((unsigned)(strlen(classNs->name)+1));
    strcpy(cdPtr->name, classNs->name);

    cdPtr->fullname = (char*)ckalloc((unsigned)(strlen(classNs->fullName)+1));
    strcpy(cdPtr->fullname, classNs->fullName);

    /*
     *  Add special name resolution procedures to the class namespace
     *  so that members are accessed according to the rules for
     *  [incr Tcl].
     */
    Tcl_SetNamespaceResolvers(classNs, Itcl_ClassCmdResolver,
        Itcl_ClassVarResolver, Itcl_ClassCompiledVarResolver);

    /*
     *  Add the built-in "this" variable to the list of data members.
     */
    (void) Itcl_CreateVarDefn(interp, cdPtr, "this",
        (char*)NULL, (char*)NULL, &vdefn);

    vdefn->member->protection = ITCL_PROTECTED;  /* always "protected" */
    vdefn->member->flags |= ITCL_THIS_VAR;       /* mark as "this" variable */

    entry = Tcl_CreateHashEntry(&cdPtr->variables, "this", &newEntry);
    Tcl_SetHashValue(entry, (ClientData)vdefn);

    /*
     *  Create a command in the current namespace to manage the class:
     *    <className>
     *    <className> <objName> ?<constructor-args>?
     */
    Itcl_PreserveData((ClientData)cdPtr);

    cdPtr->accessCmd = Tcl_CreateObjCommand(interp,
        cdPtr->fullname, Itcl_HandleClass,
        (ClientData)cdPtr, ItclDestroyClass);

    *rPtr = cdPtr;
    return TCL_OK;
}


/*
 * ------------------------------------------------------------------------
 *  Itcl_DeleteClass()
 *
 *  Deletes a class by deleting all derived classes and all objects in
 *  that class, and finally, by destroying the class namespace.  This
 *  procedure provides a friendly way of doing this.  If any errors
 *  are detected along the way, the process is aborted.
 *
 *  Returns TCL_OK if successful, or TCL_ERROR (along with an error
 *  message in the interpreter) if anything goes wrong.
 * ------------------------------------------------------------------------
 */
int
Itcl_DeleteClass(interp, cdefnPtr)
    Tcl_Interp *interp;     /* interpreter managing this class */
    ItclClass *cdefnPtr;    /* class namespace */
{
    ItclClass *cdPtr = NULL;

    Itcl_ListElem *elem;
    ItclObject *contextObj;
    Tcl_HashEntry *entry;
    Tcl_HashSearch place;
    Tcl_DString buffer;

    /*
     *  Destroy all derived classes, since these lose their meaning
     *  when the base class goes away.  If anything goes wrong,
     *  abort with an error.
     *
     *  TRICKY NOTE:  When a derived class is destroyed, it
     *    automatically deletes itself from the "derived" list.
     */
    elem = Itcl_FirstListElem(&cdefnPtr->derived);
    while (elem) {
        cdPtr = (ItclClass*)Itcl_GetListValue(elem);
        elem = Itcl_NextListElem(elem);  /* advance here--elem will go away */

        if (Itcl_DeleteClass(interp, cdPtr) != TCL_OK) {
            goto deleteClassFail;
        }
    }

    /*
     *  Scan through and find all objects that belong to this class.
     *  Note that more specialized objects have already been
     *  destroyed above, when derived classes were destroyed.
     *  Destroy objects and report any errors.
     */
    entry = Tcl_FirstHashEntry(&cdefnPtr->info->objects, &place);
    while (entry) {
        contextObj = (ItclObject*)Tcl_GetHashValue(entry);
        if (contextObj->classDefn == cdefnPtr) {
            if (Itcl_DeleteObject(interp, contextObj) != TCL_OK) {
                cdPtr = cdefnPtr;
                goto deleteClassFail;
            }
        }
        entry = Tcl_NextHashEntry(&place);
    }

    /*
     *  Destroy the namespace associated with this class.
     *
     *  TRICKY NOTE:
     *    The cleanup procedure associated with the namespace is
     *    invoked automatically.  It does all of the same things
     *    above, but it also disconnects this class from its
     *    base-class lists, and removes the class access command.
     */
    Tcl_DeleteNamespace(cdefnPtr->namesp);
    return TCL_OK;

deleteClassFail:
    Tcl_DStringInit(&buffer);
    Tcl_DStringAppend(&buffer, "\n    (while deleting class \"", -1);
    Tcl_DStringAppend(&buffer, cdPtr->namesp->fullName, -1);
    Tcl_DStringAppend(&buffer, "\")", -1);
    Tcl_AddErrorInfo(interp, Tcl_DStringValue(&buffer));
    Tcl_DStringFree(&buffer);
    return TCL_ERROR;
}


/*
 * ------------------------------------------------------------------------
 *  ItclDestroyClass()
 *
 *  Invoked whenever the access command for a class is destroyed.
 *  Destroys the namespace associated with the class, which also
 *  destroys all objects in the class and all derived classes.
 *  Disconnects this class from the "derived" class lists of its
 *  base classes, and releases any claim to the class definition
 *  data.  If this is the last use of that data, the class will
 *  completely vanish at this point.
 * ------------------------------------------------------------------------
 */
static void
ItclDestroyClass(cdata)
    ClientData cdata;  /* class definition to be destroyed */
{
    ItclClass *cdefnPtr = (ItclClass*)cdata;
    cdefnPtr->accessCmd = NULL;

    Tcl_DeleteNamespace(cdefnPtr->namesp);
    Itcl_ReleaseData((ClientData)cdefnPtr);
}


/*
 * ------------------------------------------------------------------------
 *  ItclDestroyClassNamesp()
 *
 *  Invoked whenever the namespace associated with a class is destroyed.
 *  Destroys all objects associated with this class and all derived
 *  classes.  Disconnects this class from the "derived" class lists
 *  of its base classes, and removes the class access command.  Releases
 *  any claim to the class definition data.  If this is the last use
 *  of that data, the class will completely vanish at this point.
 * ------------------------------------------------------------------------
 */
static void
ItclDestroyClassNamesp(cdata)
    ClientData cdata;  /* class definition to be destroyed */
{
    ItclClass *cdefnPtr = (ItclClass*)cdata;
    ItclObject *contextObj;
    Itcl_ListElem *elem, *belem;
    ItclClass *cdPtr, *basePtr, *derivedPtr;
    Tcl_HashEntry *entry;
    Tcl_HashSearch place;

    /*
     *  Destroy all derived classes, since these lose their meaning
     *  when the base class goes away.
     *
     *  TRICKY NOTE:  When a derived class is destroyed, it
     *    automatically deletes itself from the "derived" list.
     */
    elem = Itcl_FirstListElem(&cdefnPtr->derived);
    while (elem) {
        cdPtr = (ItclClass*)Itcl_GetListValue(elem);
        elem = Itcl_NextListElem(elem);  /* advance here--elem will go away */

        Tcl_DeleteNamespace(cdPtr->namesp);
    }

    /*
     *  Scan through and find all objects that belong to this class.
     *  Destroy them quietly by deleting their access command.
     */
    entry = Tcl_FirstHashEntry(&cdefnPtr->info->objects, &place);
    while (entry) {
        contextObj = (ItclObject*)Tcl_GetHashValue(entry);
        if (contextObj->classDefn == cdefnPtr) {
            Tcl_DeleteCommandFromToken(cdefnPtr->interp, contextObj->accessCmd);
        }
        entry = Tcl_NextHashEntry(&place);
    }

    /*
     *  Next, remove this class from the "derived" list in
     *  all base classes.
     */
    belem = Itcl_FirstListElem(&cdefnPtr->bases);
    while (belem) {
        basePtr = (ItclClass*)Itcl_GetListValue(belem);

        elem = Itcl_FirstListElem(&basePtr->derived);
        while (elem) {
            derivedPtr = (ItclClass*)Itcl_GetListValue(elem);
            if (derivedPtr == cdefnPtr) {
                Itcl_ReleaseData( Itcl_GetListValue(elem) );
                elem = Itcl_DeleteListElem(elem);
            } else {
                elem = Itcl_NextListElem(elem);
            }
        }
        belem = Itcl_NextListElem(belem);
    }

    /*
     *  Next, destroy the access command associated with the class.
     */
    if (cdefnPtr->accessCmd) {
        Command *cmdPtr = (Command*)cdefnPtr->accessCmd;

        cmdPtr->deleteProc = Itcl_ReleaseData;
        Tcl_DeleteCommandFromToken(cdefnPtr->interp, cdefnPtr->accessCmd);
    }

    /*
     *  Release the namespace's claim on the class definition.
     */
    Itcl_ReleaseData((ClientData)cdefnPtr);
}


/*
 * ------------------------------------------------------------------------
 *  ItclFreeClass()
 *