itcl_class.c

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

 *  Frees all memory associated with a class definition.  This is
 *  usually invoked automatically by Itcl_ReleaseData(), when class
 *  data is no longer being used.
 * ------------------------------------------------------------------------
 */
static void
ItclFreeClass(cdata)
    char *cdata;  /* class definition to be destroyed */
{
    ItclClass *cdefnPtr = (ItclClass*)cdata;

    int newEntry;
    Itcl_ListElem *elem;
    Tcl_HashSearch place;
    Tcl_HashEntry *entry, *hPtr;
    ItclVarDefn *vdefn;
    ItclVarLookup *vlookup;
    Var *varPtr;
    Tcl_HashTable varTable;

    /*
     *  Tear down the list of derived classes.  This list should
     *  really be empty if everything is working properly, but
     *  release it here just in case.
     */
    elem = Itcl_FirstListElem(&cdefnPtr->derived);
    while (elem) {
        Itcl_ReleaseData( Itcl_GetListValue(elem) );
        elem = Itcl_NextListElem(elem);
    }
    Itcl_DeleteList(&cdefnPtr->derived);

    /*
     *  Tear down the variable resolution table.  Some records
     *  appear multiple times in the table (for x, foo::x, etc.)
     *  so each one has a reference count.
     */
    Tcl_InitHashTable(&varTable, TCL_STRING_KEYS);

    entry = Tcl_FirstHashEntry(&cdefnPtr->resolveVars, &place);
    while (entry) {
        vlookup = (ItclVarLookup*)Tcl_GetHashValue(entry);
        if (--vlookup->usage == 0) {
            /*
             *  If this is a common variable owned by this class,
             *  then release the class's hold on it.  If it's no
             *  longer being used, move it into a variable table
             *  for destruction.
             */
            if ( (vlookup->vdefn->member->flags & ITCL_COMMON) != 0 &&
                 vlookup->vdefn->member->classDefn == cdefnPtr ) {
                varPtr = (Var*)vlookup->var.common;
                if (--varPtr->refCount == 0) {
                    hPtr = Tcl_CreateHashEntry(&varTable,
                        vlookup->vdefn->member->fullname, &newEntry);
                    Tcl_SetHashValue(hPtr, (ClientData) varPtr);
                }
            }
            ckfree((char*)vlookup);
        }
        entry = Tcl_NextHashEntry(&place);
    }

    TclDeleteVars((Interp*)cdefnPtr->interp, &varTable);
    Tcl_DeleteHashTable(&cdefnPtr->resolveVars);

    /*
     *  Tear down the virtual method table...
     */
    Tcl_DeleteHashTable(&cdefnPtr->resolveCmds);

    /*
     *  Delete all variable definitions.
     */
    entry = Tcl_FirstHashEntry(&cdefnPtr->variables, &place);
    while (entry) {
        vdefn = (ItclVarDefn*)Tcl_GetHashValue(entry);
        Itcl_DeleteVarDefn(vdefn);
        entry = Tcl_NextHashEntry(&place);
    }
    Tcl_DeleteHashTable(&cdefnPtr->variables);

    /*
     *  Delete all function definitions.
     */
    entry = Tcl_FirstHashEntry(&cdefnPtr->functions, &place);
    while (entry) {
        Itcl_ReleaseData( Tcl_GetHashValue(entry) );
        entry = Tcl_NextHashEntry(&place);
    }
    Tcl_DeleteHashTable(&cdefnPtr->functions);

    /*
     *  Release the claim on all base classes.
     */
    elem = Itcl_FirstListElem(&cdefnPtr->bases);
    while (elem) {
        Itcl_ReleaseData( Itcl_GetListValue(elem) );
        elem = Itcl_NextListElem(elem);
    }
    Itcl_DeleteList(&cdefnPtr->bases);
    Tcl_DeleteHashTable(&cdefnPtr->heritage);

    /*
     *  Free up the object initialization code.
     */
    if (cdefnPtr->initCode) {
        Tcl_DecrRefCount(cdefnPtr->initCode);
    }

    Itcl_ReleaseData((ClientData)cdefnPtr->info);

    ckfree(cdefnPtr->name);
    ckfree(cdefnPtr->fullname);

    ckfree((char*)cdefnPtr);
}


/*
 * ------------------------------------------------------------------------
 *  Itcl_IsClassNamespace()
 *
 *  Checks to see whether or not the given namespace represents an
 *  [incr Tcl] class.  Returns non-zero if so, and zero otherwise.
 * ------------------------------------------------------------------------
 */
int
Itcl_IsClassNamespace(namesp)
    Tcl_Namespace *namesp;  /* namespace being tested */
{
    Namespace *nsPtr = (Namespace*)namesp;

    if (nsPtr != NULL) {
        return (nsPtr->deleteProc == ItclDestroyClassNamesp);
    }
    return 0;
}


/*
 * ------------------------------------------------------------------------
 *  Itcl_IsClass()
 *
 *  Checks the given Tcl command to see if it represents an itcl class.
 *  Returns non-zero if the command is associated with a class.
 * ------------------------------------------------------------------------
 */
int
Itcl_IsClass(cmd)
    Tcl_Command cmd;         /* command being tested */
{
    Command *cmdPtr = (Command*)cmd;

    if (cmdPtr->deleteProc == ItclDestroyClass) {
        return 1;
    }

    /*
     *  This may be an imported command.  Try to get the real
     *  command and see if it represents a class.
     */
    cmdPtr = (Command*)TclGetOriginalCommand(cmd);
    if (cmdPtr && cmdPtr->deleteProc == ItclDestroyClass) {
        return 1;
    }
    return 0;
}


/*
 * ------------------------------------------------------------------------
 *  Itcl_FindClass()
 *
 *  Searches for the specified class in the active namespace.  If the
 *  class is found, this procedure returns a pointer to the class
 *  definition.  Otherwise, if the autoload flag is non-zero, an
 *  attempt will be made to autoload the class definition.  If it
 *  still can't be found, this procedure returns NULL, along with an
 *  error message in the interpreter.
 * ------------------------------------------------------------------------
 */
ItclClass*
Itcl_FindClass(interp, path, autoload)
    Tcl_Interp* interp;      /* interpreter containing class */
    char* path;              /* path name for class */
{
    Tcl_Namespace* classNs;

    /*
     *  Search for a namespace with the specified name, and if
     *  one is found, see if it is a class namespace.
     */
    classNs = Itcl_FindClassNamespace(interp, path);

    if (classNs && Itcl_IsClassNamespace(classNs)) {
        return (ItclClass*)classNs->clientData;
    }

    /*
     *  If the autoload flag is set, try to autoload the class
     *  definition.
     */
    if (autoload) {
        if (Tcl_VarEval(interp, "::auto_load ", path, (char*)NULL) != TCL_OK) {
            char msg[256];
            sprintf(msg, "\n    (while attempting to autoload class \"%.200s\")", path);
            Tcl_AddErrorInfo(interp, msg);
            return NULL;
        }
        Tcl_ResetResult(interp);

        classNs = Itcl_FindClassNamespace(interp, path);
        if (classNs && Itcl_IsClassNamespace(classNs)) {
            return (ItclClass*)classNs->clientData;
        }
    }

    Tcl_AppendResult(interp, "class \"", path, "\" not found in context \"",
        Tcl_GetCurrentNamespace(interp)->fullName, "\"",
        (char*)NULL);

    return NULL;
}

/*
 * ------------------------------------------------------------------------
 *  Itcl_FindClassNamespace()
 *
 *  Searches for the specified class namespace.  The normal Tcl procedure
 *  Tcl_FindNamespace also searches for namespaces, but only in the
 *  current namespace context.  This makes it hard to find one class
 *  from within another.  For example, suppose. you have two namespaces
 *  Foo and Bar.  If you're in the context of Foo and you look for
 *  Bar, you won't find it with Tcl_FindNamespace.  This behavior is
 *  okay for namespaces, but wrong for classes.
 *
 *  This procedure search for a class namespace.  If the name is
 *  absolute (i.e., starts with "::"), then that one name is checked,
 *  and the class is either found or not.  But if the name is relative,
 *  it is sought in the current namespace context and in the global
 *  context, just like the normal command lookup.
 *
 *  This procedure returns a pointer to the desired namespace, or
 *  NULL if the namespace was not found.
 * ------------------------------------------------------------------------
 */
Tcl_Namespace*
Itcl_FindClassNamespace(interp, path)
    Tcl_Interp* interp;        /* interpreter containing class */
    char* path;                /* path name for class */
{
    Tcl_Namespace* contextNs = Tcl_GetCurrentNamespace(interp);
    Tcl_Namespace* classNs;
    Tcl_DString buffer;

    /*
     *  Look up the namespace.  If the name is not absolute, then
     *  see if it's the current namespace, and try the global
     *  namespace as well.
     */
    classNs = Tcl_FindNamespace(interp, path, (Tcl_Namespace*)NULL,
        /* flags */ 0);

    if ( !classNs && contextNs->parentPtr != NULL &&
         (*path != ':' || *(path+1) != ':') ) {

        if (strcmp(contextNs->name, path) == 0) {
            classNs = contextNs;
        }
        else {
            Tcl_DStringInit(&buffer);
            Tcl_DStringAppend(&buffer, "::", -1);
            Tcl_DStringAppend(&buffer, path, -1);

            classNs = Tcl_FindNamespace(interp, Tcl_DStringValue(&buffer),
                (Tcl_Namespace*)NULL, /* flags */ 0);

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


/*
 * ------------------------------------------------------------------------
 *  Itcl_HandleClass()
 *
 *  Invoked by Tcl whenever the user issues the command associated with
 *  a class name.  Handles the following syntax:
 *
 *    <className>
 *    <className> <objName> ?<args>...?
 *
 *  Without any arguments, the command does nothing.  In the olden days,
 *  this allowed the class name to be invoked by itself to prompt the
 *  autoloader to load the class definition.  Today, this behavior is
 *  retained for backward compatibility with old releases.
 *
 *  If arguments are specified, then this procedure creates a new
 *  object named <objName> in the appropriate class.  Note that if
 *  <objName> contains "#auto", that part is automatically replaced
 *  by a unique string built from the class name.
 * ------------------------------------------------------------------------
 */
int
Itcl_HandleClass(clientData, interp, objc, objv)
    ClientData clientData;   /* class definition */
    Tcl_Interp *interp;      /* current interpreter */
    int objc;                /* number of arguments */
    Tcl_Obj *CONST objv[];   /* argument objects */
{
    ItclClass *cdefnPtr = (ItclClass*)clientData;
    int result = TCL_OK;

    char unique[256];    /* buffer used for unique part of object names */
    Tcl_DString buffer;  /* buffer used to build object names */
    char *token, *objName, tmp, *start, *pos, *match;

    ItclObject *newObj;
    Tcl_CallFrame frame;

    /*
     *  If the command is invoked without an object name, then do nothing.
     *  This used to support autoloading--that the class name could be
     *  invoked as a command by itself, prompting the autoloader to
     *  load the class definition.  We retain the behavior here for
     *  backward-compatibility with earlier releases.
     */
    if (objc == 1) {
        return TCL_OK;
    }

    /*
     *  If the object name is "::", and if this is an old-style class
     *  definition, then treat the remaining arguments as a command
     *  in the class namespace.  This used to be the way of invoking
     *  a class proc, but the new syntax is "class::proc" (without
     *  spaces).
     */
    token = Tcl_GetStringFromObj(objv[1], (int*)NULL);
    if ((*token == ':') && (strcmp(token,"::") == 0) && (objc > 2)) {
        if ((cdefnPtr->flags & ITCL_OLD_STYLE) != 0) {

            result = Tcl_PushCallFrame(interp, &frame,
                 cdefnPtr->namesp, /* isProcCallFrame */ 0);

            if (result != TCL_OK) {
                return result;
            }
            result = Itcl_EvalArgs(interp, objc-2, objv+2);

            Tcl_PopCallFrame(interp);
            return result;
        }

        /*
         *  If this is not an old-style class, then return an error
         *  describing the syntax change.
         */
        Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
            "syntax \"class :: proc\" is an anachronism\n",
            "[incr Tcl] no longer supports this syntax.\n",
            "Instead, remove the spaces from your procedure invocations:\n",
            "  ",
            Tcl_GetStringFromObj(objv[0], (int*)NULL), "::",
            Tcl_GetStringFromObj(objv[2], (int*)NULL), " ?args?",
            (char*)NULL);
        return TCL_ERROR;
    }

    /*
     *  Otherwise, we have a proper object name.  Create a new instance
     *  with that name.  If the name contains "#auto", replace this with
     *  a uniquely generated string based on the class name.
     */
    Tcl_DStringInit(&buffer);
    objName = NULL;

    match = "#auto";
    start = token;
    for (pos=start; *pos != '\0'; pos++) {
        if (*pos == *match) {
            if (*(++match) == '\0') {
                tmp = *start;
                *start = '\0';  /* null-terminate first part */

                /*
                 *  Substitute a unique part in for "#auto", and keep
                 *  incrementing a counter until a valid name is found.
                 */
                do {
                    sprintf(unique,"%.200s%d", cdefnPtr->name,
                        cdefnPtr->unique++);
                    unique[0] = tolower(unique[0]);

                    Tcl_DStringTrunc(&buffer, 0);
                    Tcl_DStringAppend(&buffer, token, -1);
                    Tcl_DStringAppend(&buffer, unique, -1);
                    Tcl_DStringAppend(&buffer, start+5, -1);

                    objName = Tcl_DStringValue(&buffer);
                    if (Itcl_FindObject(interp, objName, &newObj) != TCL_OK) {
                        break;  /* if an error is found, bail out! */
                    }
                } while (newObj != NULL);

                *start = tmp;       /* undo null-termination */
                objName = Tcl_DStringValue(&buffer);
                break;              /* object name is ready to go! */
            }
        }
        else {
            match = "#auto";
            pos = start++;
        }
    }

    /*
     *  If "#auto" was not found, then just use object name as-is.
     */
    if (objName == NULL) {
        objName = token;
    }

    /*
     *  Try to create a new object.  If successful, return the
     *  object name as the result of this command.
     */
    result = Itcl_CreateObject(interp, objName, cdefnPtr,
        objc-2, objv+2, &newObj);

    if (result == TCL_OK) {
        Tcl_SetResult(interp, objName, TCL_VOLATILE);
    }

    Tcl_DStringFree(&buffer);
    return result;
}


/*
 * ------------------------------------------------------------------------
 *  Itcl_ClassCmdResolver()
 *