itcl_ensemble.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 part handles ensembles, which support compound commands in Tcl.
 *  The usual "info" command is an ensemble with parts like "info body"
 *  and "info globals".  Extension developers can extend commands like
 *  "info" by adding their own parts to the ensemble.
 *
 * ========================================================================
 *  AUTHOR:  Michael J. McLennan
 *           Bell Labs Innovations for Lucent Technologies
 *           [e-mail]
 *           http://www.tcltk.com/itcl
 *
 *     RCS:  $Id: itcl_ensemble.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"

/*
 *  Data used to represent an ensemble:
 */
struct Ensemble;
typedef struct EnsemblePart {
    char *name;                 /* name of this part */
    int minChars;               /* chars needed to uniquely identify part */
    Command *cmdPtr;            /* command handling this part */
    char *usage;                /* usage string describing syntax */
    struct Ensemble* ensemble;  /* ensemble containing this part */
} EnsemblePart;

/*
 *  Data used to represent an ensemble:
 */
typedef struct Ensemble {
    Tcl_Interp *interp;         /* interpreter containing this ensemble */
    EnsemblePart **parts;       /* list of parts in this ensemble */
    int numParts;               /* number of parts in part list */
    int maxParts;               /* current size of parts list */
    Tcl_Command cmd;            /* command representing this ensemble */
    EnsemblePart* parent;       /* parent part for sub-ensembles
                                 * NULL => toplevel ensemble */
} Ensemble;

/*
 *  Data shared by ensemble access commands and ensemble parser:
 */
typedef struct EnsembleParser {
    Tcl_Interp* master;           /* master interp containing ensembles */
    Tcl_Interp* parser;           /* slave interp for parsing */
    Ensemble* ensData;            /* add parts to this ensemble */
} EnsembleParser;

/*
 *  Declarations for local procedures to this file:
 */
static void FreeEnsInvocInternalRep _ANSI_ARGS_((Tcl_Obj *objPtr));
static void DupEnsInvocInternalRep _ANSI_ARGS_((Tcl_Obj *objPtr,
    Tcl_Obj *copyPtr));
static void UpdateStringOfEnsInvoc _ANSI_ARGS_((Tcl_Obj *objPtr));
static int SetEnsInvocFromAny _ANSI_ARGS_((Tcl_Interp *interp,
    Tcl_Obj *objPtr));

/*
 *  This structure defines a Tcl object type that takes the
 *  place of a part name during ensemble invocations.  When an
 *  error occurs and the caller tries to print objv[0], it will
 *  get a string that contains a complete path to the ensemble
 *  part.
 */
Tcl_ObjType itclEnsInvocType = {
    "ensembleInvoc",                    /* name */
    FreeEnsInvocInternalRep,            /* freeIntRepProc */
    DupEnsInvocInternalRep,             /* dupIntRepProc */
    UpdateStringOfEnsInvoc,             /* updateStringProc */
    SetEnsInvocFromAny                  /* setFromAnyProc */
};

/*
 *  Boolean flag indicating whether or not the "ensemble" object
 *  type has been registered with the Tcl compiler.
 */
static int ensInitialized = 0;

/*
 *  Forward declarations for the procedures used in this file.
 */
static void GetEnsembleUsage _ANSI_ARGS_((Ensemble *ensData,
    Tcl_Obj *objPtr));

static void GetEnsemblePartUsage _ANSI_ARGS_((EnsemblePart *ensPart,
    Tcl_Obj *objPtr));

static int CreateEnsemble _ANSI_ARGS_((Tcl_Interp *interp,
    Ensemble *parentEnsData, char *ensName));

static int AddEnsemblePart _ANSI_ARGS_((Tcl_Interp *interp,
    Ensemble* ensData, char* partName, char* usageInfo,
    Tcl_ObjCmdProc *objProc, ClientData clientData,
    Tcl_CmdDeleteProc *deleteProc, EnsemblePart **rVal));

static void DeleteEnsemble _ANSI_ARGS_((ClientData clientData));

static int FindEnsemble _ANSI_ARGS_((Tcl_Interp *interp, char **nameArgv,
    int nameArgc, Ensemble** ensDataPtr));

static int CreateEnsemblePart _ANSI_ARGS_((Tcl_Interp *interp,
    Ensemble *ensData, char* partName, EnsemblePart **ensPartPtr));

static void DeleteEnsemblePart _ANSI_ARGS_((EnsemblePart *ensPart));

static int FindEnsemblePart _ANSI_ARGS_((Tcl_Interp *interp,
    Ensemble *ensData, char* partName, EnsemblePart **rensPart));

static int FindEnsemblePartIndex _ANSI_ARGS_((Ensemble *ensData,
    char *partName, int *posPtr));

static void ComputeMinChars _ANSI_ARGS_((Ensemble *ensData, int pos));

static int HandleEnsemble _ANSI_ARGS_((ClientData clientData,
    Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]));

static EnsembleParser* GetEnsembleParser _ANSI_ARGS_((Tcl_Interp *interp));

static void DeleteEnsParser _ANSI_ARGS_((ClientData clientData,
    Tcl_Interp* interp));



/*
 *----------------------------------------------------------------------
 *
 * Itcl_EnsembleInit --
 *
 *      Called when any interpreter is created to make sure that
 *      things are properly set up for ensembles.
 *
 * Results:
 *      Returns TCL_OK if successful, and TCL_ERROR if anything goes
 *      wrong.
 *
 * Side effects:
 *      On the first call, the "ensemble" object type is registered
 *      with the Tcl compiler.  If an error is encountered, an error
 *      is left as the result in the interpreter.
 *
 *----------------------------------------------------------------------
 */
	/* ARGSUSED */
int
Itcl_EnsembleInit(interp)
    Tcl_Interp *interp;         /* interpreter being initialized */
{
    if (!ensInitialized) {
        Tcl_RegisterObjType(&itclEnsInvocType);
        ensInitialized = 1;
    }

    Tcl_CreateObjCommand(interp, "::itcl::ensemble",
        Itcl_EnsembleCmd, (ClientData)NULL, (Tcl_CmdDeleteProc*)NULL);

    return TCL_OK;
}


/*
 *----------------------------------------------------------------------
 *
 * Itcl_CreateEnsemble --
 *
 *      Creates an ensemble command, or adds a sub-ensemble to an
 *      existing ensemble command.  The ensemble name is a space-
 *      separated list.  The first word in the list is the command
 *      name for the top-level ensemble.  Other names do not have
 *      commands associated with them; they are merely sub-ensembles
 *      within the ensemble.  So a name like "a::b::foo bar baz"
 *      represents an ensemble command called "foo" in the namespace
 *      "a::b" that has a sub-ensemble "bar", that has a sub-ensemble
 *      "baz".
 *
 *      If the name is a single word, then this procedure creates
 *      a top-level ensemble and installs an access command for it.
 *      If a command already exists with that name, it is deleted.
 *
 *      If the name has more than one word, then the leading words
 *      are treated as a path name for an existing ensemble.  The
 *      last word is treated as the name for a new sub-ensemble.
 *      If an part already exists with that name, it is an error.
 *
 * Results:
 *      Returns TCL_OK if successful, and TCL_ERROR if anything goes
 *      wrong.
 *
 * Side effects:
 *      If an error is encountered, an error is left as the result
 *      in the interpreter.
 *
 *----------------------------------------------------------------------
 */
int
Itcl_CreateEnsemble(interp, ensName)
    Tcl_Interp *interp;            /* interpreter to be updated */
    char* ensName;                 /* name of the new ensemble */
{
    char **nameArgv = NULL;
    int nameArgc;
    Ensemble *parentEnsData;
    Tcl_DString buffer;

    /*
     *  Split the ensemble name into its path components.
     */
    if (Tcl_SplitList(interp, ensName, &nameArgc, &nameArgv) != TCL_OK) {
        goto ensCreateFail;
    }
    if (nameArgc < 1) {
        Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
            "invalid ensemble name \"", ensName, "\"",
            (char*)NULL);
        goto ensCreateFail;
    }

    /*
     *  If there is more than one path component, then follow
     *  the path down to the last component, to find the containing
     *  ensemble.
     */
    parentEnsData = NULL;
    if (nameArgc > 1) {
        if (FindEnsemble(interp, nameArgv, nameArgc-1, &parentEnsData)
            != TCL_OK) {
            goto ensCreateFail;
        }

        if (parentEnsData == NULL) {
            char *pname = Tcl_Merge(nameArgc-1, nameArgv);
            Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
                "invalid ensemble name \"", pname, "\"",
                (char*)NULL);
            ckfree(pname);
            goto ensCreateFail;
        }
    }

    /*
     *  Create the ensemble.
     */
    if (CreateEnsemble(interp, parentEnsData, nameArgv[nameArgc-1])
        != TCL_OK) {
        goto ensCreateFail;
    }

    ckfree((char*)nameArgv);
    return TCL_OK;

ensCreateFail:
    if (nameArgv) {
        ckfree((char*)nameArgv);
    }
    Tcl_DStringInit(&buffer);
    Tcl_DStringAppend(&buffer, "\n    (while creating ensemble \"", -1);
    Tcl_DStringAppend(&buffer, ensName, -1);
    Tcl_DStringAppend(&buffer, "\")", -1);
    Tcl_AddObjErrorInfo(interp, Tcl_DStringValue(&buffer), -1);
    Tcl_DStringFree(&buffer);

    return TCL_ERROR;
}


/*
 *----------------------------------------------------------------------
 *
 * Itcl_AddEnsemblePart --
 *
 *      Adds a part to an ensemble which has been created by
 *      Itcl_CreateEnsemble.  Ensembles are addressed by name, as
 *      described in Itcl_CreateEnsemble.
 *
 *      If the ensemble already has a part with the specified name,
 *      this procedure returns an error.  Otherwise, it adds a new
 *      part to the ensemble.
 *
 *      Any client data specified is automatically passed to the
 *      handling procedure whenever the part is invoked.  It is
 *      automatically destroyed by the deleteProc when the part is
 *      deleted.
 *
 * Results:
 *      Returns TCL_OK if successful, and TCL_ERROR if anything goes
 *      wrong.
 *
 * Side effects:
 *      If an error is encountered, an error is left as the result
 *      in the interpreter.
 *
 *----------------------------------------------------------------------
 */
int
Itcl_AddEnsemblePart(interp, ensName, partName, usageInfo,
    objProc, clientData, deleteProc)

    Tcl_Interp *interp;            /* interpreter to be updated */
    char* ensName;                 /* ensemble containing this part */
    char* partName;                /* name of the new part */
    char* usageInfo;               /* usage info for argument list */
    Tcl_ObjCmdProc *objProc;       /* handling procedure for part */
    ClientData clientData;         /* client data associated with part */
    Tcl_CmdDeleteProc *deleteProc; /* procedure used to destroy client data */
{
    char **nameArgv = NULL;
    int nameArgc;
    Ensemble *ensData;
    EnsemblePart *ensPart;
    Tcl_DString buffer;

    /*
     *  Parse the ensemble name and look for a containing ensemble.
     */
    if (Tcl_SplitList(interp, ensName, &nameArgc, &nameArgv) != TCL_OK) {
        goto ensPartFail;
    }
    if (FindEnsemble(interp, nameArgv, nameArgc, &ensData) != TCL_OK) {
        goto ensPartFail;
    }

    if (ensData == NULL) {
        char *pname = Tcl_Merge(nameArgc, nameArgv);
        Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
            "invalid ensemble name \"", pname, "\"",
            (char*)NULL);
        ckfree(pname);
        goto ensPartFail;
    }

    /*
     *  Install the new part into the part list.
     */
    if (AddEnsemblePart(interp, ensData, partName, usageInfo,
        objProc, clientData, deleteProc, &ensPart) != TCL_OK) {
        goto ensPartFail;
    }

    ckfree((char*)nameArgv);
    return TCL_OK;

ensPartFail:
    if (nameArgv) {
        ckfree((char*)nameArgv);
    }
    Tcl_DStringInit(&buffer);
    Tcl_DStringAppend(&buffer, "\n    (while adding to ensemble \"", -1);
    Tcl_DStringAppend(&buffer, ensName, -1);
    Tcl_DStringAppend(&buffer, "\")", -1);
    Tcl_AddObjErrorInfo(interp, Tcl_DStringValue(&buffer), -1);
    Tcl_DStringFree(&buffer);

    return TCL_ERROR;
}


/*
 *----------------------------------------------------------------------
 *
 * Itcl_GetEnsemblePart --
 *
 *      Looks for a part within an ensemble, and returns information
 *      about it.
 *
 * Results:
 *      If the ensemble and its part are found, this procedure
 *      loads information about the part into the "infoPtr" structure
 *      and returns 1.  Otherwise, it returns 0.
 *
 * Side effects:
 *      None.
 *
 *----------------------------------------------------------------------
 */
int
Itcl_GetEnsemblePart(interp, ensName, partName, infoPtr)
    Tcl_Interp *interp;            /* interpreter to be updated */
    char *ensName;                 /* ensemble containing the part */
    char *partName;                /* name of the desired part */
    Tcl_CmdInfo *infoPtr;          /* returns: info associated with part */
{
    char **nameArgv = NULL;
    int nameArgc;
    Ensemble *ensData;
    EnsemblePart *ensPart;
    Command *cmdPtr;
    Itcl_InterpState state;

    /*
     *  Parse the ensemble name and look for a containing ensemble.
     *  Save the interpreter state before we do this.  If we get any
     *  errors, we don't want them to affect the interpreter.
     */
    state = Itcl_SaveInterpState(interp, TCL_OK);

    if (Tcl_SplitList(interp, ensName, &nameArgc, &nameArgv) != TCL_OK) {
        goto ensGetFail;
    }
    if (FindEnsemble(interp, nameArgv, nameArgc, &ensData) != TCL_OK) {
        goto ensGetFail;
    }
    if (ensData == NULL) {
        goto ensGetFail;
    }

    /*