itcl_cmds.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.
 *
 *  This file defines information that tracks classes and objects
 *  at a global level for a given interpreter.
 *
 * ========================================================================
 *  AUTHOR:  Michael J. McLennan
 *           Bell Labs Innovations for Lucent Technologies
 *           [e-mail]
 *           http://www.tcltk.com/itcl
 *
 *     RCS:  $Id: itcl_cmds.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"

/*
 *  FORWARD DECLARATIONS
 */
static void ItclDelObjectInfo _ANSI_ARGS_((char* cdata));
static int Initialize _ANSI_ARGS_((Tcl_Interp *interp));
static int ItclHandleStubCmd _ANSI_ARGS_((ClientData clientData,
    Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]));
static void ItclDeleteStub _ANSI_ARGS_((ClientData cdata));

/*
 * The following string is the startup script executed in new
 * interpreters.  It locates the Tcl code in the [incr Tcl] library
 * directory and loads it in.
 */

static char initScript[] = "\n\
namespace eval ::itcl {\n\
    proc _find_init {} {\n\
        global env tcl_library\n\
        variable library\n\
        variable version\n\
        rename _find_init {}\n\
        if {[info exists library]} {\n\
            lappend dirs $library\n\
        } else {\n\
            if {[catch {uplevel #0 source -rsrc itcl}] == 0} {\n\
                return\n\
            }\n\
            set dirs {}\n\
            if {[info exists env(ITCL_LIBRARY)]} {\n\
                lappend dirs $env(ITCL_LIBRARY)\n\
            }\n\
            lappend dirs [file join [file dirname $tcl_library] itcl$version]\n\
            set bindir [file dirname [info nameofexecutable]]\n\
            lappend dirs [file join $bindir .. lib itcl$version]\n\
            lappend dirs [file join $bindir .. library]\n\
            lappend dirs [file join $bindir .. .. library]\n\
            lappend dirs [file join $bindir .. .. itcl library]\n\
            lappend dirs [file join $bindir .. .. .. itcl library]\n\
        }\n\
        foreach i $dirs {\n\
            set library $i\n\
            set itclfile [file join $i itcl.tcl]\n\
            if {![catch {uplevel #0 [list source $itclfile]} msg]} {\n\
                return\n\
            }\n\
        }\n\
        set msg \"Can't find a usable itcl.tcl in the following directories:\n\"\n\
        append msg \"    $dirs\n\"\n\
        append msg \"This probably means that Itcl/Tcl weren't installed properly.\n\"\n\
        append msg \"If you know where the Itcl library directory was installed,\n\"\n\
        append msg \"you can set the environment variable ITCL_LIBRARY to point\n\"\n\
        append msg \"to the library directory.\n\"\n\
        error $msg\n\
    }\n\
    _find_init\n\
}";

/*
 * The following script is used to initialize Itcl in a safe interpreter.
 */

static char safeInitScript[] =
"proc ::itcl::local {class name args} {\n\
    set ptr [uplevel [list $class $name] $args]\n\
    uplevel [list set itcl-local-$ptr $ptr]\n\
    set cmd [uplevel namespace which -command $ptr]\n\
    uplevel [list trace variable itcl-local-$ptr u \"::itcl::delete object $cmd; list\"]\n\
    return $ptr\n\
}";

extern ItclStubs itclStubs;


/*
 * ------------------------------------------------------------------------
 *  Initialize()
 *
 *  Invoked whenever a new interpeter is created to install the
 *  [incr Tcl] package.  Usually invoked within Tcl_AppInit() at
 *  the start of execution.
 *
 *  Creates the "::itcl" namespace and installs access commands for
 *  creating classes and querying info.
 *
 *  Returns TCL_OK on success, or TCL_ERROR (along with an error
 *  message in the interpreter) if anything goes wrong.
 * ------------------------------------------------------------------------
 */
static int
Initialize(interp)
    Tcl_Interp *interp;  /* interpreter to be updated */
{
    Tcl_CmdInfo cmdInfo;
    Tcl_Namespace *itclNs;
    ItclObjectInfo *info;

    if (Tcl_InitStubs(interp, "8.1", 0) == NULL) {
	return TCL_ERROR;
    };

    /*
     *  See if [incr Tcl] is already installed.
     */
    if (Tcl_GetCommandInfo(interp, "::itcl::class", &cmdInfo)) {
        Tcl_SetResult(interp, "already installed: [incr Tcl]", TCL_STATIC);
        return TCL_ERROR;
    }

    /*
     *  Initialize the ensemble package first, since we need this
     *  for other parts of [incr Tcl].
     */
    if (Itcl_EnsembleInit(interp) != TCL_OK) {
        return TCL_ERROR;
    }

    /*
     *  Create the top-level data structure for tracking objects.
     *  Store this as "associated data" for easy access, but link
     *  it to the itcl namespace for ownership.
     */
    info = (ItclObjectInfo*)ckalloc(sizeof(ItclObjectInfo));
    info->interp = interp;
    Tcl_InitHashTable(&info->objects, TCL_ONE_WORD_KEYS);
    Itcl_InitStack(&info->transparentFrames);
    Tcl_InitHashTable(&info->contextFrames, TCL_ONE_WORD_KEYS);
    info->protection = ITCL_DEFAULT_PROTECT;
    Itcl_InitStack(&info->cdefnStack);

    Tcl_SetAssocData(interp, ITCL_INTERP_DATA,
        (Tcl_InterpDeleteProc*)NULL, (ClientData)info);

    /*
     *  Install commands into the "::itcl" namespace.
     */
    Tcl_CreateObjCommand(interp, "::itcl::class", Itcl_ClassCmd,
        (ClientData)info, Itcl_ReleaseData);
    Itcl_PreserveData((ClientData)info);

    Tcl_CreateObjCommand(interp, "::itcl::body", Itcl_BodyCmd,
        (ClientData)NULL, (Tcl_CmdDeleteProc*)NULL);

    Tcl_CreateObjCommand(interp, "::itcl::configbody", Itcl_ConfigBodyCmd,
        (ClientData)NULL, (Tcl_CmdDeleteProc*)NULL);

    Itcl_EventuallyFree((ClientData)info, ItclDelObjectInfo);

    /*
     *  Create the "itcl::find" command for high-level queries.
     */
    if (Itcl_CreateEnsemble(interp, "::itcl::find") != TCL_OK) {
        return TCL_ERROR;
    }
    if (Itcl_AddEnsemblePart(interp, "::itcl::find",
            "classes", "?pattern?",
            Itcl_FindClassesCmd,
            (ClientData)info, Itcl_ReleaseData) != TCL_OK) {
        return TCL_ERROR;
    }
    Itcl_PreserveData((ClientData)info);

    if (Itcl_AddEnsemblePart(interp, "::itcl::find",
            "objects", "?-class className? ?-isa className? ?pattern?",
            Itcl_FindObjectsCmd,
            (ClientData)info, Itcl_ReleaseData) != TCL_OK) {
        return TCL_ERROR;
    }
    Itcl_PreserveData((ClientData)info);


    /*
     *  Create the "itcl::delete" command to delete objects
     *  and classes.
     */
    if (Itcl_CreateEnsemble(interp, "::itcl::delete") != TCL_OK) {
        return TCL_ERROR;
    }
    if (Itcl_AddEnsemblePart(interp, "::itcl::delete",
            "class", "name ?name...?",
            Itcl_DelClassCmd,
            (ClientData)info, Itcl_ReleaseData) != TCL_OK) {
        return TCL_ERROR;
    }
    Itcl_PreserveData((ClientData)info);

    if (Itcl_AddEnsemblePart(interp, "::itcl::delete",
            "object", "name ?name...?",
            Itcl_DelObjectCmd,
            (ClientData)info, Itcl_ReleaseData) != TCL_OK) {
        return TCL_ERROR;
    }
    Itcl_PreserveData((ClientData)info);

    /*
     *  Add "code" and "scope" commands for handling scoped values.
     */
    Tcl_CreateObjCommand(interp, "::itcl::code", Itcl_CodeCmd,
        (ClientData)NULL, (Tcl_CmdDeleteProc*)NULL);

    Tcl_CreateObjCommand(interp, "::itcl::scope", Itcl_ScopeCmd,
        (ClientData)NULL, (Tcl_CmdDeleteProc*)NULL);

    /*
     *  Add commands for handling import stubs at the Tcl level.
     */
    if (Itcl_CreateEnsemble(interp, "::itcl::import::stub") != TCL_OK) {
        return TCL_ERROR;
    }
    if (Itcl_AddEnsemblePart(interp, "::itcl::import::stub",
            "create", "name", Itcl_StubCreateCmd,
            (ClientData)NULL, (Tcl_CmdDeleteProc*)NULL) != TCL_OK) {
        return TCL_ERROR;
    }
    if (Itcl_AddEnsemblePart(interp, "::itcl::import::stub",
            "exists", "name", Itcl_StubExistsCmd,
            (ClientData)NULL, (Tcl_CmdDeleteProc*)NULL) != TCL_OK) {
        return TCL_ERROR;
    }

    /*
     *  Install a variable resolution procedure to handle scoped
     *  values everywhere within the interpreter.
     */
    Tcl_AddInterpResolvers(interp, "itcl", (Tcl_ResolveCmdProc*)NULL,
        Itcl_ScopedVarResolver, (Tcl_ResolveCompiledVarProc*)NULL);

    /*
     *  Install the "itcl::parser" namespace used to parse the
     *  class definitions.
     */
    if (Itcl_ParseInit(interp, info) != TCL_OK) {
        return TCL_ERROR;
    }

    /*
     *  Create "itcl::builtin" namespace for commands that
     *  are automatically built into class definitions.
     */
    if (Itcl_BiInit(interp) != TCL_OK) {
        return TCL_ERROR;
    }

    /*
     *  Install stuff needed for backward compatibility with previous
     *  version of [incr Tcl].
     */
    if (Itcl_OldInit(interp, info) != TCL_OK) {
        return TCL_ERROR;
    }

    /*
     *  Export all commands in the "itcl" namespace so that they
     *  can be imported with something like "namespace import itcl::*"
     */
    itclNs = Tcl_FindNamespace(interp, "::itcl", (Tcl_Namespace*)NULL,
        TCL_LEAVE_ERR_MSG);

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

    /*
     *  Set up the variables containing version info.
     */

    Tcl_SetVar(interp, "::itcl::patchLevel", ITCL_PATCH_LEVEL,
        TCL_NAMESPACE_ONLY);

    Tcl_SetVar(interp, "::itcl::version", ITCL_VERSION,
        TCL_NAMESPACE_ONLY);

    /*
     *  Package is now loaded.
     */
    if (Tcl_PkgProvideEx(interp, "Itcl", ITCL_VERSION,
            (ClientData) &itclStubs) != TCL_OK) {
	return TCL_ERROR;
    }
    return TCL_OK;
}


/*
 * ------------------------------------------------------------------------
 *  Itcl_Init()
 *
 *  Invoked whenever a new INTERPRETER is created to install the
 *  [incr Tcl] package.  Usually invoked within Tcl_AppInit() at
 *  the start of execution.
 *
 *  Creates the "::itcl" namespace and installs access commands for
 *  creating classes and querying info.
 *
 *  Returns TCL_OK on success, or TCL_ERROR (along with an error
 *  message in the interpreter) if anything goes wrong.
 * ------------------------------------------------------------------------
 */
int
Itcl_Init(interp)
    Tcl_Interp *interp;  /* interpreter to be updated */
{
    if (Initialize(interp) != TCL_OK) {
	return TCL_ERROR;
    }
    return Tcl_Eval(interp, initScript);
}


/*
 * ------------------------------------------------------------------------
 *  Itcl_SafeInit()
 *
 *  Invoked whenever a new SAFE INTERPRETER is created to install
 *  the [incr Tcl] package.
 *
 *  Creates the "::itcl" namespace and installs access commands for
 *  creating classes and querying info.
 *
 *  Returns TCL_OK on success, or TCL_ERROR (along with an error
 *  message in the interpreter) if anything goes wrong.
 * ------------------------------------------------------------------------
 */
int
Itcl_SafeInit(interp)