itcl_obsolete.c

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

 *    }
 *
 *  NOTE:  This command is will only be provided for a limited time,
 *         to support backward compatibility with the old-style
 *         [incr Tcl] syntax.  Users should convert their scripts
 *         to use the newer syntax (Itcl_ClassCmd()) as soon as possible.
 *
 * ------------------------------------------------------------------------
 */
static int
ItclOldClassCmd(clientData, interp, objc, objv)
    ClientData clientData;   /* info for all known objects */
    Tcl_Interp *interp;      /* current interpreter */
    int objc;                /* number of arguments */
    Tcl_Obj *CONST objv[];   /* argument objects */
{
    ItclObjectInfo* info = (ItclObjectInfo*)clientData;

    int result;
    char *className;
    Tcl_Namespace *parserNs;
    ItclClass *cdefnPtr;
    Tcl_HashEntry* entry;
    ItclMemberFunc *mfunc;
    Tcl_CallFrame frame;

    if (objc != 3) {
        Tcl_WrongNumArgs(interp, 1, objv, "name { definition }");
        return TCL_ERROR;
    }
    className = Tcl_GetStringFromObj(objv[1], (int*)NULL);

    /*
     *  Find the namespace to use as a parser for the class definition.
     *  If for some reason it is destroyed, bail out here.
     */
    parserNs = Tcl_FindNamespace(interp, "::itcl::old-parser",
        (Tcl_Namespace*)NULL, TCL_LEAVE_ERR_MSG);

    if (parserNs == NULL) {
        char msg[256];
        sprintf(msg, "\n    (while parsing class definition for \"%.100s\")",
            className);
        Tcl_AddErrorInfo(interp, msg);
        return TCL_ERROR;
    }

    /*
     *  Try to create the specified class and its namespace.
     */
    if (Itcl_CreateClass(interp, className, info, &cdefnPtr) != TCL_OK) {
        return TCL_ERROR;
    }
    cdefnPtr->flags |= ITCL_OLD_STYLE;

    /*
     *  Import the built-in commands from the itcl::old-builtin
     *  and itcl::builtin namespaces.  Do this before parsing the
     *  class definition, so methods/procs can override the built-in
     *  commands.
     */
    result = Tcl_Import(interp, cdefnPtr->namesp, "::itcl::builtin::*",
        /* allowOverwrite */ 1);

    if (result == TCL_OK) {
        result = Tcl_Import(interp, cdefnPtr->namesp, "::itcl::old-builtin::*",
            /* allowOverwrite */ 1);
    }

    if (result != TCL_OK) {
        char msg[256];
        sprintf(msg, "\n    (while installing built-in commands for class \"%.100s\")", className);
        Tcl_AddErrorInfo(interp, msg);

        Tcl_DeleteNamespace(cdefnPtr->namesp);
        return TCL_ERROR;
    }

    /*
     *  Push this class onto the class definition stack so that it
     *  becomes the current context for all commands in the parser.
     *  Activate the parser and evaluate the class definition.
     */
    Itcl_PushStack((ClientData)cdefnPtr, &info->cdefnStack);

    result = Tcl_PushCallFrame(interp, &frame, parserNs,
        /* isProcCallFrame */ 0);

    if (result == TCL_OK) {
      /* CYGNUS LOCAL - Fix for Tcl8.1 */
#if TCL_MAJOR_VERSION == 8 && TCL_MINOR_VERSION == 1
      result = Tcl_EvalObj(interp, objv[2], 0);
#else
      result = Tcl_EvalObj(interp, objv[2]);
#endif
      /* END CYGNUS LOCAL */
      Tcl_PopCallFrame(interp);
    }
    Itcl_PopStack(&info->cdefnStack);

    if (result != TCL_OK) {
        char msg[256];
        sprintf(msg, "\n    (class \"%.200s\" body line %d)",
            className, interp->errorLine);
        Tcl_AddErrorInfo(interp, msg);

        Tcl_DeleteNamespace(cdefnPtr->namesp);
        return TCL_ERROR;
    }

    /*
     *  At this point, parsing of the class definition has succeeded.
     *  Add built-in methods such as "configure" and "cget"--as long
     *  as they don't conflict with those defined in the class.
     */
    if (Itcl_InstallOldBiMethods(interp, cdefnPtr) != TCL_OK) {
        Tcl_DeleteNamespace(cdefnPtr->namesp);
        return TCL_ERROR;
    }

    /*
     *  See if this class has a "constructor", and if it does, mark
     *  it as "old-style".  This will allow the "config" argument
     *  to work.
     */
    entry = Tcl_FindHashEntry(&cdefnPtr->functions, "constructor");
    if (entry) {
        mfunc = (ItclMemberFunc*)Tcl_GetHashValue(entry);
        mfunc->member->flags |= ITCL_OLD_STYLE;
    }

    /*
     *  Build the virtual tables for this class.
     */
    Itcl_BuildVirtualTables(cdefnPtr);

    Tcl_ResetResult(interp);
    return TCL_OK;
}


/*
 * ------------------------------------------------------------------------
 *  ItclOldMethodCmd()
 *
 *  Invoked by Tcl during the parsing of a class definition whenever
 *  the "method" command is invoked to define an object method.
 *  Handles the following syntax:
 *
 *      method <name> {<arglist>} {<body>}
 *
 * ------------------------------------------------------------------------
 */
static int
ItclOldMethodCmd(clientData, interp, objc, objv)
    ClientData clientData;   /* info for all known objects */
    Tcl_Interp *interp;      /* current interpreter */
    int objc;                /* number of arguments */
    Tcl_Obj *CONST objv[];   /* argument objects */
{
    ItclObjectInfo *info = (ItclObjectInfo*)clientData;
    ItclClass *cdefn = (ItclClass*)Itcl_PeekStack(&info->cdefnStack);

    char *name, *arglist, *body;
    Tcl_HashEntry *entry;
    ItclMemberFunc *mfunc;

    if (objc != 4) {
        Tcl_WrongNumArgs(interp, 1, objv, "name args body");
        return TCL_ERROR;
    }

    name = Tcl_GetStringFromObj(objv[1], (int*)NULL);
    if (Tcl_FindHashEntry(&cdefn->functions, name)) {
        Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
            "\"", name, "\" already defined in class \"", cdefn->name, "\"",
            (char*)NULL);
        return TCL_ERROR;
    }

    arglist = Tcl_GetStringFromObj(objv[2], (int*)NULL);
    body    = Tcl_GetStringFromObj(objv[3], (int*)NULL);

    if (Itcl_CreateMethod(interp, cdefn, name, arglist, body) != TCL_OK) {
        return TCL_ERROR;
    }

    /*
     *  Find the method that was just created and mark it as an
     *  "old-style" method, so that the magic "config" argument
     *  will be allowed to work.  This is done for backward-
     *  compatibility with earlier releases.  In the latest version,
     *  use of the "config" argument is discouraged.
     */
    entry = Tcl_FindHashEntry(&cdefn->functions, name);
    if (entry) {
        mfunc = (ItclMemberFunc*)Tcl_GetHashValue(entry);
        mfunc->member->flags |= ITCL_OLD_STYLE;
    }

    return TCL_OK;
}


/*
 * ------------------------------------------------------------------------
 *  ItclOldPublicCmd()
 *
 *  Invoked by Tcl during the parsing of a class definition whenever
 *  the "public" command is invoked to define a public variable.
 *  Handles the following syntax:
 *
 *      public <varname> ?<init>? ?<config>?
 *
 * ------------------------------------------------------------------------
 */
static int
ItclOldPublicCmd(clientData, interp, objc, objv)
    ClientData clientData;   /* info for all known objects */
    Tcl_Interp *interp;      /* current interpreter */
    int objc;                /* number of arguments */
    Tcl_Obj *CONST objv[];   /* argument objects */
{
    ItclObjectInfo *info = (ItclObjectInfo*)clientData;
    ItclClass *cdefnPtr = (ItclClass*)Itcl_PeekStack(&info->cdefnStack);

    char *name, *init, *config;
    ItclVarDefn *vdefn;

    if ((objc < 2) || (objc > 4)) {
        Tcl_WrongNumArgs(interp, 1, objv, "varname ?init? ?config?");
        return TCL_ERROR;
    }

    /*
     *  Make sure that the variable name does not contain anything
     *  goofy like a "::" scope qualifier.
     */
    name = Tcl_GetStringFromObj(objv[1], (int*)NULL);
    if (strstr(name, "::")) {
        Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
            "bad variable name \"", name, "\"",
            (char*)NULL);
        return TCL_ERROR;
    }

    init   = NULL;
    config = NULL;
    if (objc >= 3) {
        init = Tcl_GetStringFromObj(objv[2], (int*)NULL);
    }
    if (objc >= 4) {
        config = Tcl_GetStringFromObj(objv[3], (int*)NULL);
    }

    if (Itcl_CreateVarDefn(interp, cdefnPtr, name, init, config,
        &vdefn) != TCL_OK) {

        return TCL_ERROR;
    }

    vdefn->member->protection = ITCL_PUBLIC;

    return TCL_OK;
}

/*
 * ------------------------------------------------------------------------
 *  ItclOldProtectedCmd()
 *
 *  Invoked by Tcl during the parsing of a class definition whenever
 *  the "protected" command is invoked to define a protected variable.
 *  Handles the following syntax:
 *
 *      protected <varname> ?<init>?
 *
 * ------------------------------------------------------------------------
 */
static int
ItclOldProtectedCmd(clientData, interp, objc, objv)
    ClientData clientData;   /* info for all known objects */
    Tcl_Interp *interp;      /* current interpreter */
    int objc;                /* number of arguments */
    Tcl_Obj *CONST objv[];   /* argument objects */
{
    ItclObjectInfo *info = (ItclObjectInfo*)clientData;
    ItclClass *cdefnPtr = (ItclClass*)Itcl_PeekStack(&info->cdefnStack);

    char *name, *init;
    ItclVarDefn *vdefn;

    if ((objc < 2) || (objc > 3)) {
        Tcl_WrongNumArgs(interp, 1, objv, "varname ?init?");
        return TCL_ERROR;
    }

    /*
     *  Make sure that the variable name does not contain anything
     *  goofy like a "::" scope qualifier.
     */
    name = Tcl_GetStringFromObj(objv[1], (int*)NULL);
    if (strstr(name, "::")) {
        Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
            "bad variable name \"", name, "\"",
            (char*)NULL);
        return TCL_ERROR;
    }

    if (objc == 3) {
        init = Tcl_GetStringFromObj(objv[2], (int*)NULL);
    } else {
        init = NULL;
    }

    if (Itcl_CreateVarDefn(interp, cdefnPtr, name, init, (char*)NULL,
        &vdefn) != TCL_OK) {

        return TCL_ERROR;
    }

    vdefn->member->protection = ITCL_PROTECTED;

    return TCL_OK;
}

/*
 * ------------------------------------------------------------------------
 *  ItclOldCommonCmd()
 *
 *  Invoked by Tcl during the parsing of a class definition whenever
 *  the "common" command is invoked to define a variable that is
 *  common to all objects in the class.  Handles the following syntax:
 *
 *      common <varname> ?<init>?
 *
 * ------------------------------------------------------------------------
 */
static int
ItclOldCommonCmd(clientData, interp, objc, objv)
    ClientData clientData;   /* info for all known objects */
    Tcl_Interp *interp;      /* current interpreter */
    int objc;                /* number of arguments */
    Tcl_Obj *CONST objv[];   /* argument objects */
{
    ItclObjectInfo *info = (ItclObjectInfo*)clientData;
    ItclClass *cdefnPtr = (ItclClass*)Itcl_PeekStack(&info->cdefnStack);

    int newEntry;
    char *name, *init;
    ItclVarDefn *vdefn;
    Tcl_HashEntry *entry;
    Namespace *nsPtr;
    Var *varPtr;

    if ((objc < 2) || (objc > 3)) {
        Tcl_WrongNumArgs(interp, 1, objv, "varname ?init?");
        return TCL_ERROR;
    }

    /*
     *  Make sure that the variable name does not contain anything
     *  goofy like a "::" scope qualifier.
     */
    name = Tcl_GetStringFromObj(objv[1], (int*)NULL);
    if (strstr(name, "::")) {
        Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
            "bad variable name \"", name, "\"",
            (char*)NULL);
        return TCL_ERROR;
    }

    if (objc == 3) {
        init = Tcl_GetStringFromObj(objv[2], (int*)NULL);
    } else {
        init = NULL;
    }

    if (Itcl_CreateVarDefn(interp, cdefnPtr, name, init, (char*)NULL,
        &vdefn) != TCL_OK) {

        return TCL_ERROR;
    }

    vdefn->member->protection = ITCL_PROTECTED;
    vdefn->member->flags |= ITCL_COMMON;

    /*
     *  Create the variable in the namespace associated with the
     *  class.  Do this the hard way, to avoid the variable resolver
     *  procedures.  These procedures won't work until we rebuild
     *  the virtual tables below.
     */