Tcl Source Code

    Tcl_IncrRefCount(fPtr->clonedName);
    Tcl_IncrRefCount(fPtr->defineName);
    Tcl_CreateObjCommand(interp, "::oo::UnknownDefinition",
	    TclOOUnknownDefinition, NULL, NULL);
    TclNewLiteralStringObj(namePtr, "::oo::UnknownDefinition");
    Tcl_SetNamespaceUnknownHandler(interp, fPtr->defineNs, namePtr);
    Tcl_SetNamespaceUnknownHandler(interp, fPtr->objdefNs, namePtr);
    Tcl_CreateObjCommand(interp, "::oo::SetClassDefinitionNamespace",
	    TclOOSetClassDefinitionNamespaceObjectCmd, NULL, NULL);
    Tcl_CreateObjCommand(interp, "::oo::SetObjectDefinitionNamespace",
	    TclOOSetObjectDefinitionNamespaceObjectCmd, NULL, NULL);

    /*
     * Create the subcommands in the oo::define and oo::objdefine spaces.
     */

    Tcl_DStringInit(&buffer);
    for (i=0 ; defineCmds[i].name ; i++) {

    /*
     * Return the name of the cloned object.
     */

    Tcl_SetObjResult(interp, TclOOObjectName(interp, (Object *) o2Ptr));
    return TCL_OK;
}

int
TclOOSetClassDefinitionNamespaceObjectCmd(
    ClientData clientData,
    Tcl_Interp *interp,
    int objc,
    Tcl_Obj *const *objv)
{
    Tcl_Object object;
    Class *classPtr;
    int haveNs;
    Tcl_Namespace *nsPtr;

    if (objc != 3) {
	Tcl_WrongNumArgs(interp, 1, objv, "class namespace");
	return TCL_ERROR;
    }
    object = Tcl_GetObjectFromObj(interp, objv[1]);
    if (object == NULL) {
	return TCL_ERROR;
    }
    classPtr = ((Object *)object)->classPtr;
    if (classPtr == NULL) {
	Tcl_SetObjResult(interp, Tcl_ObjPrintf(
		"\"%s\" is not a class", TclGetString(objv[1])));
	Tcl_SetErrorCode(interp, "TCL", "OO", "CLASS_REQUIRED", NULL);
	return TCL_ERROR;
    }
    haveNs = (Tcl_GetString(objv[2])[0] != '\0');
    if (haveNs &&
	    TclGetNamespaceFromObj(interp, objv[2], &nsPtr) != TCL_OK) {
	return TCL_ERROR;
    }

    if (classPtr->definitionNs) {
	Tcl_DecrRefCount(classPtr->definitionNs);
	classPtr->definitionNs = NULL;
    }
    if (haveNs) {
	classPtr->definitionNs = objv[2];
	Tcl_IncrRefCount(classPtr->definitionNs);
    }
    return TCL_OK;
}

int
TclOOSetObjectDefinitionNamespaceObjectCmd(
    ClientData clientData,
    Tcl_Interp *interp,
    int objc,
    Tcl_Obj *const *objv)
{
    Object *oPtr;
    int haveNs;
    Tcl_Namespace *nsPtr;

    if (objc != 3) {
	Tcl_WrongNumArgs(interp, 1, objv, "object namespace");
	return TCL_ERROR;
    }

    oPtr = (Object *) Tcl_GetObjectFromObj(interp, objv[1]);
    if (oPtr == NULL) {
	return TCL_ERROR;
    }
    haveNs = (Tcl_GetString(objv[2])[0] != '\0');
    if (haveNs &&
	    TclGetNamespaceFromObj(interp, objv[2], &nsPtr) != TCL_OK) {
	return TCL_ERROR;
    }

    if (oPtr->definitionNs) {
	Tcl_DecrRefCount(oPtr->definitionNs);
	oPtr->definitionNs = NULL;
    }
    if (haveNs) {
	oPtr->definitionNs = objv[2];
	Tcl_IncrRefCount(oPtr->definitionNs);
    }
    return TCL_OK;
}

/*
 * Local Variables:
 * mode: c
 * c-basic-offset: 4
 * fill-column: 78
 * End:

    Tcl_Interp *interp,
    int objc,
    Tcl_Obj *const *objv)
{
    Foundation *fPtr = TclOOGetFoundation(interp);
    int result;
    Object *oPtr;
    Tcl_Namespace *nsPtr = NULL;

    if (objc < 3) {
	Tcl_WrongNumArgs(interp, 1, objv, "className arg ?arg ...?");
	return TCL_ERROR;
    }

    oPtr = (Object *) Tcl_GetObjectFromObj(interp, objv[1]);
    if (oPtr == NULL) {
	return TCL_ERROR;
    }
    if (oPtr->classPtr == NULL) {
	Tcl_SetObjResult(interp, Tcl_ObjPrintf(
		"%s does not refer to a class",TclGetString(objv[1])));
	Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "CLASS",
		TclGetString(objv[1]), NULL);
	return TCL_ERROR;
    }

    /*
     * Make the oo::define namespace (or its override) the current namespace
     * and evaluate the command(s).
     */

    if (oPtr->classPtr->definitionNs &&
	    TclGetNamespaceFromObj(interp, oPtr->classPtr->definitionNs,
		    &nsPtr) != TCL_OK) {
	return TCL_ERROR;
    }
    if (nsPtr == NULL) {
	nsPtr = fPtr->defineNs;
    }
    if (InitDefineContext(interp, nsPtr, oPtr, objc, objv) != TCL_OK) {
	return TCL_ERROR;
    }

    AddRef(oPtr);
    if (objc == 3) {
	Tcl_Obj *objNameObj = TclOOObjectName(interp, oPtr);

	/*
	 * Build the list of arguments using a Tcl_Obj as a workspace. See
	 * comments above for why these contortions are necessary.
	 */

	objPtr = Tcl_NewObj();
	obj2Ptr = Tcl_NewObj();
	cmd = FindCommand(interp, objv[2], nsPtr);
	if (cmd == NULL) {
	    /* punt this case! */
	    Tcl_AppendObjToObj(obj2Ptr, objv[2]);
	} else {
	    Tcl_GetCommandFullName(interp, cmd, obj2Ptr);
	}
	Tcl_ListObjAppendElement(NULL, objPtr, obj2Ptr);

    Tcl_Interp *interp,
    int objc,
    Tcl_Obj *const *objv)
{
    Foundation *fPtr = TclOOGetFoundation(interp);
    int isRoot, result;
    Object *oPtr;
    Tcl_Namespace *nsPtr = NULL;

    if (objc < 3) {
	Tcl_WrongNumArgs(interp, 1, objv, "objectName arg ?arg ...?");
	return TCL_ERROR;
    }

    oPtr = (Object *) Tcl_GetObjectFromObj(interp, objv[1]);
    if (oPtr == NULL) {
	return TCL_ERROR;
    }

    /*
     * Make the oo::objdefine namespace (or its override) the current
     * namespace and evaluate the command(s).
     */

    if (oPtr->definitionNs &&
	    TclGetNamespaceFromObj(interp, oPtr->definitionNs,
		    &nsPtr) != TCL_OK) {
	return TCL_ERROR;
    }
    if (nsPtr == NULL) {
	nsPtr = fPtr->objdefNs;
    }
    if (InitDefineContext(interp, nsPtr, oPtr, objc, objv) != TCL_OK) {
	return TCL_ERROR;
    }

    AddRef(oPtr);
    if (objc == 3) {
	Tcl_Obj *objNameObj = TclOOObjectName(interp, oPtr);

	/*
	 * Build the list of arguments using a Tcl_Obj as a workspace. See
	 * comments above for why these contortions are necessary.
	 */

	objPtr = Tcl_NewObj();
	obj2Ptr = Tcl_NewObj();
	cmd = FindCommand(interp, objv[2], nsPtr);
	if (cmd == NULL) {
	    /* punt this case! */
	    Tcl_AppendObjToObj(obj2Ptr, objv[2]);
	} else {
	    Tcl_GetCommandFullName(interp, cmd, obj2Ptr);
	}
	Tcl_ListObjAppendElement(NULL, objPtr, obj2Ptr);

    Tcl_Obj *cachedNameObj;	/* Cache of the name of the object. */
    Tcl_HashTable *chainCache;	/* Place to keep unused contexts. This table
				 * is indexed by method name as Tcl_Obj. */
    Tcl_ObjectMapMethodNameProc *mapMethodNameProc;
				/* Function to allow remapping of method
				 * names. For itcl-ng. */
    LIST_STATIC(Tcl_Obj *) variables;
    Tcl_Obj *definitionNs;	/* Name of the namespace to use for
				 * oo::objdefine. If NULL, use the default
				 * from the Foundation. It's an error at
				 * [oo::objdefine] call time if this namespace
				 * is defined but doesn't exist; we also check
				 * at setting time but don't check between
				 * times. */
} Object;

#define OBJECT_DELETED	1	/* Flag to say that an object has been
				 * destroyed. */
#define DESTRUCTOR_CALLED 2	/* Flag to say that the destructor has been
				 * called. */
#define CLASS_GONE	4	/* Indicates that the class of this object has

				 * constructors, the class chain is always
				 * used. For destructors and ordinary methods,
				 * the class chain is only used when the
				 * object doesn't override with its own mixins
				 * (and filters and method implementations for
				 * when getting method chains). */
    LIST_STATIC(Tcl_Obj *) variables;
    Tcl_Obj *definitionNs;	/* Name of the namespace to do definitions of
				 * this class in. If NULL, use the default
				 * from the Foundation. It's an error at
				 * [oo::define] call time if this namespace is
				 * defined but doesn't exist; we also check
				 * at setting time but don't check between
				 * times. */
} Class;

/*
 * The foundation of the object system within an interpreter contains
 * references to the key classes and namespaces, together with a few other
 * useful bits and pieces. Probably ought to eventually go in the Interp
 * structure itself.

			    Tcl_Obj *const *objv);
MODULE_SCOPE int	TclOONextToObjCmd(ClientData clientData,
			    Tcl_Interp *interp, int objc,
			    Tcl_Obj *const *objv);
MODULE_SCOPE int	TclOOSelfObjCmd(ClientData clientData,
			    Tcl_Interp *interp, int objc,
			    Tcl_Obj *const *objv);
MODULE_SCOPE int	TclOOSetClassDefinitionNamespaceObjectCmd(
			    ClientData clientData, Tcl_Interp *interp,
			    int objc, Tcl_Obj *const *objv);
MODULE_SCOPE int	TclOOSetObjectDefinitionNamespaceObjectCmd(
			    ClientData clientData, Tcl_Interp *interp,
			    int objc, Tcl_Obj *const *objv)

/*
 * Method implementations (in tclOOBasic.c).
 */

MODULE_SCOPE int	TclOO_Class_Constructor(ClientData clientData,
			    Tcl_Interp *interp, Tcl_ObjectContext context,