itcl_bicmds.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 built-in class methods, including the
 *  "isa" method (to query hierarchy info) and the "info" method
 *  (to query class/object data).
 *
 * ========================================================================
 *  AUTHOR:  Michael J. McLennan
 *           Bell Labs Innovations for Lucent Technologies
 *           [e-mail]
 *           http://www.tcltk.com/itcl
 *
 *     RCS:  $Id: itcl_bicmds.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"

/*
 *  Standard list of built-in methods for all objects.
 */
typedef struct BiMethod {
    char* name;              /* method name */
    char* usage;             /* string describing usage */
    char* registration;      /* registration name for C proc */
    Tcl_ObjCmdProc *proc;    /* implementation C proc */
} BiMethod;

static BiMethod BiMethodList[] = {
    { "cget",      "-option",
                   "@itcl-builtin-cget",  Itcl_BiCgetCmd },
    { "configure", "?-option? ?value -option value...?",
                   "@itcl-builtin-configure",  Itcl_BiConfigureCmd },
    { "isa",       "className",
                   "@itcl-builtin-isa",  Itcl_BiIsaCmd },
};
static int BiMethodListLen = sizeof(BiMethodList)/sizeof(BiMethod);


/*
 *  FORWARD DECLARATIONS
 */
static Tcl_Obj* ItclReportPublicOpt _ANSI_ARGS_((Tcl_Interp *interp,
    ItclVarDefn *vdefn, ItclObject *contextObj));


/*
 * ------------------------------------------------------------------------
 *  Itcl_BiInit()
 *
 *  Creates a namespace full of built-in methods/procs for [incr Tcl]
 *  classes.  This includes things like the "isa" method and "info"
 *  for querying class info.  Usually invoked by Itcl_Init() when
 *  [incr Tcl] is first installed into an interpreter.
 *
 *  Returns TCL_OK/TCL_ERROR to indicate success/failure.
 * ------------------------------------------------------------------------
 */
int
Itcl_BiInit(interp)
    Tcl_Interp *interp;      /* current interpreter */
{
    int i;
    Tcl_Namespace *itclBiNs;

    /*
     *  Declare all of the built-in methods as C procedures.
     */
    for (i=0; i < BiMethodListLen; i++) {
        if (Itcl_RegisterObjC(interp,
                BiMethodList[i].registration+1, BiMethodList[i].proc,
                (ClientData)NULL, (Tcl_CmdDeleteProc*)NULL) != TCL_OK) {

            return TCL_ERROR;
        }
    }

    /*
     *  Create the "::itcl::builtin" namespace for built-in class
     *  commands.  These commands are imported into each class
     *  just before the class definition is parsed.
     */
    Tcl_CreateObjCommand(interp, "::itcl::builtin::chain", Itcl_BiChainCmd,
        (ClientData)NULL, (Tcl_CmdDeleteProc*)NULL);

    if (Itcl_CreateEnsemble(interp, "::itcl::builtin::info") != TCL_OK) {
        return TCL_ERROR;
    }

    if (Itcl_AddEnsemblePart(interp, "::itcl::builtin::info",
            "class", "",
            Itcl_BiInfoClassCmd, (ClientData)NULL, (Tcl_CmdDeleteProc*)NULL)
            != TCL_OK ||
        Itcl_AddEnsemblePart(interp, "::itcl::builtin::info",
            "inherit", "",
            Itcl_BiInfoInheritCmd, (ClientData)NULL, (Tcl_CmdDeleteProc*)NULL)
            != TCL_OK ||
        Itcl_AddEnsemblePart(interp, "::itcl::builtin::info",
            "heritage", "",
            Itcl_BiInfoHeritageCmd, (ClientData)NULL, (Tcl_CmdDeleteProc*)NULL)
            != TCL_OK ||
        Itcl_AddEnsemblePart(interp, "::itcl::builtin::info",
            "function", "?name? ?-protection? ?-type? ?-name? ?-args? ?-body?",
            Itcl_BiInfoFunctionCmd, (ClientData)NULL, (Tcl_CmdDeleteProc*)NULL)
            != TCL_OK ||
        Itcl_AddEnsemblePart(interp, "::itcl::builtin::info",
            "variable", "?name? ?-protection? ?-type? ?-name? ?-init? ?-value? ?-config?",
            Itcl_BiInfoVariableCmd, (ClientData)NULL, (Tcl_CmdDeleteProc*)NULL)
            != TCL_OK ||
        Itcl_AddEnsemblePart(interp, "::itcl::builtin::info",
            "args", "procname",
            Itcl_BiInfoArgsCmd, (ClientData)NULL, (Tcl_CmdDeleteProc*)NULL)
            != TCL_OK ||
        Itcl_AddEnsemblePart(interp, "::itcl::builtin::info",
            "body", "procname",
            Itcl_BiInfoBodyCmd, (ClientData)NULL, (Tcl_CmdDeleteProc*)NULL)
            != TCL_OK
    ) {
        return TCL_ERROR;
    }

    /*
     *  Add an error handler to support all of the usual inquiries
     *  for the "info" command in the global namespace.
     */
    if (Itcl_AddEnsemblePart(interp, "::itcl::builtin::info",
            "@error", "",
            Itcl_DefaultInfoCmd, (ClientData)NULL, (Tcl_CmdDeleteProc*)NULL)
            != TCL_OK
    ) {
        return TCL_ERROR;
    }

    /*
     *  Export all commands in the built-in namespace so we can
     *  import them later on.
     */
    itclBiNs = Tcl_FindNamespace(interp, "::itcl::builtin",
        (Tcl_Namespace*)NULL, TCL_LEAVE_ERR_MSG);

    if (!itclBiNs ||
        Tcl_Export(interp, itclBiNs, "*", /* resetListFirst */ 1) != TCL_OK) {
        return TCL_ERROR;
    }

    return TCL_OK;
}


/*
 * ------------------------------------------------------------------------
 *  Itcl_InstallBiMethods()
 *
 *  Invoked when a class is first created, just after the class
 *  definition has been parsed, to add definitions for built-in
 *  methods to the class.  If a method already exists in the class
 *  with the same name as the built-in, then the built-in is skipped.
 *  Otherwise, a method definition for the built-in method is added.
 *
 *  Returns TCL_OK if successful, or TCL_ERROR (along with an error
 *  message in the interpreter) if anything goes wrong.
 * ------------------------------------------------------------------------
 */
int
Itcl_InstallBiMethods(interp, cdefn)
    Tcl_Interp *interp;      /* current interpreter */
    ItclClass *cdefn;        /* class definition to be updated */
{
    int result = TCL_OK;
    Tcl_HashEntry *entry = NULL;

    int i;
    ItclHierIter hier;
    ItclClass *cdPtr;

    /*
     *  Scan through all of the built-in methods and see if
     *  that method already exists in the class.  If not, add
     *  it in.
     *
     *  TRICKY NOTE:  The virtual tables haven't been built yet,
     *    so look for existing methods the hard way--by scanning
     *    through all classes.
     */
    for (i=0; i < BiMethodListLen; i++) {
        Itcl_InitHierIter(&hier, cdefn);
        cdPtr = Itcl_AdvanceHierIter(&hier);
        while (cdPtr) {
            entry = Tcl_FindHashEntry(&cdPtr->functions, BiMethodList[i].name);
            if (entry) {
                break;
            }
            cdPtr = Itcl_AdvanceHierIter(&hier);
        }
        Itcl_DeleteHierIter(&hier);

        if (!entry) {
            result = Itcl_CreateMethod(interp, cdefn, BiMethodList[i].name,
                BiMethodList[i].usage, BiMethodList[i].registration);

            if (result != TCL_OK) {
                break;
            }
        }
    }
    return result;
}


/*
 * ------------------------------------------------------------------------
 *  Itcl_BiIsaCmd()
 *
 *  Invoked whenever the user issues the "isa" method for an object.
 *  Handles the following syntax:
 *
 *    <objName> isa <className>
 *
 *  Checks to see if the object has the given <className> anywhere
 *  in its heritage.  Returns 1 if so, and 0 otherwise.
 * ------------------------------------------------------------------------
 */
/* ARGSUSED */
int
Itcl_BiIsaCmd(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 *contextClass, *cdefn;
    ItclObject *contextObj;
    char *token;

    /*
     *  Make sure that this command is being invoked in the proper
     *  context.
     */
    if (Itcl_GetContext(interp, &contextClass, &contextObj) != TCL_OK) {
        return TCL_ERROR;
    }

    if (!contextObj) {
        Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
            "improper usage: should be \"object isa className\"",
            (char*)NULL);
        return TCL_ERROR;
    }
    if (objc != 2) {
        token = Tcl_GetStringFromObj(objv[0], (int*)NULL);
        Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
            "wrong # args: should be \"object ", token, " className\"",
            (char*)NULL);
        return TCL_ERROR;
    }

    /*
     *  Look for the requested class.  If it is not found, then
     *  try to autoload it.  If it absolutely cannot be found,
     *  signal an error.
     */
    token = Tcl_GetStringFromObj(objv[1], (int*)NULL);
    cdefn = Itcl_FindClass(interp, token, /* autoload */ 1);
    if (cdefn == NULL) {
        return TCL_ERROR;
    }

    if (Itcl_ObjectIsa(contextObj, cdefn)) {
        Tcl_SetIntObj(Tcl_GetObjResult(interp), 1);
    } else {
        Tcl_SetIntObj(Tcl_GetObjResult(interp), 0);
    }
    return TCL_OK;
}


/*
 * ------------------------------------------------------------------------
 *  Itcl_BiConfigureCmd()
 *
 *  Invoked whenever the user issues the "configure" method for an object.
 *  Handles the following syntax:
 *
 *    <objName> configure ?-<option>? ?<value> -<option> <value>...?
 *
 *  Allows access to public variables as if they were configuration
 *  options.  With no arguments, this command returns the current
 *  list of public variable options.  If -<option> is specified,
 *  this returns the information for just one option:
 *
 *    -<optionName> <initVal> <currentVal>
 *
 *  Otherwise, the list of arguments is parsed, and values are
 *  assigned to the various public variable options.  When each
 *  option changes, a big of "config" code associated with the option
 *  is executed, to bring the object up to date.
 * ------------------------------------------------------------------------
 */
/* ARGSUSED */
int
Itcl_BiConfigureCmd(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 *contextClass;
    ItclObject *contextObj;

    int i, result;
    char *token, *lastval;
    ItclClass *cdPtr;
    Tcl_HashSearch place;
    Tcl_HashEntry *entry;
    ItclVarDefn *vdefn;
    ItclVarLookup *vlookup;
    ItclMember *member;
    ItclMemberCode *mcode;
    ItclHierIter hier;
    Tcl_Obj *resultPtr, *objPtr;
    Tcl_DString buffer;
    ItclContext context;
    Tcl_CallFrame *oldFramePtr, *uplevelFramePtr;

    /*
     *  Make sure that this command is being invoked in the proper
     *  context.
     */
    if (Itcl_GetContext(interp, &contextClass, &contextObj) != TCL_OK) {
        return TCL_ERROR;
    }

    if (!contextObj) {
        Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
            "improper usage: should be ",
            "\"object configure ?-option? ?value -option value...?\"",
            (char*)NULL);
        return TCL_ERROR;
    }

    /*
     *  BE CAREFUL:  work in the virtual scope!
     */
    contextClass = contextObj->classDefn;

    /*
     *  HANDLE:  configure
     */
    if (objc == 1) {
        resultPtr = Tcl_NewListObj(0, (Tcl_Obj**)NULL);

        Itcl_InitHierIter(&hier, contextClass);
        while ((cdPtr=Itcl_AdvanceHierIter(&hier)) != NULL) {
            entry = Tcl_FirstHashEntry(&cdPtr->variables, &place);
            while (entry) {
                vdefn = (ItclVarDefn*)Tcl_GetHashValue(entry);
                if (vdefn->member->protection == ITCL_PUBLIC) {
                    objPtr = ItclReportPublicOpt(interp, vdefn, contextObj);

                    Tcl_ListObjAppendElement((Tcl_Interp*)NULL, resultPtr,
                        objPtr);
                }
                entry = Tcl_NextHashEntry(&place);
            }
        }
        Itcl_DeleteHierIter(&hier);

        Tcl_SetObjResult(interp, resultPtr);
        return TCL_OK;
    }

    /*
     *  HANDLE:  configure -option
     */
    else if (objc == 2) {
        token = Tcl_GetStringFromObj(objv[1], (int*)NULL);
        if (*token != '-') {
            Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
                "improper usage: should be ",
                "\"object configure ?-option? ?value -option value...?\"",
                (char*)NULL);
            return TCL_ERROR;
        }

        vlookup = NULL;
        entry = Tcl_FindHashEntry(&contextClass->resolveVars, token+1);
        if (entry) {
            vlookup = (ItclVarLookup*)Tcl_GetHashValue(entry);

            if (vlookup->vdefn->member->protection != ITCL_PUBLIC) {
                vlookup = NULL;
            }
        }

        if (!vlookup) {
            Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
                "unknown option \"", token, "\"",
                (char*)NULL);
            return TCL_ERROR;
        }

        resultPtr = ItclReportPublicOpt(interp, vlookup->vdefn, contextObj);
        Tcl_SetObjResult(interp, resultPtr);
        return TCL_OK;
    }

    /*
     *  HANDLE:  configure -option value -option value...
     *
     *  Be careful to work in the virtual scope.  If this "configure"