Tcl Source Code

    {"private", TclOODefinePrivateObjCmd, 1},
    {"renamemethod", TclOODefineRenameMethodObjCmd, 1},
    {"self", TclOODefineObjSelfObjCmd, 0},
    {"unexport", TclOODefineUnexportObjCmd, 1},
    {NULL, NULL, 0}
};

static const char *
initCmds[] = {
    "_init",
    "class",
    "configurable",
    "define",
    "objdefine",
    "object",
    "singleton",
    "InfoObject",
    "InfoClass",
    NULL
};

/*
 * What sort of size of things we like to allocate.
 */

#define ALLOC_CHUNK 8

/*

 *	Creates namespaces, commands, several classes and a number of
 *	callbacks. Upon return, the OO system is ready for use.
 *
 * ----------------------------------------------------------------------
 */
static int
TclOOInitModuleObjCmd(
    void *clientData,
    Tcl_Interp *interp,
    int objc,
    Tcl_Obj *const objv[])
{
    Interp *iPtr = (Interp *)interp;
    
    if (iPtr->objectFoundation != NULL) {
	/* 
	 * Shall be not initialized yet, so it looks like a mockup/injection,
	 * try to update the command.
	 */
	Foundation *fPtr = (Foundation *) iPtr->objectFoundation;
	const char *cmdName = (char *)clientData;

	if (objc) {
	    Tcl_Command cmd = Tcl_FindCommand(interp, cmdName, fPtr->ooNs, 0);
	    Tcl_Command cmd2 = Tcl_FindCommand(interp, TclGetString(objv[0]),
					fPtr->ooNs, 0);
	    if (cmd && cmd2) {
	    	Tcl_CmdInfo info;
		Tcl_GetCommandInfoFromToken(cmd, &info);
		Tcl_SetCommandInfoFromToken(cmd2, &info);
		goto evalIt;
	    }
	}

	/* We cannot reinitialize the command, so simply produce an error */
	Tcl_SetObjResult(interp, Tcl_ObjPrintf(
	    "unexpected already initialized foundation calling \"%s\" for \"%s\"",
		objc ? TclGetString(objv[0]) : "", cmdName));
	return TCL_ERROR;
    }

    /*
     * Defining of oo::{configurable,singleton} as classes will fail
     * if the command of that name exists so delete their stubs.
     */
    (void) Tcl_DeleteCommand(interp, "::oo::configurable");
    (void) Tcl_DeleteCommand(interp, "::oo::singleton");
    if (InitFoundation(interp) != TCL_OK) {
	return TCL_ERROR;
    }


evalIt:
    return Tcl_EvalObjv(interp, objc, objv, 0);
}

/*
 * ----------------------------------------------------------------------
 *
 * TclOOInit --

 *
 * ----------------------------------------------------------------------
 */
int
TclOOInit(
    Tcl_Interp *interp)		/* The interpreter to install into. */
{
    Tcl_Namespace *ooNS;
    const char **cmdNamePtr;


    Tcl_Command infoCmd;

    Tcl_Obj *mapDict;

    ooNS = Tcl_CreateNamespace(interp, "::oo", NULL, NULL);

    for (cmdNamePtr = initCmds; *cmdNamePtr; cmdNamePtr++) {
	TclCreateObjCommandInNs(interp, *cmdNamePtr, ooNS,
		TclOOInitModuleObjCmd, (void *)*cmdNamePtr, NULL);
    }




    /*
     * Install into the [info] ensemble.
     */

    infoCmd = Tcl_FindCommand(interp, "info", NULL, TCL_GLOBAL_ONLY);
    if (infoCmd) {




	Tcl_GetEnsembleMappingDict(NULL, infoCmd, &mapDict);
	TclDictPutString(NULL, mapDict, "object", "::oo::InfoObject");
	TclDictPutString(NULL, mapDict, "class", "::oo::InfoClass");
	Tcl_SetEnsembleMappingDict(interp, infoCmd, mapDict);
    }

    /*
     * Set up the version and patchlevel variables. This used to be done by
     * the init script which is no longer used.
     */
    Tcl_SetVar2(interp, "::oo::patchlevel", NULL, TCLOO_PATCHLEVEL, 0);
    Tcl_SetVar2(interp, "::oo::version", NULL, TCLOO_VERSION, 0);








    if (Tcl_EvalEx(interp,
	"package ifneeded tcl::oo " TCLOO_PATCHLEVEL " oo::_init;"
	"package ifneeded TclOO " TCLOO_PATCHLEVEL " oo::_init;",
	TCL_INDEX_NONE, 0) != TCL_OK) {
	return TCL_ERROR;
    }
    return TCL_OK;
}

/*

    }
    cmdPtr = (Command *) TclCreateObjCommandInNs(interp, name,
	    namespacePtr, cmdProc, NULL, NULL);
    cmdPtr->nreProc = nreProc;
    cmdPtr->compileProc = compileProc;
}

static int
NoopCmd(
    TCL_UNUSED(void *),
    TCL_UNUSED(Tcl_Interp *),
    TCL_UNUSED(int) /*objc*/,
    TCL_UNUSED(Tcl_Obj *const *) /*objv*/)
{
    return TCL_OK;
}
/*
 * ----------------------------------------------------------------------
 *
 * InitFoundation --
 *
 *	Set up the core of the OO core class system. This is a structure
 *	holding references to the magical bits that need to be known about in
 *	other places, plus the oo::object and oo::class classes.
 *
 * ----------------------------------------------------------------------
 */

static int
InitFoundation(
    Tcl_Interp *interp)
{
    static Tcl_ThreadDataKey tsdKey;
    ThreadLocalData *tsdPtr = (ThreadLocalData *)
	    Tcl_GetThreadData(&tsdKey, sizeof(ThreadLocalData));
    Foundation *fPtr;
    Tcl_Namespace *define, *objdef;
    Tcl_Obj *namePtr;
    size_t i;

    if (((Interp *) interp)->objectFoundation) {
	return TCL_OK;
    }

#ifndef TCL_NO_DEPRECATED
    Tcl_PkgProvideEx(interp, "TclOO", TCLOO_PATCHLEVEL,

	    &tclOOStubs);
#endif
    Tcl_PkgProvideEx(interp, "tcl::oo", TCLOO_PATCHLEVEL,
	    &tclOOStubs);


    /*
     * Initialize the structure that holds the OO system core. This is
     * attached to the interpreter via an assocData entry; not very efficient,
     * but the best we can do without hacking the core more.
     */

    fPtr = (Foundation *) Tcl_Alloc(sizeof(Foundation));
    memset(fPtr, 0, sizeof(Foundation));
    ((Interp *) interp)->objectFoundation = fPtr;
    fPtr->interp = interp;
    fPtr->ooNs = Tcl_FindNamespace(interp, "::oo", NULL, 0);
    assert(fPtr->ooNs != NULL);
    TclCreateObjCommandInNs(interp, "_init", fPtr->ooNs, NoopCmd, NULL, NULL);
    Tcl_Export(interp, fPtr->ooNs, "[a-z]*", 1);
    define = Tcl_CreateNamespace(interp, "::oo::define", fPtr, NULL);
    objdef = Tcl_CreateNamespace(interp, "::oo::objdefine", fPtr, NULL);
    fPtr->helpersNs = Tcl_CreateNamespace(interp, "::oo::Helpers", fPtr,
	    DeletedHelpersNamespace);
    Tcl_CreateNamespace(interp, "::oo::configuresupport", NULL, NULL);
    fPtr->epoch = 1;