summaryrefslogtreecommitdiffstats
path: root/generic
diff options
context:
space:
mode:
Diffstat (limited to 'generic')
-rw-r--r--generic/tcl.h83
-rw-r--r--generic/tclBasic.c18
-rw-r--r--generic/tclCmdIL.c20
-rw-r--r--generic/tclInt.decls5
-rw-r--r--generic/tclInt.h73
-rw-r--r--generic/tclIntDecls.h6
-rw-r--r--generic/tclNamesp.c16
-rw-r--r--generic/tclOO.c3288
-rw-r--r--generic/tclOO.h389
-rw-r--r--generic/tclOOCall.c803
-rw-r--r--generic/tclOODefineCmds.c953
-rw-r--r--generic/tclOOInfo.c901
-rw-r--r--generic/tclProc.c275
-rw-r--r--generic/tclVar.c29
14 files changed, 6752 insertions, 107 deletions
diff --git a/generic/tcl.h b/generic/tcl.h
index bc89666..2c95f26 100644
--- a/generic/tcl.h
+++ b/generic/tcl.h
@@ -13,7 +13,7 @@
* See the file "license.terms" for information on usage and redistribution of
* this file, and for a DISCLAIMER OF ALL WARRANTIES.
*
- * RCS: @(#) $Id: tcl.h,v 1.217 2006/10/05 21:24:39 hobbs Exp $
+ * RCS: @(#) $Id: tcl.h,v 1.218 2006/10/20 14:04:00 dkf Exp $
*/
#ifndef _TCL
@@ -501,6 +501,7 @@ typedef struct Tcl_Interp {
typedef struct Tcl_AsyncHandler_ *Tcl_AsyncHandler;
typedef struct Tcl_Channel_ *Tcl_Channel;
typedef struct Tcl_ChannelTypeVersion_ *Tcl_ChannelTypeVersion;
+typedef struct Tcl_Class_ *Tcl_Class;
typedef struct Tcl_Command_ *Tcl_Command;
typedef struct Tcl_Condition_ *Tcl_Condition;
typedef struct Tcl_Dict_ *Tcl_Dict;
@@ -509,7 +510,10 @@ typedef struct Tcl_Encoding_ *Tcl_Encoding;
typedef struct Tcl_Event Tcl_Event;
typedef struct Tcl_InterpState_ *Tcl_InterpState;
typedef struct Tcl_LoadHandle_ *Tcl_LoadHandle;
+typedef struct Tcl_Method_ *Tcl_Method;
typedef struct Tcl_Mutex_ *Tcl_Mutex;
+typedef struct Tcl_Object_ *Tcl_Object;
+typedef struct Tcl_ObjectContext_ *Tcl_ObjectContext;
typedef struct Tcl_Pid_ *Tcl_Pid;
typedef struct Tcl_RegExp_ *Tcl_RegExp;
typedef struct Tcl_ThreadDataKey_ *Tcl_ThreadDataKey;
@@ -953,6 +957,8 @@ typedef struct Tcl_CallFrame {
char *dummy8;
int dummy9;
char* dummy10;
+ void* dummy11;
+ /*int dummy12;*/
} Tcl_CallFrame;
/*
@@ -2351,6 +2357,81 @@ typedef unsigned long mp_digit;
#define MP_DIGIT_DECLARED
#endif
+/*
+ * Public datatypes for callbacks and structures used in the TIP#257 (OO)
+ * implementation. These are used to implement custom types of method calls
+ * and to allow the attachment of arbitrary data to objects and classes.
+ */
+
+typedef int (*Tcl_MethodCallProc)_ANSI_ARGS_((ClientData clientData,
+ Tcl_Interp *interp, Tcl_ObjectContext objectContext, int objc,
+ Tcl_Obj *const *objv));
+typedef void (*Tcl_MethodDeleteProc)_ANSI_ARGS_((ClientData clientData));
+typedef int (*Tcl_MethodCloneProc)_ANSI_ARGS_((ClientData oldClientData,
+ ClientData *newClientData));
+typedef void (*Tcl_ObjectMetadataDeleteProc)_ANSI_ARGS_((
+ ClientData clientData));
+typedef ClientData (*Tcl_ObjectMetadataCloneProc)_ANSI_ARGS_((
+ ClientData clientData));
+
+/*
+ * The type of a method implementation. This describes how to call the method
+ * implementation, how to delete it (when the object or class is deleted) and
+ * how to create a clone of it (when the object or class is copied).
+ */
+
+typedef struct {
+ int version; /* Structure version field. Always to be equal
+ * to TCL_OO_METHOD_VERSION_CURRENT in
+ * declarations. */
+ const char *name; /* Name of this type of method, mostly for
+ * debugging purposes. */
+ Tcl_MethodCallProc callProc;/* How to invoke this method. */
+ Tcl_MethodDeleteProc deleteProc;
+ /* How to delete this method's type-specific
+ * data, or NULL if the type-specific data
+ * does not need deleting. */
+ Tcl_MethodCloneProc cloneProc;
+ /* How to copy this method's type-specific
+ * data, or NULL if the type-specific data can
+ * be copied directly. */
+} Tcl_MethodType;
+
+/*
+ * The correct value for the version field of the Tcl_MethodType structure.
+ * This allows new versions of the structure to be introduced without breaking
+ * binary compatability.
+ */
+
+#define TCL_OO_METHOD_VERSION_CURRENT 1
+
+/*
+ * The type of some object (or class) metadata. This describes how to delete
+ * the metadata (when the object or class is deleted) and how to create a
+ * clone of it (when the object or class is copied).
+ */
+
+typedef struct {
+ int version; /* Structure version field. Always to be equal
+ * to TCL_OO_METADATA_VERSION_CURRENT in
+ * declarations. */
+ const char *name;
+ Tcl_ObjectMetadataDeleteProc deleteProc;
+ /* How to delete the metadata. This must not
+ * be NULL. */
+ Tcl_ObjectMetadataCloneProc cloneProc;
+ /* How to clone the metadata. If NULL, the
+ * metadata will not be copied. */
+} Tcl_ObjectMetadataType;
+
+/*
+ * The correct value for the version field of the Tcl_ObjectMetadataType
+ * structure. This allows new versions of the structure to be introduced
+ * without breaking binary compatability.
+ */
+
+#define TCL_OO_METHOD_VERSION_CURRENT 1
+
#ifndef TCL_NO_DEPRECATED
/*
* Deprecated Tcl functions:
diff --git a/generic/tclBasic.c b/generic/tclBasic.c
index 49211d0..0b9f15f 100644
--- a/generic/tclBasic.c
+++ b/generic/tclBasic.c
@@ -13,7 +13,7 @@
* See the file "license.terms" for information on usage and redistribution of
* this file, and for a DISCLAIMER OF ALL WARRANTIES.
*
- * RCS: @(#) $Id: tclBasic.c,v 1.198 2006/10/16 16:52:01 andreas_kupries Exp $
+ * RCS: @(#) $Id: tclBasic.c,v 1.199 2006/10/20 14:04:00 dkf Exp $
*/
#include "tclInt.h"
@@ -526,13 +526,18 @@ Tcl_CreateInterp(void)
#endif
/*
- * TIP #59: Make embedded configuration information
- * available.
+ * TIP #59: Make embedded configuration information available.
*/
TclInitEmbeddedConfigurationInformation(interp);
/*
+ * TIP #257: Install the OO engine (for testing).
+ */
+
+ TclOOInit(interp);
+
+ /*
* Compute the byte order of this machine.
*/
@@ -1938,8 +1943,8 @@ TclInvokeObjectCommand(
int
TclRenameCommand(
Tcl_Interp *interp, /* Current interpreter. */
- char *oldName, /* Existing command name. */
- char *newName) /* New command name. */
+ const char *oldName, /* Existing command name. */
+ const char *newName) /* New command name. */
{
Interp *iPtr = (Interp *) interp;
CONST char *newTail;
@@ -1956,8 +1961,7 @@ TclRenameCommand(
* found.
*/
- cmd = Tcl_FindCommand(interp, oldName, NULL,
- /*flags*/ 0);
+ cmd = Tcl_FindCommand(interp, oldName, NULL, /*flags*/ 0);
cmdPtr = (Command *) cmd;
if (cmdPtr == NULL) {
Tcl_AppendResult(interp, "can't ",
diff --git a/generic/tclCmdIL.c b/generic/tclCmdIL.c
index be2f4c2..97170a9 100644
--- a/generic/tclCmdIL.c
+++ b/generic/tclCmdIL.c
@@ -16,7 +16,7 @@
* See the file "license.terms" for information on usage and redistribution of
* this file, and for a DISCLAIMER OF ALL WARRANTIES.
*
- * RCS: @(#) $Id: tclCmdIL.c,v 1.87 2006/08/09 14:16:03 dkf Exp $
+ * RCS: @(#) $Id: tclCmdIL.c,v 1.88 2006/10/20 14:04:00 dkf Exp $
*/
#include "tclInt.h"
@@ -357,17 +357,17 @@ Tcl_InfoObjCmd(clientData, interp, objc, objv)
Tcl_Obj *CONST objv[]; /* Argument objects. */
{
static CONST char *subCmds[] = {
- "args", "body", "cmdcount", "commands",
+ "args", "body", "class", "cmdcount", "commands",
"complete", "default", "exists", "functions", "globals",
- "hostname", "level", "library", "loaded",
- "locals", "nameofexecutable", "patchlevel", "procs",
+ "hostname", "level", "library", "loaded", "locals",
+ "nameofexecutable", "object", "patchlevel", "procs",
"script", "sharedlibextension", "tclversion", "vars",
(char *) NULL};
enum ISubCmdIdx {
- IArgsIdx, IBodyIdx, ICmdCountIdx, ICommandsIdx,
+ IArgsIdx, IBodyIdx, IClassIdx, ICmdCountIdx, ICommandsIdx,
ICompleteIdx, IDefaultIdx, IExistsIdx, IFunctionsIdx, IGlobalsIdx,
- IHostnameIdx, ILevelIdx, ILibraryIdx, ILoadedIdx,
- ILocalsIdx, INameOfExecutableIdx, IPatchLevelIdx, IProcsIdx,
+ IHostnameIdx, ILevelIdx, ILibraryIdx, ILoadedIdx, ILocalsIdx,
+ INameOfExecutableIdx, IObjectIdx, IPatchLevelIdx, IProcsIdx,
IScriptIdx, ISharedLibExtensionIdx, ITclVersionIdx, IVarsIdx
};
int index, result;
@@ -390,6 +390,9 @@ Tcl_InfoObjCmd(clientData, interp, objc, objv)
case IBodyIdx:
result = InfoBodyCmd(clientData, interp, objc, objv);
break;
+ case IClassIdx:
+ result = TclInfoClassCmd(clientData, interp, objc, objv);
+ break;
case ICmdCountIdx:
result = InfoCmdCountCmd(clientData, interp, objc, objv);
break;
@@ -429,6 +432,9 @@ Tcl_InfoObjCmd(clientData, interp, objc, objv)
case INameOfExecutableIdx:
result = InfoNameOfExecutableCmd(clientData, interp, objc, objv);
break;
+ case IObjectIdx:
+ result = TclInfoObjectCmd(clientData, interp, objc, objv);
+ break;
case IPatchLevelIdx:
result = InfoPatchLevelCmd(clientData, interp, objc, objv);
break;
diff --git a/generic/tclInt.decls b/generic/tclInt.decls
index 3d77a83..c927ce1 100644
--- a/generic/tclInt.decls
+++ b/generic/tclInt.decls
@@ -12,7 +12,7 @@
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
-# RCS: @(#) $Id: tclInt.decls,v 1.98 2006/09/30 19:00:12 msofer Exp $
+# RCS: @(#) $Id: tclInt.decls,v 1.99 2006/10/20 14:04:00 dkf Exp $
library tcl
@@ -390,7 +390,8 @@ declare 93 generic {
# int TclpStat(CONST char *path, Tcl_StatBuf *buf)
#}
declare 96 generic {
- int TclRenameCommand(Tcl_Interp *interp, char *oldName, char *newName)
+ int TclRenameCommand(Tcl_Interp *interp, CONST char *oldName,
+ CONST char *newName)
}
declare 97 generic {
void TclResetShadowedCmdRefs(Tcl_Interp *interp, Command *newCmdPtr)
diff --git a/generic/tclInt.h b/generic/tclInt.h
index 6c45660..02bfbcb 100644
--- a/generic/tclInt.h
+++ b/generic/tclInt.h
@@ -12,7 +12,7 @@
* See the file "license.terms" for information on usage and redistribution of
* this file, and for a DISCLAIMER OF ALL WARRANTIES.
*
- * RCS: @(#) $Id: tclInt.h,v 1.279 2006/09/30 19:00:12 msofer Exp $
+ * RCS: @(#) $Id: tclInt.h,v 1.280 2006/10/20 14:04:00 dkf Exp $
*/
#ifndef _TCLINT
@@ -112,6 +112,8 @@ typedef int ptrdiff_t;
#define NO_WIDE_TYPE
#endif
+struct Foundation; // Forward decl for OO support
+
/*
* The following procedures allow namespaces to be customized to support
* special name resolution rules for commands/variables.
@@ -890,9 +892,15 @@ typedef struct CallFrame {
* recognized by the compiler. The compiler
* emits code that refers to these variables
* using an index into this array. */
+ void *ooContextPtr; /* TODO: Docme */
} CallFrame;
#define FRAME_IS_PROC 0x1
+#define FRAME_IS_METHOD 0x2 /* TODO: Docme */
+#define FRAME_IS_FILTER 0x4 /* TODO: Docme */
+#define FRAME_IS_OO_DEFINE 0x8 /* TODO: Docme */
+#define FRAME_IS_CONSTRUCTOR 0x10
+#define FRAME_IS_DESTRUCTOR 0x20
/*
*----------------------------------------------------------------
@@ -1514,6 +1522,8 @@ typedef struct Interp {
* inserted by an ensemble. */
} ensembleRewrite;
+ struct Foundation *ooFoundation; // OO support
+
/*
* TIP #219 ... Global info for the I/O system ...
*/
@@ -2109,7 +2119,7 @@ MODULE_SCOPE void TclInitLimitSupport(Tcl_Interp *interp);
MODULE_SCOPE void TclInitNamespaceSubsystem(void);
MODULE_SCOPE void TclInitNotifier(void);
MODULE_SCOPE void TclInitObjSubsystem(void);
-MODULE_SCOPE void TclInitSubsystems ();
+MODULE_SCOPE void TclInitSubsystems(void);
MODULE_SCOPE int TclInterpReady(Tcl_Interp *interp);
MODULE_SCOPE int TclIsLocalScalar(CONST char *src, int len);
MODULE_SCOPE int TclJoinThread(Tcl_ThreadId id, int* result);
@@ -2377,6 +2387,12 @@ MODULE_SCOPE int Tcl_IncrObjCmd(ClientData clientData,
MODULE_SCOPE int Tcl_InfoObjCmd(ClientData clientData,
Tcl_Interp *interp, int objc,
Tcl_Obj *CONST objv[]);
+MODULE_SCOPE int TclInfoClassCmd(ClientData clientData,
+ Tcl_Interp *interp, int objc,
+ Tcl_Obj *CONST objv[]);
+MODULE_SCOPE int TclInfoObjectCmd(ClientData clientData,
+ Tcl_Interp *interp, int objc,
+ Tcl_Obj *CONST objv[]);
MODULE_SCOPE int Tcl_InterpObjCmd(ClientData clientData,
Tcl_Interp *interp, int argc,
Tcl_Obj *CONST objv[]);
@@ -2518,6 +2534,55 @@ MODULE_SCOPE int Tcl_WhileObjCmd(ClientData clientData,
/*
*----------------------------------------------------------------
+ * Commands relating to OO support.
+ *----------------------------------------------------------------
+ */
+
+MODULE_SCOPE int TclOOInit(Tcl_Interp *interp);
+MODULE_SCOPE int TclOODefineObjCmd(ClientData clientData,
+ Tcl_Interp *interp, int objc,
+ Tcl_Obj *const *objv);
+MODULE_SCOPE int TclOODefineConstructorObjCmd(ClientData clientData,
+ Tcl_Interp *interp, int objc,
+ Tcl_Obj *const *objv);
+MODULE_SCOPE int TclOODefineCopyObjCmd(ClientData clientData,
+ Tcl_Interp *interp, int objc,
+ Tcl_Obj *const *objv);
+MODULE_SCOPE int TclOODefineDestructorObjCmd(ClientData clientData,
+ Tcl_Interp *interp, int objc,
+ Tcl_Obj *const *objv);
+MODULE_SCOPE int TclOODefineExportObjCmd(ClientData clientData,
+ Tcl_Interp *interp, int objc,
+ Tcl_Obj *const *objv);
+MODULE_SCOPE int TclOODefineFilterObjCmd(ClientData clientData,
+ Tcl_Interp *interp, int objc,
+ Tcl_Obj *const *objv);
+MODULE_SCOPE int TclOODefineForwardObjCmd(ClientData clientData,
+ Tcl_Interp *interp, int objc,
+ Tcl_Obj *const *objv);
+MODULE_SCOPE int TclOODefineMethodObjCmd(ClientData clientData,
+ Tcl_Interp *interp, int objc,
+ Tcl_Obj *const *objv);
+MODULE_SCOPE int TclOODefineMixinObjCmd(ClientData clientData,
+ Tcl_Interp *interp, int objc,
+ Tcl_Obj *const *objv);
+#ifdef SUPPORT_OO_PARAMETERS
+MODULE_SCOPE int TclOODefineParameterObjCmd(ClientData clientData,
+ Tcl_Interp *interp, int objc,
+ Tcl_Obj *const *objv);
+#endif
+MODULE_SCOPE int TclOODefineSuperclassObjCmd(ClientData clientData,
+ Tcl_Interp *interp, int objc,
+ Tcl_Obj *const *objv);
+MODULE_SCOPE int TclOODefineUnexportObjCmd(ClientData clientData,
+ Tcl_Interp *interp, int objc,
+ Tcl_Obj *const *objv);
+MODULE_SCOPE int TclOODefineSelfClassObjCmd(ClientData clientData,
+ Tcl_Interp *interp, int objc,
+ Tcl_Obj *const *objv);
+
+/*
+ *----------------------------------------------------------------
* Compilation procedures for commands in the generic core:
*----------------------------------------------------------------
*/
@@ -3054,6 +3119,10 @@ MODULE_SCOPE void TclBNInitBignumFromWideUInt(mp_int* bignum,
#define TclIsNaN(d) ((d) != (d))
#endif
+// MOVE ME TO tclInt.decls
+void TclSetNsPath(Namespace *nsPtr, int pathLength,
+ Tcl_Namespace *pathAry[]);
+
#include "tclPort.h"
#include "tclIntDecls.h"
#include "tclIntPlatDecls.h"
diff --git a/generic/tclIntDecls.h b/generic/tclIntDecls.h
index f9ec7a7..3e9ba60 100644
--- a/generic/tclIntDecls.h
+++ b/generic/tclIntDecls.h
@@ -11,7 +11,7 @@
* See the file "license.terms" for information on usage and redistribution
* of this file, and for a DISCLAIMER OF ALL WARRANTIES.
*
- * RCS: @(#) $Id: tclIntDecls.h,v 1.88 2006/09/30 19:00:13 msofer Exp $
+ * RCS: @(#) $Id: tclIntDecls.h,v 1.89 2006/10/20 14:04:00 dkf Exp $
*/
#ifndef _TCLINTDECLS
@@ -424,7 +424,7 @@ EXTERN void TclProcDeleteProc _ANSI_ARGS_((ClientData clientData));
#define TclRenameCommand_TCL_DECLARED
/* 96 */
EXTERN int TclRenameCommand _ANSI_ARGS_((Tcl_Interp * interp,
- char * oldName, char * newName));
+ CONST char * oldName, CONST char * newName));
#endif
#ifndef TclResetShadowedCmdRefs_TCL_DECLARED
#define TclResetShadowedCmdRefs_TCL_DECLARED
@@ -1136,7 +1136,7 @@ typedef struct TclIntStubs {
void (*tclProcDeleteProc) _ANSI_ARGS_((ClientData clientData)); /* 93 */
void *reserved94;
void *reserved95;
- int (*tclRenameCommand) _ANSI_ARGS_((Tcl_Interp * interp, char * oldName, char * newName)); /* 96 */
+ int (*tclRenameCommand) _ANSI_ARGS_((Tcl_Interp * interp, CONST char * oldName, CONST char * newName)); /* 96 */
void (*tclResetShadowedCmdRefs) _ANSI_ARGS_((Tcl_Interp * interp, Command * newCmdPtr)); /* 97 */
int (*tclServiceIdle) _ANSI_ARGS_((void)); /* 98 */
void *reserved99;
diff --git a/generic/tclNamesp.c b/generic/tclNamesp.c
index a2e01d2..c3d4e7c 100644
--- a/generic/tclNamesp.c
+++ b/generic/tclNamesp.c
@@ -22,7 +22,7 @@
* See the file "license.terms" for information on usage and redistribution
* of this file, and for a DISCLAIMER OF ALL WARRANTIES.
*
- * RCS: @(#) $Id: tclNamesp.c,v 1.101 2006/10/10 16:45:04 dgp Exp $
+ * RCS: @(#) $Id: tclNamesp.c,v 1.102 2006/10/20 14:04:00 dkf Exp $
*/
#include "tclInt.h"
@@ -117,8 +117,8 @@ typedef struct EnsembleConfig {
* all lists, and cannot be found by scanning
* the list from the namespace's ensemble
* field. */
- int flags; /* ORed combo of ENS_DEAD and
- * TCL_ENSEMBLE_PREFIX. */
+ int flags; /* ORed combo of TCL_ENSEMBLE_PREFIX and
+ * ENS_DEAD. */
/* OBJECT FIELDS FOR ENSEMBLE CONFIGURATION */
@@ -251,8 +251,6 @@ static void FreeEnsembleCmdRep(Tcl_Obj *objPtr);
static void DupEnsembleCmdRep(Tcl_Obj *objPtr, Tcl_Obj *copyPtr);
static void StringOfEnsembleCmdRep(Tcl_Obj *objPtr);
static void UnlinkNsPath(Namespace *nsPtr);
-static void SetNsPath(Namespace *nsPtr, int pathLength,
- Tcl_Namespace *pathAry[]);
/*
* This structure defines a Tcl object type that contains a namespace
@@ -4110,7 +4108,7 @@ NamespacePathCmd(
* Now we have the list of valid namespaces, install it as the path.
*/
- SetNsPath(nsPtr, nsObjc, namespaceList);
+ TclSetNsPath(nsPtr, nsObjc, namespaceList);
result = TCL_OK;
badNamespace:
@@ -4123,7 +4121,7 @@ NamespacePathCmd(
/*
*----------------------------------------------------------------------
*
- * SetNsPath --
+ * TclSetNsPath --
*
* Sets the namespace command name resolution path to the given list of
* namespaces. If the list is empty (of zero length) the path is set to
@@ -4141,8 +4139,8 @@ NamespacePathCmd(
*/
/* EXPOSE ME? */
-static void
-SetNsPath(
+void
+TclSetNsPath(
Namespace *nsPtr, /* Namespace whose path is to be set. */
int pathLength, /* Length of pathAry */
Tcl_Namespace *pathAry[]) /* Array of namespaces that are the path. */
diff --git a/generic/tclOO.c b/generic/tclOO.c
new file mode 100644
index 0000000..bca3477
--- /dev/null
+++ b/generic/tclOO.c
@@ -0,0 +1,3288 @@
+/*
+ * tclOO.c --
+ *
+ * This file contains the object-system core (NB: not Tcl_Obj, but ::oo)
+ *
+ * Copyright (c) 2005-2006 by Donal K. Fellows
+ *
+ * See the file "license.terms" for information on usage and redistribution of
+ * this file, and for a DISCLAIMER OF ALL WARRANTIES.
+ *
+ * RCS: @(#) $Id: tclOO.c,v 1.2 2006/10/20 14:04:00 dkf Exp $
+ */
+
+#include "tclInt.h"
+#include "tclOO.h"
+
+/*
+ * Commands in oo::define.
+ */
+
+static const struct {
+ const char *name;
+ Tcl_ObjCmdProc *objProc;
+ int flag;
+} defineCmds[] = {
+ {"constructor", TclOODefineConstructorObjCmd, 0},
+ {"copy", TclOODefineCopyObjCmd, 0},
+ {"destructor", TclOODefineDestructorObjCmd, 0},
+ {"export", TclOODefineExportObjCmd, 0},
+ {"self.export", TclOODefineExportObjCmd, 1},
+ {"filter", TclOODefineFilterObjCmd, 0},
+ {"self.filter", TclOODefineFilterObjCmd, 1},
+ {"forward", TclOODefineForwardObjCmd, 0},
+ {"self.forward", TclOODefineForwardObjCmd, 1},
+ {"method", TclOODefineMethodObjCmd, 0},
+ {"self.method", TclOODefineMethodObjCmd, 1},
+ {"mixin", TclOODefineMixinObjCmd, 0},
+ {"self.mixin", TclOODefineMixinObjCmd, 1},
+#ifdef SUPPORT_OO_PARAMETERS
+ {"parameter", TclOODefineParameterObjCmd, 0},
+#endif
+ {"superclass", TclOODefineSuperclassObjCmd, 0},
+ {"unexport", TclOODefineUnexportObjCmd, 0},
+ {"self.unexport", TclOODefineUnexportObjCmd, 1},
+ {"self.class", TclOODefineSelfClassObjCmd, 1},
+ {NULL, NULL, 0}
+};
+
+/*
+ * What sort of size of things we like to allocate.
+ */
+
+#define ALLOC_CHUNK 8
+
+/*
+ * Function declarations for things defined in this file.
+ */
+
+static Class * AllocClass(Tcl_Interp *interp, Object *useThisObj);
+static Object * AllocObject(Tcl_Interp *interp, const char *nameStr);
+static Method * CloneClassMethod(Tcl_Interp *interp, Class *clsPtr,
+ Method *mPtr, Tcl_Obj *namePtr);
+static Method * CloneObjectMethod(Tcl_Interp *interp, Object *oPtr,
+ Method *mPtr, Tcl_Obj *namePtr);
+static void DeclareClassMethod(Tcl_Interp *interp, Class *clsPtr,
+ const char *name, int isPublic,
+ Tcl_MethodCallProc callProc);
+static void KillFoundation(ClientData clientData,
+ Tcl_Interp *interp);
+static int ObjectCmd(Object *oPtr, Tcl_Interp *interp, int objc,
+ Tcl_Obj *const *objv, int publicOnly,
+ Tcl_HashTable *cachePtr);
+static void ObjectNamespaceDeleted(ClientData clientData);
+static void ObjectDeletedTrace(ClientData clientData,
+ Tcl_Interp *interp, const char *oldName,
+ const char *newName, int flags);
+static void ReleaseClassContents(Tcl_Interp *interp,Object *oPtr);
+
+static int PublicObjectCmd(ClientData clientData,
+ Tcl_Interp *interp, int objc,
+ Tcl_Obj *const *objv);
+static int PrivateObjectCmd(ClientData clientData,
+ Tcl_Interp *interp, int objc,
+ Tcl_Obj *const *objv);
+
+static int SimpleInvoke(ClientData clientData,
+ Tcl_Interp *interp, Tcl_ObjectContext context,
+ int objc, Tcl_Obj *const *objv);
+static int InvokeProcedureMethod(ClientData clientData,
+ Tcl_Interp *interp, Tcl_ObjectContext context,
+ int objc, Tcl_Obj *const *objv);
+static void DeleteProcedureMethod(ClientData clientData);
+static int CloneProcedureMethod(ClientData clientData,
+ ClientData *newClientData);
+static int InvokeForwardMethod(ClientData clientData,
+ Tcl_Interp *interp, Tcl_ObjectContext context,
+ int objc, Tcl_Obj *const *objv);
+static void DeleteForwardMethod(ClientData clientData);
+static int CloneForwardMethod(ClientData clientData,
+ ClientData *newClientData);
+static Tcl_Obj ** InitEnsembleRewrite(Tcl_Interp *interp, int objc,
+ Tcl_Obj *const *objv, int toRewrite,
+ int rewriteLength, Tcl_Obj *const *rewriteObjs,
+ int *lengthPtr);
+
+static int ClassCreate(ClientData clientData, Tcl_Interp *interp,
+ Tcl_ObjectContext context, int objc,
+ Tcl_Obj *const *objv);
+static int ClassNew(ClientData clientData, Tcl_Interp *interp,
+ Tcl_ObjectContext context, int objc,
+ Tcl_Obj *const *objv);
+static int ObjectDestroy(ClientData clientData,
+ Tcl_Interp *interp, Tcl_ObjectContext context,
+ int objc, Tcl_Obj *const *objv);
+static int ObjectEval(ClientData clientData, Tcl_Interp *interp,
+ Tcl_ObjectContext context, int objc,
+ Tcl_Obj *const *objv);
+static int ObjectLinkVar(ClientData clientData,
+ Tcl_Interp *interp, Tcl_ObjectContext context,
+ int objc, Tcl_Obj *const *objv);
+static int ObjectUnknown(ClientData clientData,
+ Tcl_Interp *interp, Tcl_ObjectContext context,
+ int objc, Tcl_Obj *const *objv);
+static int ObjectVarName(ClientData clientData,
+ Tcl_Interp *interp, Tcl_ObjectContext context,
+ int objc, Tcl_Obj *const *objv);
+
+static int NextObjCmd(ClientData clientData, Tcl_Interp *interp,
+ int objc, Tcl_Obj *const *objv);
+static int SelfObjCmd(ClientData clientData, Tcl_Interp *interp,
+ int objc, Tcl_Obj *const *objv);
+
+/*
+ * The types of methods defined by the core OO system.
+ */
+
+static const Tcl_MethodType procMethodType = {
+ TCL_OO_METHOD_VERSION_CURRENT, "procedural method",
+ InvokeProcedureMethod, DeleteProcedureMethod, CloneProcedureMethod
+};
+static const Tcl_MethodType fwdMethodType = {
+ TCL_OO_METHOD_VERSION_CURRENT, "forward",
+ InvokeForwardMethod, DeleteForwardMethod, CloneForwardMethod
+};
+static const Tcl_MethodType coreMethodType = {
+ TCL_OO_METHOD_VERSION_CURRENT, "core method",
+ SimpleInvoke, NULL, NULL
+};
+
+/*
+ * ----------------------------------------------------------------------
+ *
+ * TclOOInit --
+ *
+ * Called to initialise the OO system within an interpreter.
+ *
+ * Result:
+ * TCL_OK if the setup succeeded. Currently assumed to always work.
+ *
+ * Side effects:
+ * Creates namespaces, commands, several classes and a number of
+ * callbacks. Upon return, the OO system is ready for use.
+ *
+ * ----------------------------------------------------------------------
+ */
+
+int
+TclOOInit(
+ Tcl_Interp *interp) /* The interpreter to install into. */
+{
+ Interp *iPtr = (Interp *) interp;
+ Foundation *fPtr;
+ int i;
+ Tcl_DString buffer;
+
+ /*
+ * Construct the foundation of the object system. This is a structure
+ * holding references to the magical bits that need to be known about in
+ * other places.
+ */
+
+ fPtr = iPtr->ooFoundation = (Foundation *) ckalloc(sizeof(Foundation));
+ memset(fPtr, 0, sizeof(Foundation));
+ fPtr->ooNs = Tcl_CreateNamespace(interp, "::oo", fPtr, NULL);
+ Tcl_Export(interp, fPtr->ooNs, "[a-z]*", 1);
+ fPtr->defineNs = Tcl_CreateNamespace(interp, "::oo::define", NULL, NULL);
+ fPtr->helpersNs = Tcl_CreateNamespace(interp, "::oo::Helpers", NULL,
+ NULL);
+ Tcl_CreateObjCommand(interp, "::oo::Helpers::next", NextObjCmd, NULL,
+ NULL);
+ Tcl_CreateObjCommand(interp, "::oo::Helpers::self", SelfObjCmd, NULL,
+ NULL);
+ Tcl_CreateObjCommand(interp, "::oo::define", TclOODefineObjCmd, NULL,
+ NULL);
+ Tcl_DStringInit(&buffer);
+ for (i=0 ; defineCmds[i].name ; i++) {
+ Tcl_DStringAppend(&buffer, "::oo::define::", 14);
+ Tcl_DStringAppend(&buffer, defineCmds[i].name, -1);
+ Tcl_CreateObjCommand(interp, Tcl_DStringValue(&buffer),
+ defineCmds[i].objProc, (void *) defineCmds[i].flag, NULL);
+ Tcl_DStringFree(&buffer);
+ }
+ fPtr->epoch = 0;
+ fPtr->nsCount = 0;
+ fPtr->unknownMethodNameObj = Tcl_NewStringObj("unknown", -1);
+ Tcl_IncrRefCount(fPtr->unknownMethodNameObj);
+
+ Tcl_CallWhenDeleted(interp, KillFoundation, fPtr);
+
+ /*
+ * Create the objects at the core of the object system. These need to be
+ * spliced manually.
+ */
+
+ fPtr->objectCls = AllocClass(interp, AllocObject(interp, "::oo::object"));
+ fPtr->classCls = AllocClass(interp, AllocObject(interp, "::oo::class"));
+ fPtr->objectCls->thisPtr->selfCls = fPtr->classCls;
+ fPtr->objectCls->thisPtr->flags |= ROOT_OBJECT;
+ fPtr->objectCls->superclasses.num = 0;
+ ckfree((char *) fPtr->objectCls->superclasses.list);
+ fPtr->objectCls->superclasses.list = NULL;
+ fPtr->classCls->thisPtr->selfCls = fPtr->classCls;
+ TclOOAddToInstances(fPtr->objectCls->thisPtr, fPtr->classCls);
+ TclOOAddToInstances(fPtr->classCls->thisPtr, fPtr->classCls);
+
+ /*
+ * Basic method declarations for the core classes.
+ */
+
+ DeclareClassMethod(interp, fPtr->objectCls, "destroy", 1, ObjectDestroy);
+ DeclareClassMethod(interp, fPtr->objectCls, "eval", 0, ObjectEval);
+ DeclareClassMethod(interp, fPtr->objectCls, "unknown", 0, ObjectUnknown);
+ DeclareClassMethod(interp, fPtr->objectCls, "variable", 0, ObjectLinkVar);
+ DeclareClassMethod(interp, fPtr->objectCls, "varname", 0, ObjectVarName);
+ DeclareClassMethod(interp, fPtr->classCls, "create", 1, ClassCreate);
+ DeclareClassMethod(interp, fPtr->classCls, "new", 1, ClassNew);
+
+ /*
+ * Finish setting up the class of classes.
+ */
+
+ {
+ Tcl_Obj *namePtr, *argsPtr, *bodyPtr;
+
+ /*
+ * Mark the 'new' method in oo::class as private; classes, unlike
+ * general objects, must have explicit names.
+ */
+
+ namePtr = Tcl_NewStringObj("new", -1);
+ Tcl_NewMethod(interp, (Tcl_Object) fPtr->classCls->thisPtr, namePtr,
+ 0 /* ==private */, NULL, NULL);
+
+ argsPtr = Tcl_NewStringObj("{definitionScript {}}", -1);
+ bodyPtr = Tcl_NewStringObj(
+ "if {[catch {define [self] $definitionScript} msg opt]} {\n"
+ "set ei [split [dict get $opt -errorinfo] \\n]\n"
+ "dict set opt -errorinfo [join [lrange $ei 0 end-2] \\n]\n"
+ "dict set opt -errorline 0xdeadbeef\n"
+ "}\n"
+ "return -options $opt $msg", -1);
+ fPtr->classCls->constructorPtr = TclOONewProcClassMethod(interp,
+ fPtr->classCls, 0, NULL, argsPtr, bodyPtr);
+ }
+
+ return TCL_OK;
+}
+
+/*
+ * ----------------------------------------------------------------------
+ *
+ * KillFoundation --
+ *
+ * Delete those parts of the OO core that are not deleted automatically
+ * when the objects and classes themselves are destroyed.
+ *
+ * ----------------------------------------------------------------------
+ */
+
+static void
+KillFoundation(
+ ClientData clientData, /* Pointer to the OO system foundation
+ * structure. */
+ Tcl_Interp *interp) /* The interpreter containing the OO system
+ * foundation. */
+{
+ Foundation *fPtr = clientData;
+
+ TclDecrRefCount(fPtr->unknownMethodNameObj);
+ ckfree((char *) fPtr);
+}
+
+/*
+ * ----------------------------------------------------------------------
+ *
+ * AllocObject --
+ *
+ * Allocate an object of basic type. Does not splice the object into its
+ * class's instance list.
+ *
+ * ----------------------------------------------------------------------
+ */
+
+static Object *
+AllocObject(
+ Tcl_Interp *interp, /* Interpreter within which to create the
+ * object. */
+ const char *nameStr) /* The name of the object to create, or NULL
+ * if the OO system should pick the object
+ * name itself. */
+{
+ Foundation *fPtr = ((Interp *) interp)->ooFoundation;
+ Tcl_Obj *cmdnameObj;
+ Tcl_DString buffer;
+ Object *oPtr;
+
+ oPtr = (Object *) ckalloc(sizeof(Object));
+ memset(oPtr, 0, sizeof(Object));
+ while (1) {
+ char objName[10 + TCL_INTEGER_SPACE];
+
+ sprintf(objName, "::oo::Obj%d", ++fPtr->nsCount);
+ oPtr->namespacePtr = Tcl_CreateNamespace(interp, objName, oPtr,
+ ObjectNamespaceDeleted);
+ if (oPtr->namespacePtr != NULL) {
+ break;
+ }
+
+ /*
+ * Could not make that namespace, so we make another. But first we
+ * have to get rid of the error message from Tcl_CreateNamespace,
+ * since that's something that should not be exposed to the user.
+ */
+
+ Tcl_ResetResult(interp);
+ }
+ TclSetNsPath((Namespace *) oPtr->namespacePtr, 1, &fPtr->helpersNs);
+ oPtr->selfCls = fPtr->objectCls;
+ Tcl_InitObjHashTable(&oPtr->methods);
+ Tcl_InitObjHashTable(&oPtr->publicContextCache);
+ Tcl_InitObjHashTable(&oPtr->privateContextCache);
+ oPtr->filters.num = 0;
+ oPtr->filters.list = NULL;
+ oPtr->mixins.num = 0;
+ oPtr->mixins.list = NULL;
+ oPtr->classPtr = NULL;
+ oPtr->flags = 0;
+ oPtr->metadataPtr = NULL;
+
+ /*
+ * Initialize the traces.
+ */
+
+ Tcl_DStringInit(&buffer);
+ if (nameStr) {
+ if (nameStr[0] != ':' || nameStr[1] != ':') {
+ Tcl_DStringAppend(&buffer,
+ Tcl_GetCurrentNamespace(interp)->fullName, -1);
+ Tcl_DStringAppend(&buffer, "::", 2);
+ }
+ Tcl_DStringAppend(&buffer, nameStr, -1);
+ } else {
+ Tcl_DStringAppend(&buffer, oPtr->namespacePtr->fullName, -1);
+ }
+ oPtr->command = Tcl_CreateObjCommand(interp, Tcl_DStringValue(&buffer),
+ PublicObjectCmd, oPtr, NULL);
+ if (nameStr) {
+ Tcl_DStringFree(&buffer);
+ Tcl_DStringAppend(&buffer, oPtr->namespacePtr->fullName, -1);
+ }
+ Tcl_DStringAppend(&buffer, "::my", 4);
+ oPtr->myCommand = Tcl_CreateObjCommand(interp, Tcl_DStringValue(&buffer),
+ PrivateObjectCmd, oPtr, NULL);
+ Tcl_DStringFree(&buffer);
+
+ TclNewObj(cmdnameObj);
+ Tcl_GetCommandFullName(interp, oPtr->command, cmdnameObj);
+ Tcl_TraceCommand(interp, TclGetString(cmdnameObj),
+ TCL_TRACE_DELETE, ObjectDeletedTrace, oPtr);
+ TclDecrRefCount(cmdnameObj);
+
+ return oPtr;
+}
+
+/*
+ * ----------------------------------------------------------------------
+ *
+ * ObjectDeletedTrace --
+ *
+ * This callback is triggered when the object is deleted by any
+ * mechanism. It runs the destructors and arranges for the actual cleanup
+ * of the object's namespace, which in turn triggers cleansing of the
+ * object data structures.
+ *
+ * ----------------------------------------------------------------------
+ */
+
+static void
+ObjectDeletedTrace(
+ ClientData clientData, /* The object being deleted. */
+ Tcl_Interp *interp, /* The interpreter containing the object. */
+ const char *oldName, /* What the object was (last) called. */
+ const char *newName, /* Always NULL. */
+ int flags) /* Why was the object deleted? */
+{
+ Interp *iPtr = (Interp *) interp;
+ Object *oPtr = clientData;
+ Class *clsPtr;
+
+ Tcl_Preserve(oPtr);
+ oPtr->flags |= OBJECT_DELETED;
+ if (!Tcl_InterpDeleted(interp)) {
+ CallContext *contextPtr = TclOOGetCallContext(iPtr->ooFoundation,
+ oPtr, NULL, DESTRUCTOR, NULL);
+
+ if (contextPtr != NULL) {
+ int result;
+ Tcl_InterpState state;
+
+ contextPtr->flags |= DESTRUCTOR;
+ contextPtr->skip = 0;
+ state = Tcl_SaveInterpState(interp, TCL_OK);
+ result = TclOOInvokeContext(interp, contextPtr, 0, NULL);
+ if (result != TCL_OK) {
+ Tcl_BackgroundError(interp);
+ }
+ (void) Tcl_RestoreInterpState(interp, state);
+ TclOODeleteContext(contextPtr);
+ }
+ }
+
+ clsPtr = oPtr->classPtr;
+ if (clsPtr != NULL) {
+ ReleaseClassContents(interp, oPtr);
+ }
+
+ Tcl_DeleteNamespace(oPtr->namespacePtr);
+ if (clsPtr) {
+ Tcl_Release(clsPtr);
+ }
+ Tcl_Release(oPtr);
+
+ /*
+ * What else to do to delete an object?
+ */
+}
+
+/*
+ * ----------------------------------------------------------------------
+ *
+ * ReleaseClassContents --
+ *
+ * Tear down the special class data structure, including deleting all
+ * dependent classes and objects.
+ *
+ * ----------------------------------------------------------------------
+ */
+
+static void
+ReleaseClassContents(
+ Tcl_Interp *interp, /* The interpreter containing the class. */
+ Object *oPtr) /* The object representing the class. */
+{
+ int i, n;
+ Class *clsPtr, **list;
+ Object **insts;
+
+ clsPtr = oPtr->classPtr;
+ Tcl_Preserve(clsPtr);
+
+ /*
+ * Must empty list before processing the members of the list so that
+ * things happen in the correct order even if something tries to play
+ * fast-and-loose.
+ */
+
+ list = clsPtr->mixinSubs.list;
+ n = clsPtr->mixinSubs.num;
+ clsPtr->mixinSubs.list = NULL;
+ clsPtr->mixinSubs.num = 0;
+ clsPtr->mixinSubs.size = 0;
+ for (i=0 ; i<n ; i++) {
+ Tcl_Preserve(list[i]);
+ }
+ for (i=0 ; i<n ; i++) {
+ if (!(list[i]->flags & OBJECT_DELETED) && interp != NULL) {
+ Tcl_DeleteCommandFromToken(interp, list[i]->thisPtr->command);
+ }
+ Tcl_Release(list[i]);
+ }
+ if (list != NULL) {
+ ckfree((char *) list);
+ }
+
+ list = clsPtr->subclasses.list;
+ n = clsPtr->subclasses.num;
+ clsPtr->subclasses.list = NULL;
+ clsPtr->subclasses.num = 0;
+ clsPtr->subclasses.size = 0;
+ for (i=0 ; i<n ; i++) {
+ Tcl_Preserve(list[i]);
+ }
+ for (i=0 ; i<n ; i++) {
+ if (!(list[i]->flags & OBJECT_DELETED) && interp != NULL) {
+ Tcl_DeleteCommandFromToken(interp, list[i]->thisPtr->command);
+ }
+ Tcl_Release(list[i]);
+ }
+ if (list != NULL) {
+ ckfree((char *) list);
+ }
+
+ insts = clsPtr->instances.list;
+ n = clsPtr->instances.num;
+ clsPtr->instances.list = NULL;
+ clsPtr->instances.num = 0;
+ clsPtr->instances.size = 0;
+ for (i=0 ; i<n ; i++) {
+ Tcl_Preserve(insts[i]);
+ }
+ for (i=0 ; i<n ; i++) {
+ if (!(insts[i]->flags & OBJECT_DELETED) && interp != NULL) {
+ Tcl_DeleteCommandFromToken(interp, insts[i]->command);
+ }
+ Tcl_Release(insts[i]);
+ }
+ if (insts != NULL) {
+ ckfree((char *) insts);
+ }
+
+ if (clsPtr->filters.num) {
+ Tcl_Obj *filterObj;
+
+ FOREACH(filterObj, clsPtr->filters) {
+ TclDecrRefCount(filterObj);
+ }
+ ckfree((char *) clsPtr->filters.list);
+ clsPtr->filters.num = 0;
+ }
+
+ if (clsPtr->metadataPtr != NULL) {
+ FOREACH_HASH_DECLS;
+ Tcl_ObjectMetadataType *metadataTypePtr;
+ ClientData value;
+
+ FOREACH_HASH(metadataTypePtr, value, clsPtr->metadataPtr) {
+ metadataTypePtr->deleteProc(value);
+ }
+ Tcl_DeleteHashTable(clsPtr->metadataPtr);
+ ckfree((char *) clsPtr->metadataPtr);
+ clsPtr->metadataPtr = NULL;
+ }
+}
+
+/*
+ * ----------------------------------------------------------------------
+ *
+ * ObjectNamespaceDeleted --
+ *
+ * Callback when the object's namespace is deleted. Used to clean up the
+ * data structures associated with the object. The complicated bit is
+ * that this can sometimes happen before the object's command is deleted
+ * (interpreter teardown is complex!)
+ *
+ * ----------------------------------------------------------------------
+ */
+
+static void
+ObjectNamespaceDeleted(
+ ClientData clientData) /* Pointer to the class whose namespace is
+ * being deleted. */
+{
+ Object *oPtr = clientData;
+ FOREACH_HASH_DECLS;
+ Class *clsPtr, *mixinPtr;
+ CallContext *contextPtr;
+ Method *mPtr;
+ Tcl_Obj *filterObj;
+ int i;
+
+ /*
+ * Instruct everyone to no longer use any allocated fields of the object.
+ */
+
+ if (!(oPtr->flags & OBJECT_DELETED)) {
+ Tcl_Preserve(oPtr);
+ if (oPtr->classPtr != NULL) {
+ ReleaseClassContents(NULL, oPtr);
+ }
+ }
+ oPtr->flags |= OBJECT_DELETED;
+
+ /*
+ * Splice the object out of its context. After this, we must *not* call
+ * methods on the object.
+ */
+
+ if (!(oPtr->flags & ROOT_OBJECT)) {
+ TclOORemoveFromInstances(oPtr, oPtr->selfCls);
+ }
+ FOREACH(mixinPtr, oPtr->mixins) {
+ TclOORemoveFromInstances(oPtr, mixinPtr);
+ }
+ if (i) {
+ ckfree((char *)oPtr->mixins.list);
+ }
+ FOREACH(filterObj, oPtr->filters) {
+ TclDecrRefCount(filterObj);
+ }
+ if (i) {
+ ckfree((char *)oPtr->filters.list);
+ }
+ FOREACH_HASH_VALUE(mPtr, &oPtr->methods) {
+ TclOODeleteMethod(mPtr);
+ }
+ Tcl_DeleteHashTable(&oPtr->methods);
+ FOREACH_HASH_VALUE(contextPtr, &oPtr->publicContextCache) {
+ if (contextPtr) {
+ TclOODeleteContext(contextPtr);
+ }
+ }
+ Tcl_DeleteHashTable(&oPtr->publicContextCache);
+ FOREACH_HASH_VALUE(contextPtr, &oPtr->privateContextCache) {
+ if (contextPtr) {
+ TclOODeleteContext(contextPtr);
+ }
+ }
+ Tcl_DeleteHashTable(&oPtr->privateContextCache);
+
+ if (oPtr->metadataPtr != NULL) {
+ FOREACH_HASH_DECLS;
+ Tcl_ObjectMetadataType *metadataTypePtr;
+ ClientData value;
+
+ FOREACH_HASH(metadataTypePtr, value, oPtr->metadataPtr) {
+ metadataTypePtr->deleteProc(value);
+ }
+ Tcl_DeleteHashTable(oPtr->metadataPtr);
+ ckfree((char *) oPtr->metadataPtr);
+ oPtr->metadataPtr = NULL;
+ }
+
+ clsPtr = oPtr->classPtr;
+ if (clsPtr != NULL && !(oPtr->flags & ROOT_OBJECT)) {
+ Class *superPtr, *mixinPtr;
+
+ clsPtr->flags |= OBJECT_DELETED;
+ FOREACH(mixinPtr, clsPtr->mixins) {
+ if (!(mixinPtr->flags & OBJECT_DELETED)) {
+ TclOORemoveFromSubclasses(clsPtr, mixinPtr);
+ }
+ }
+ if (i) {
+ ckfree((char *) clsPtr->mixins.list);
+ clsPtr->mixins.num = 0;
+ }
+ FOREACH(superPtr, clsPtr->superclasses) {
+ if (!(superPtr->flags & OBJECT_DELETED)) {
+ TclOORemoveFromSubclasses(clsPtr, superPtr);
+ }
+ }
+ if (i) {
+ ckfree((char *) clsPtr->superclasses.list);
+ clsPtr->superclasses.num = 0;
+ }
+ if (clsPtr->subclasses.list) {
+ ckfree((char *) clsPtr->subclasses.list);
+ clsPtr->subclasses.num = 0;
+ }
+ if (clsPtr->instances.list) {
+ ckfree((char *) clsPtr->instances.list);
+ clsPtr->instances.num = 0;
+ }
+ if (clsPtr->mixinSubs.list) {
+ ckfree((char *) clsPtr->mixinSubs.list);
+ clsPtr->mixinSubs.num = 0;
+ }
+ if (clsPtr->classHierarchy.list) {
+ ckfree((char *) clsPtr->classHierarchy.list);
+ clsPtr->classHierarchy.num = 0;
+ }
+
+ FOREACH_HASH_VALUE(mPtr, &clsPtr->classMethods) {
+ TclOODeleteMethod(mPtr);
+ }
+ Tcl_DeleteHashTable(&clsPtr->classMethods);
+ TclOODeleteMethod(clsPtr->constructorPtr);
+ TclOODeleteMethod(clsPtr->destructorPtr);
+ Tcl_EventuallyFree(clsPtr, TCL_DYNAMIC);
+ }
+
+ /*
+ * Delete the object structure itself.
+ */
+
+ if (!(oPtr->flags & OBJECT_DELETED)) {
+ Tcl_EventuallyFree(oPtr, TCL_DYNAMIC);
+ Tcl_Release(oPtr);
+ } else {
+ Tcl_EventuallyFree(oPtr, TCL_DYNAMIC);
+ }
+}
+
+/*
+ * ----------------------------------------------------------------------
+ *
+ * TclOORemoveFromInstances --
+ *
+ * Utility function to remove an object from the list of instances within
+ * a class.
+ *
+ * ----------------------------------------------------------------------
+ */
+
+void
+TclOORemoveFromInstances(
+ Object *oPtr, /* The instance to remove. */
+ Class *clsPtr) /* The class (possibly) containing the
+ * reference to the instance. */
+{
+ int i;
+ Object *instPtr;
+
+ FOREACH(instPtr, clsPtr->instances) {
+ if (oPtr == instPtr) {
+ goto removeInstance;
+ }
+ }
+ return;
+
+ removeInstance:
+ clsPtr->instances.num--;
+ if (i < clsPtr->instances.num) {
+ clsPtr->instances.list[i] =
+ clsPtr->instances.list[clsPtr->instances.num];
+ }
+ clsPtr->instances.list[clsPtr->instances.num] = NULL;
+}
+
+/*
+ * ----------------------------------------------------------------------
+ *
+ * TclOOAddToInstances --
+ *
+ * Utility function to add an object to the list of instances within a
+ * class.
+ *
+ * ----------------------------------------------------------------------
+ */
+
+void
+TclOOAddToInstances(
+ Object *oPtr, /* The instance to add. */
+ Class *clsPtr) /* The class to add the instance to. It is
+ * assumed that the class is not already
+ * present as an instance in the class. */
+{
+ if (clsPtr->instances.num >= clsPtr->instances.size) {
+ clsPtr->instances.size += ALLOC_CHUNK;
+ if (clsPtr->instances.size == ALLOC_CHUNK) {
+ clsPtr->instances.list = (Object **)
+ ckalloc(sizeof(Object *) * ALLOC_CHUNK);
+ } else {
+ clsPtr->instances.list = (Object **)
+ ckrealloc((char *) clsPtr->instances.list,
+ sizeof(Object *) * clsPtr->instances.size);
+ }
+ }
+ clsPtr->instances.list[clsPtr->instances.num++] = oPtr;
+}
+
+/*
+ * ----------------------------------------------------------------------
+ *
+ * TclOORemoveFromSubclasses --
+ *
+ * Utility function to remove a class from the list of subclasses within
+ * another class.
+ *
+ * ----------------------------------------------------------------------
+ */
+
+void
+TclOORemoveFromSubclasses(
+ Class *subPtr, /* The subclass to remove. */
+ Class *superPtr) /* The superclass to (possibly) remove the
+ * subclass reference from. */
+{
+ int i;
+ Class *subclsPtr;
+
+ FOREACH(subclsPtr, superPtr->subclasses) {
+ if (subPtr == subclsPtr) {
+ goto removeSubclass;
+ }
+ }
+ return;
+
+ removeSubclass:
+ superPtr->subclasses.num--;
+ if (i < superPtr->subclasses.num) {
+ superPtr->subclasses.list[i] =
+ superPtr->subclasses.list[superPtr->subclasses.num];
+ }
+ superPtr->subclasses.list[superPtr->subclasses.num] = NULL;
+}
+
+/*
+ * ----------------------------------------------------------------------
+ *
+ * TclOOAddToSubclasses --
+ *
+ * Utility function to add a class to the list of subclasses within
+ * another class.
+ *
+ * ----------------------------------------------------------------------
+ */
+
+void
+TclOOAddToSubclasses(
+ Class *subPtr, /* The subclass to add. */
+ Class *superPtr) /* The superclass to add the subclass to. It
+ * is assumed that the class is not already
+ * present as a subclass in the superclass. */
+{
+ if (superPtr->subclasses.num >= superPtr->subclasses.size) {
+ superPtr->subclasses.size += ALLOC_CHUNK;
+ if (superPtr->subclasses.size == ALLOC_CHUNK) {
+ superPtr->subclasses.list = (Class **)
+ ckalloc(sizeof(Class *) * ALLOC_CHUNK);
+ } else {
+ superPtr->subclasses.list = (Class **)
+ ckrealloc((char *) superPtr->subclasses.list,
+ sizeof(Class *) * superPtr->subclasses.size);
+ }
+ }
+ superPtr->subclasses.list[superPtr->subclasses.num++] = subPtr;
+}
+
+/*
+ * ----------------------------------------------------------------------
+ *
+ * TclOORemoveFromMixinSubs --
+ *
+ * Utility function to remove a class from the list of mixinSubs within
+ * another class.
+ *
+ * ----------------------------------------------------------------------
+ */
+
+void
+TclOORemoveFromMixinSubs(
+ Class *subPtr, /* The subclass to remove. */
+ Class *superPtr) /* The superclass to (possibly) remove the
+ * subclass reference from. */
+{
+ int i;
+ Class *subclsPtr;
+
+ FOREACH(subclsPtr, superPtr->mixinSubs) {
+ if (subPtr == subclsPtr) {
+ goto removeSubclass;
+ }
+ }
+ return;
+
+ removeSubclass:
+ superPtr->mixinSubs.num--;
+ if (i < superPtr->mixinSubs.num) {
+ superPtr->mixinSubs.list[i] =
+ superPtr->mixinSubs.list[superPtr->mixinSubs.num];
+ }
+ superPtr->mixinSubs.list[superPtr->mixinSubs.num] = NULL;
+}
+
+/*
+ * ----------------------------------------------------------------------
+ *
+ * TclOOAddToMixinSubs --
+ *
+ * Utility function to add a class to the list of mixinSubs within
+ * another class.
+ *
+ * ----------------------------------------------------------------------
+ */
+
+void
+TclOOAddToMixinSubs(
+ Class *subPtr, /* The subclass to add. */
+ Class *superPtr) /* The superclass to add the subclass to. It
+ * is assumed that the class is not already
+ * present as a subclass in the superclass. */
+{
+ if (superPtr->mixinSubs.num >= superPtr->mixinSubs.size) {
+ superPtr->mixinSubs.size += ALLOC_CHUNK;
+ if (superPtr->mixinSubs.size == ALLOC_CHUNK) {
+ superPtr->mixinSubs.list = (Class **)
+ ckalloc(sizeof(Class *) * ALLOC_CHUNK);
+ } else {
+ superPtr->mixinSubs.list = (Class **)
+ ckrealloc((char *) superPtr->mixinSubs.list,
+ sizeof(Class *) * superPtr->mixinSubs.size);
+ }
+ }
+ superPtr->mixinSubs.list[superPtr->mixinSubs.num++] = subPtr;
+}
+
+/*
+ * ----------------------------------------------------------------------
+ *
+ * AllocClass --
+ *
+ * Allocate a basic class. Does not splice the class object into its
+ * class's instance list.
+ *
+ * ----------------------------------------------------------------------
+ */
+
+static Class *
+AllocClass(
+ Tcl_Interp *interp, /* Interpreter within which to allocate the
+ * class. */
+ Object *useThisObj) /* Object that is to act as the class
+ * representation, or NULL if a new object
+ * (with automatic name) is to be used. */
+{
+ Class *clsPtr;
+ Foundation *fPtr = ((Interp *) interp)->ooFoundation;
+
+ clsPtr = (Class *) ckalloc(sizeof(Class));
+ memset(clsPtr, 0, sizeof(Class));
+ if (useThisObj == NULL) {
+ clsPtr->thisPtr = AllocObject(interp, NULL);
+ } else {
+ clsPtr->thisPtr = useThisObj;
+ }
+ clsPtr->thisPtr->selfCls = fPtr->classCls;
+ if (fPtr->classCls != NULL) {
+ TclOOAddToInstances(clsPtr->thisPtr, fPtr->classCls);
+ TclOOAddToSubclasses(clsPtr, fPtr->objectCls);
+ }
+ {
+ Tcl_Namespace *path[2];
+
+ path[0] = fPtr->helpersNs;
+ path[1] = fPtr->ooNs;
+ TclSetNsPath((Namespace *) clsPtr->thisPtr->namespacePtr, 2, path);
+ }
+ clsPtr->thisPtr->classPtr = clsPtr;
+ clsPtr->flags = 0;
+ clsPtr->superclasses.num = 1;
+ clsPtr->superclasses.list = (Class **) ckalloc(sizeof(Class *));
+ clsPtr->superclasses.list[0] = fPtr->objectCls;
+ clsPtr->subclasses.num = 0;
+ clsPtr->subclasses.list = NULL;
+ clsPtr->subclasses.size = 0;
+ clsPtr->instances.num = 0;
+ clsPtr->instances.list = NULL;
+ clsPtr->instances.size = 0;
+ clsPtr->filters.list = NULL;
+ clsPtr->filters.num = 0;
+ clsPtr->mixins.list = NULL;
+ clsPtr->mixins.num = 0;
+ clsPtr->mixinSubs.list = NULL;
+ clsPtr->mixinSubs.num = 0;
+ clsPtr->mixinSubs.size = 0;
+ clsPtr->classHierarchy.list = NULL;
+ clsPtr->classHierarchy.num = 0;
+ clsPtr->classHierarchyEpoch = fPtr->epoch-1;
+ Tcl_InitObjHashTable(&clsPtr->classMethods);
+ clsPtr->constructorPtr = NULL;
+ clsPtr->destructorPtr = NULL;
+ clsPtr->metadataPtr = NULL;
+ return clsPtr;
+}
+
+/*
+ * ----------------------------------------------------------------------
+ *
+ * Tcl_NewObjectInstance --
+ *
+ * Allocate a new instance of an object.
+ *
+ * ----------------------------------------------------------------------
+ */
+
+Tcl_Object
+Tcl_NewObjectInstance(
+ Tcl_Interp *interp, /* Interpreter context. */
+ Tcl_Class cls, /* Class to create an instance of. */
+ const char *name, /* Name of object to create, or NULL to ask
+ * the code to pick its own unique name. */
+ int objc, /* Number of arguments. Negative value means
+ * do not call constructor. */
+ Tcl_Obj *const *objv, /* Argument list. */
+ int skip) /* Number of arguments to _not_ pass to the
+ * constructor. */
+{
+ Object *oPtr = AllocObject(interp, NULL);
+ CallContext *contextPtr;
+
+ oPtr->selfCls = (Class *) cls;
+ TclOOAddToInstances(oPtr, (Class *) cls);
+
+ if (name != NULL) {
+ Tcl_Obj *cmdnameObj;
+
+ TclNewObj(cmdnameObj);
+ Tcl_GetCommandFullName(interp, oPtr->command, cmdnameObj);
+ if (TclRenameCommand(interp, TclGetString(cmdnameObj),
+ name) != TCL_OK) {
+ Tcl_ResetResult(interp);
+ Tcl_AppendResult(interp, "can't create object \"", name,
+ "\": command already exists with that name", NULL);
+ TclDecrRefCount(cmdnameObj);
+ Tcl_DeleteCommandFromToken(interp, oPtr->command);
+ return NULL;
+ }
+ TclDecrRefCount(cmdnameObj);
+ }
+
+ /*
+ * Check to see if we're really creating a class. If so, allocate the
+ * class structure as well.
+ */
+
+ if (TclOOIsReachable((((Interp *) interp)->ooFoundation)->classCls,
+ (Class *) cls)) {
+ /*
+ * Is a class, so attach a class structure. Note that the AllocClass
+ * function splices the structure into the object, so we don't have
+ * to.
+ */
+
+ AllocClass(interp, oPtr);
+ oPtr->selfCls = (Class *) cls; // Repatch
+ }
+
+ if (objc >= 0) {
+ contextPtr = TclOOGetCallContext(((Interp *)interp)->ooFoundation,
+ oPtr, NULL, CONSTRUCTOR, NULL);
+ if (contextPtr != NULL) {
+ int result;
+ Tcl_InterpState state;
+
+ Tcl_Preserve(oPtr);
+ state = Tcl_SaveInterpState(interp, TCL_OK);
+ contextPtr->flags |= CONSTRUCTOR;
+ contextPtr->skip = skip;
+ result = TclOOInvokeContext(interp, contextPtr, objc, objv);
+ TclOODeleteContext(contextPtr);
+ Tcl_Release(oPtr);
+ if (result != TCL_OK) {
+ Tcl_DiscardInterpState(state);
+ Tcl_DeleteCommandFromToken(interp, oPtr->command);
+ return NULL;
+ }
+ (void) Tcl_RestoreInterpState(interp, state);
+ }
+ }
+
+ return (Tcl_Object) oPtr;
+}
+
+/*
+ * ----------------------------------------------------------------------
+ *
+ * Tcl_CopyObjectInstance --
+ *
+ * Creates a copy of an object. Does not copy the backing namespace,
+ * since the correct way to do that (e.g., shallow/deep) depends on the
+ * object/class's own policies.
+ *
+ * ----------------------------------------------------------------------
+ */
+
+Tcl_Object
+Tcl_CopyObjectInstance(
+ Tcl_Interp *interp,
+ Tcl_Object sourceObject,
+ const char *targetName)
+{
+ Object *oPtr = (Object *) sourceObject, *o2Ptr;
+ Interp *iPtr = (Interp *) interp;
+ FOREACH_HASH_DECLS;
+ Method *mPtr;
+ Class *mixinPtr;
+ Tcl_Obj *keyPtr, *filterObj;
+ int i;
+
+ /*
+ * Sanity checks.
+ */
+
+ if (targetName == NULL && oPtr->classPtr != NULL) {
+ Tcl_AppendResult(interp, "must supply a name when copying a class",
+ NULL);
+ return NULL;
+ }
+ if (oPtr->classPtr == iPtr->ooFoundation->classCls) {
+ Tcl_AppendResult(interp, "may not clone the class of classes", NULL);
+ return NULL;
+ }
+
+ /*
+ * Build the instance. Note that this does not run any constructors.
+ */
+
+ o2Ptr = (Object *) Tcl_NewObjectInstance(interp,
+ (Tcl_Class) oPtr->selfCls, targetName, -1, NULL, -1);
+ if (o2Ptr == NULL) {
+ return NULL;
+ }
+
+ /*
+ * Copy the object-local methods to the new object.
+ */
+
+ FOREACH_HASH(keyPtr, mPtr, &oPtr->methods) {
+ (void) CloneObjectMethod(interp, o2Ptr, mPtr, keyPtr);
+ }
+
+ /*
+ * Copy the object's mixin references to the new object.
+ */
+
+ FOREACH(mixinPtr, o2Ptr->mixins) {
+ if (mixinPtr != o2Ptr->selfCls) {
+ TclOORemoveFromInstances(o2Ptr, mixinPtr);
+ }
+ }
+ DUPLICATE(o2Ptr->mixins, oPtr->mixins, Class *);
+ FOREACH(mixinPtr, o2Ptr->mixins) {
+ if (mixinPtr != o2Ptr->selfCls) {
+ TclOOAddToInstances(o2Ptr, mixinPtr);
+ }
+ }
+
+ /*
+ * Copy the object's filter list to the new object.
+ */
+
+ DUPLICATE(o2Ptr->filters, oPtr->filters, Tcl_Obj *);
+ FOREACH(filterObj, o2Ptr->filters) {
+ Tcl_IncrRefCount(filterObj);
+ }
+
+ /*
+ * Copy the object's flags to the new object, clearing those that must be
+ * kept object-local. The duplicate is never deleted at this point, nor is
+ * it the root of the object system or in the midst of processing a filter
+ * call.
+ */
+
+ o2Ptr->flags = oPtr->flags & ~(
+ OBJECT_DELETED | ROOT_OBJECT | FILTER_HANDLING);
+
+ /*
+ * Copy the object's metadata.
+ */
+
+ if (oPtr->metadataPtr != NULL) {
+ Tcl_ObjectMetadataType *metadataTypePtr;
+ ClientData value, duplicate;
+
+ FOREACH_HASH(metadataTypePtr, value, oPtr->metadataPtr) {
+ if (metadataTypePtr->cloneProc == NULL) {
+ continue;
+ }
+ duplicate = metadataTypePtr->cloneProc(value);
+ if (duplicate != NULL) {
+ Tcl_ObjectSetMetadata((Tcl_Object) o2Ptr, metadataTypePtr,
+ duplicate);
+ }
+ }
+ }
+
+ /*
+ * Copy the class, if present. Note that if there is a class present in
+ * the source object, there must also be one in the copy.
+ */
+
+ if (oPtr->classPtr != NULL) {
+ Class *clsPtr = oPtr->classPtr;
+ Class *cls2Ptr = o2Ptr->classPtr;
+ Class *superPtr;
+
+ /*
+ * Copy the class flags across.
+ */
+
+ cls2Ptr->flags = clsPtr->flags;
+
+ /*
+ * Ensure that the new class's superclass structure is the same as the
+ * old class's.
+ */
+
+ FOREACH(superPtr, cls2Ptr->superclasses) {
+ TclOORemoveFromSubclasses(cls2Ptr, superPtr);
+ }
+ if (cls2Ptr->superclasses.num) {
+ cls2Ptr->superclasses.list = (Class **)
+ ckrealloc((char *) cls2Ptr->superclasses.list,
+ sizeof(Class *) * clsPtr->superclasses.num);
+ } else {
+ cls2Ptr->superclasses.list = (Class **)
+ ckalloc(sizeof(Class *) * clsPtr->superclasses.num);
+ }
+ memcpy(cls2Ptr->superclasses.list, clsPtr->superclasses.list,
+ sizeof(Class *) * clsPtr->superclasses.num);
+ cls2Ptr->superclasses.num = clsPtr->superclasses.num;
+ FOREACH(superPtr, cls2Ptr->superclasses) {
+ TclOOAddToSubclasses(cls2Ptr, superPtr);
+ }
+
+ /*
+ * Duplicate the source class's filters.
+ */
+
+ DUPLICATE(cls2Ptr->filters, clsPtr->filters, Tcl_Obj *);
+ FOREACH(filterObj, cls2Ptr->filters) {
+ Tcl_IncrRefCount(filterObj);
+ }
+
+ /*
+ * Duplicate the source class's mixins (which cannot be circular
+ * references to the duplicate).
+ */
+
+ FOREACH(mixinPtr, cls2Ptr->mixins) {
+ TclOORemoveFromMixinSubs(cls2Ptr, mixinPtr);
+ }
+ if (cls2Ptr->mixins.num != 0) {
+ ckfree((char *) clsPtr->mixins.list);
+ }
+ DUPLICATE(cls2Ptr->mixins, clsPtr->mixins, Class *);
+ FOREACH(mixinPtr, cls2Ptr->mixins) {
+ TclOOAddToMixinSubs(cls2Ptr, mixinPtr);
+ }
+
+ /*
+ * Duplicate the source class's methods, constructor and destructor.
+ */
+
+ FOREACH_HASH(keyPtr, mPtr, &clsPtr->classMethods) {
+ (void) CloneClassMethod(interp, cls2Ptr, mPtr, keyPtr);
+ }
+ if (clsPtr->constructorPtr) {
+ cls2Ptr->constructorPtr = CloneClassMethod(interp, cls2Ptr,
+ clsPtr->constructorPtr, NULL);
+ }
+ if (clsPtr->destructorPtr) {
+ cls2Ptr->destructorPtr = CloneClassMethod(interp, cls2Ptr,
+ clsPtr->destructorPtr, NULL);
+ }
+
+ /*
+ * Duplicate the class's metadata.
+ */
+
+ if (clsPtr->metadataPtr != NULL) {
+ Tcl_ObjectMetadataType *metadataTypePtr;
+ ClientData value, duplicate;
+
+ FOREACH_HASH(metadataTypePtr, value, clsPtr->metadataPtr) {
+ if (metadataTypePtr->cloneProc == NULL) {
+ continue;
+ }
+ duplicate = metadataTypePtr->cloneProc(value);
+ if (duplicate != NULL) {
+ Tcl_ClassSetMetadata((Tcl_Class) cls2Ptr, metadataTypePtr,
+ duplicate);
+ }
+ }
+ }
+ }
+
+ return (Tcl_Object) o2Ptr;
+}
+
+/*
+ * ----------------------------------------------------------------------
+ *
+ * CloneObjectMethod, CloneClassMethod --
+ *
+ * Helper functions used for cloning methods. They work identically to
+ * each other, except for the difference between them in how they
+ * register the cloned method on a successful clone.
+ *
+ * ----------------------------------------------------------------------
+ */
+
+static Method *
+CloneObjectMethod(
+ Tcl_Interp *interp,
+ Object *oPtr,
+ Method *mPtr,
+ Tcl_Obj *namePtr)
+{
+ if (mPtr->typePtr == NULL) {
+ return (Method *) Tcl_NewMethod(interp, (Tcl_Object) oPtr, namePtr,
+ mPtr->flags & PUBLIC_METHOD, NULL, NULL);
+ } else if (mPtr->typePtr->cloneProc) {
+ ClientData newClientData;
+
+ if (mPtr->typePtr->cloneProc(mPtr->clientData,
+ &newClientData) != TCL_OK) {
+ return NULL;
+ }
+ return (Method *) Tcl_NewMethod(interp, (Tcl_Object) oPtr, namePtr,
+ mPtr->flags & PUBLIC_METHOD, mPtr->typePtr, newClientData);
+ } else {
+ return (Method *) Tcl_NewMethod(interp, (Tcl_Object) oPtr, namePtr,
+ mPtr->flags & PUBLIC_METHOD, mPtr->typePtr, mPtr->clientData);
+ }
+}
+
+static Method *
+CloneClassMethod(
+ Tcl_Interp *interp,
+ Class *clsPtr,
+ Method *mPtr,
+ Tcl_Obj *namePtr)
+{
+ if (mPtr->typePtr == NULL) {
+ return (Method *) Tcl_NewClassMethod(interp, (Tcl_Class) clsPtr,
+ namePtr, mPtr->flags & PUBLIC_METHOD, NULL, NULL);
+ } else if (mPtr->typePtr->cloneProc) {
+ ClientData newClientData;
+
+ if (mPtr->typePtr->cloneProc(mPtr->clientData,
+ &newClientData) != TCL_OK) {
+ return NULL;
+ }
+ return (Method *) Tcl_NewClassMethod(interp, (Tcl_Class) clsPtr,
+ namePtr, mPtr->flags & PUBLIC_METHOD, mPtr->typePtr,
+ newClientData);
+ } else {
+ return (Method *) Tcl_NewClassMethod(interp, (Tcl_Class) clsPtr,
+ namePtr, mPtr->flags & PUBLIC_METHOD, mPtr->typePtr,
+ mPtr->clientData);
+ }
+}
+
+/*
+ * ----------------------------------------------------------------------
+ *
+ * Tcl_NewMethod --
+ *
+ * Attach a method to an object.
+ *
+ * ----------------------------------------------------------------------
+ */
+
+Tcl_Method
+Tcl_NewMethod(
+ Tcl_Interp *interp, /* Unused? */
+ Tcl_Object object, /* The object that has the method attached to
+ * it. */
+ Tcl_Obj *nameObj, /* The name of the method. May be NULL; if so,
+ * up to caller to manage storage (e.g., when
+ * it is a constructor or destructor). */
+ int isPublic, /* Whether this is a public method. */
+ const Tcl_MethodType *typePtr,
+ /* The type of method this is, which defines
+ * how to invoke, delete and clone the
+ * method. */
+ ClientData clientData) /* Some data associated with the particular
+ * method to be created. */
+{
+ register Object *oPtr = (Object *) object;
+ register Method *mPtr;
+ Tcl_HashEntry *hPtr;
+ int isNew;
+
+ if (nameObj == NULL) {
+ mPtr = (Method *) ckalloc(sizeof(Method));
+ mPtr->namePtr = NULL;
+ goto populate;
+ }
+ hPtr = Tcl_CreateHashEntry(&oPtr->methods, (char *) nameObj, &isNew);
+ if (isNew) {
+ mPtr = (Method *) ckalloc(sizeof(Method));
+ mPtr->namePtr = nameObj;
+ Tcl_IncrRefCount(nameObj);
+ Tcl_SetHashValue(hPtr, mPtr);
+ } else {
+ mPtr = Tcl_GetHashValue(hPtr);
+ if (mPtr->typePtr != NULL && mPtr->typePtr->deleteProc != NULL) {
+ mPtr->typePtr->deleteProc(mPtr->clientData);
+ }
+ }
+
+ populate:
+ mPtr->typePtr = typePtr;
+ mPtr->clientData = clientData;
+ mPtr->flags = 0;
+ mPtr->declaringObjectPtr = oPtr;
+ mPtr->declaringClassPtr = NULL;
+ if (isPublic) {
+ mPtr->flags |= PUBLIC_METHOD;
+ }
+ oPtr->epoch++;
+ return (Tcl_Method) mPtr;
+}
+
+/*
+ * ----------------------------------------------------------------------
+ *
+ * Tcl_NewClassMethod --
+ *
+ * Attach a method to a class.
+ *
+ * ----------------------------------------------------------------------
+ */
+
+Tcl_Method
+Tcl_NewClassMethod(
+ Tcl_Interp *interp, /* The interpreter containing the class. */
+ Tcl_Class cls, /* The class to attach the method to. */
+ Tcl_Obj *nameObj, /* The name of the object. May be NULL (e.g.,
+ * for constructors or destructors); if so, up
+ * to caller to manage storage. */
+ int isPublic, /* Whether this is a public method. */
+ const Tcl_MethodType *typePtr,
+ /* The type of method this is, which defines
+ * how to invoke, delete and clone the
+ * method. */
+ ClientData clientData) /* Some data associated with the particular
+ * method to be created. */
+{
+ register Class *clsPtr = (Class *) cls;
+ register Method *mPtr;
+ Tcl_HashEntry *hPtr;
+ int isNew;
+
+ if (nameObj == NULL) {
+ mPtr = (Method *) ckalloc(sizeof(Method));
+ mPtr->namePtr = NULL;
+ goto populate;
+ }
+ hPtr = Tcl_CreateHashEntry(&clsPtr->classMethods, (char *)nameObj,&isNew);
+ if (isNew) {
+ mPtr = (Method *) ckalloc(sizeof(Method));
+ mPtr->namePtr = nameObj;
+ Tcl_IncrRefCount(nameObj);
+ Tcl_SetHashValue(hPtr, mPtr);
+ } else {
+ mPtr = Tcl_GetHashValue(hPtr);
+ if (mPtr->typePtr != NULL && mPtr->typePtr->deleteProc != NULL) {
+ mPtr->typePtr->deleteProc(mPtr->clientData);
+ }
+ }
+
+ populate:
+ ((Interp *) interp)->ooFoundation->epoch++;
+ mPtr->typePtr = typePtr;
+ mPtr->clientData = clientData;
+ mPtr->flags = 0;
+ mPtr->declaringObjectPtr = NULL;
+ mPtr->declaringClassPtr = clsPtr;
+ if (isPublic) {
+ mPtr->flags |= PUBLIC_METHOD;
+ }
+
+ return (Tcl_Method) mPtr;
+}
+
+/*
+ * ----------------------------------------------------------------------
+ *
+ * DeleteMethodStruct --
+ *
+ * Function used when deleting a method. Always called indirectly via
+ * Tcl_EventuallyFree().
+ *
+ * ----------------------------------------------------------------------
+ */
+
+static void
+DeleteMethodStruct(
+ char *buffer)
+{
+ Method *mPtr = (Method *) buffer;
+
+ if (mPtr->typePtr != NULL && mPtr->typePtr->deleteProc != NULL) {
+ mPtr->typePtr->deleteProc(mPtr->clientData);
+ }
+ if (mPtr->namePtr != NULL) {
+ TclDecrRefCount(mPtr->namePtr);
+ }
+
+ ckfree(buffer);
+}
+
+/*
+ * ----------------------------------------------------------------------
+ *
+ * TclOODeleteMethod --
+ *
+ * How to delete a method.
+ *
+ * ----------------------------------------------------------------------
+ */
+
+void
+TclOODeleteMethod(
+ Method *mPtr)
+{
+ if (mPtr != NULL) {
+ Tcl_EventuallyFree(mPtr, DeleteMethodStruct);
+ }
+}
+
+/*
+ * ----------------------------------------------------------------------
+ *
+ * DeclareClassMethod --
+ *
+ * Helper that makes it cleaner to create very simple methods during
+ * basic system initialization. Not suitable for general use.
+ *
+ * ----------------------------------------------------------------------
+ */
+
+static void
+DeclareClassMethod(
+ Tcl_Interp *interp,
+ Class *clsPtr, /* Class to attach the method to. */
+ const char *name, /* Name of the method. */
+ int isPublic, /* Whether the method is public. */
+ Tcl_MethodCallProc callPtr)
+ /* Method implementation function. */
+{
+ Tcl_Obj *namePtr;
+
+ TclNewStringObj(namePtr, name, strlen(name));
+ Tcl_IncrRefCount(namePtr);
+ Tcl_NewClassMethod(interp, (Tcl_Class) clsPtr, namePtr, isPublic,
+ &coreMethodType, callPtr);
+ TclDecrRefCount(namePtr);
+}
+
+/*
+ * ----------------------------------------------------------------------
+ *
+ * SimpleInvoke --
+ *
+ * How to invoke a simple method.
+ *
+ * ----------------------------------------------------------------------
+ */
+
+static int
+SimpleInvoke(
+ ClientData clientData, /* Pointer to function that implements the
+ * method. */
+ Tcl_Interp *interp,
+ Tcl_ObjectContext context, /* The method calling context. */
+ int objc, /* Number of arguments. */
+ Tcl_Obj *const *objv) /* Arguments as actually seen. */
+{
+ Tcl_MethodCallProc callPtr = clientData;
+
+ return (*callPtr)(NULL, interp, context, objc, objv);
+}
+
+/*
+ * ----------------------------------------------------------------------
+ *
+ * TclOONewProcMethod --
+ *
+ * Create a new procedure-like method for an object.
+ *
+ * ----------------------------------------------------------------------
+ */
+
+Method *
+TclOONewProcMethod(
+ Tcl_Interp *interp, /* The interpreter containing the object. */
+ Object *oPtr, /* The object to modify. */
+ int isPublic, /* Whether this is a public method. */
+ Tcl_Obj *nameObj, /* The name of the method, which must not be
+ * NULL. */
+ Tcl_Obj *argsObj, /* The formal argument list for the method,
+ * which must not be NULL. */
+ Tcl_Obj *bodyObj) /* The body of the method, which must not be
+ * NULL. */
+{
+ int argsc;
+ Tcl_Obj **argsv;
+ register ProcedureMethod *pmPtr;
+ const char *procName;
+
+ if (Tcl_ListObjGetElements(interp, argsObj, &argsc, &argsv) != TCL_OK) {
+ return NULL;
+ }
+ pmPtr = (ProcedureMethod *) ckalloc(sizeof(ProcedureMethod));
+ procName = TclGetString(nameObj);
+ if (TclCreateProc(interp, NULL, procName, argsObj, bodyObj,
+ &pmPtr->procPtr) != TCL_OK) {
+ ckfree((char *) pmPtr);
+ return NULL;
+ }
+ return (Method *) Tcl_NewMethod(interp, (Tcl_Object) oPtr, nameObj,
+ isPublic, &procMethodType, pmPtr);
+}
+
+/*
+ * ----------------------------------------------------------------------
+ *
+ * TclOONewProcClassMethod --
+ *
+ * Create a new procedure-like method for a class.
+ *
+ * ----------------------------------------------------------------------
+ */
+
+Method *
+TclOONewProcClassMethod(
+ Tcl_Interp *interp, /* The interpreter containing the class. */
+ Class *clsPtr, /* The class to modify. */
+ int isPublic, /* Whether this is a public method. */
+ Tcl_Obj *nameObj, /* The name of the method, which may be NULL;
+ * if so, up to caller to manage storage
+ * (e.g., because it is a constructor or
+ * destructor). */
+ Tcl_Obj *argsObj, /* The formal argument list for the method,
+ * which may be NULL; if so, it is equivalent
+ * to an empty list. */
+ Tcl_Obj *bodyObj) /* The body of the method, which must not be
+ * NULL. */
+{
+ int argsLen; /* -1 => delete argsObj before exit */
+ register ProcedureMethod *pmPtr;
+ const char *procName;
+
+ if (argsObj == NULL) {
+ argsLen = -1;
+ TclNewObj(argsObj);
+ Tcl_IncrRefCount(argsObj);
+ procName = "<destructor>";
+ } else if (Tcl_ListObjLength(interp, argsObj, &argsLen) != TCL_OK) {
+ return NULL;
+ } else {
+ procName = (nameObj==NULL ? "<constructor>" : TclGetString(nameObj));
+ }
+ pmPtr = (ProcedureMethod *) ckalloc(sizeof(ProcedureMethod));
+ if (TclCreateProc(interp, NULL, procName, argsObj, bodyObj,
+ &pmPtr->procPtr) != TCL_OK) {
+ if (argsLen == -1) {
+ TclDecrRefCount(argsObj);
+ }
+ ckfree((char *) pmPtr);
+ return NULL;
+ }
+ if (argsLen == -1) {
+ TclDecrRefCount(argsObj);
+ }
+ return (Method *) Tcl_NewClassMethod(interp, (Tcl_Class) clsPtr, nameObj,
+ isPublic, &procMethodType, pmPtr);
+}
+
+/*
+ * ----------------------------------------------------------------------
+ *
+ * InvokeProcedureMethod --
+ *
+ * How to invoke a procedure-like method.
+ *
+ * ----------------------------------------------------------------------
+ */
+
+static int
+InvokeProcedureMethod(
+ ClientData clientData, /* Pointer to some per-method context. */
+ Tcl_Interp *interp,
+ Tcl_ObjectContext context, /* The method calling context. */
+ int objc, /* Number of arguments. */
+ Tcl_Obj *const *objv) /* Arguments as actually seen. */
+{
+ CallContext *contextPtr = (CallContext *) context;
+ ProcedureMethod *pmPtr = (ProcedureMethod *) clientData;
+ int result, flags = FRAME_IS_METHOD, skip = contextPtr->skip;
+ CallFrame *framePtr, **framePtrPtr;
+ Object *oPtr = contextPtr->oPtr;
+ Command cmd;
+ const char *namePtr;
+ Tcl_Obj *nameObj;
+
+ cmd.nsPtr = (Namespace *) oPtr->namespacePtr;
+ pmPtr->procPtr->cmdPtr = &cmd;
+ if (contextPtr->flags & CONSTRUCTOR) {
+ namePtr = "<constructor>";
+ flags |= FRAME_IS_CONSTRUCTOR;
+ nameObj = Tcl_NewStringObj("<constructor>", -1);
+ Tcl_IncrRefCount(nameObj);
+ } else if (contextPtr->flags & DESTRUCTOR) {
+ namePtr = "<destructor>";
+ flags |= FRAME_IS_DESTRUCTOR;
+ nameObj = Tcl_NewStringObj("<destructor>", -1);
+ Tcl_IncrRefCount(nameObj);
+ } else {
+ nameObj = objv[contextPtr->skip-1];
+ namePtr = TclGetString(nameObj);
+ }
+ result = TclProcCompileProc(interp, pmPtr->procPtr,
+ pmPtr->procPtr->bodyPtr, (Namespace *) oPtr->namespacePtr,
+ "body of method", namePtr);
+ if (result != TCL_OK) {
+ return result;
+ }
+
+ if (contextPtr->callChain[contextPtr->index].isFilter) {
+ flags |= FRAME_IS_FILTER;
+ }
+ framePtrPtr = &framePtr;
+ result = TclPushStackFrame(interp, (Tcl_CallFrame **) framePtrPtr,
+ oPtr->namespacePtr, flags);
+ if (result != TCL_OK) {
+ return result;
+ }
+ framePtr->ooContextPtr = contextPtr;
+ framePtr->objc = objc;
+ framePtr->objv = objv; /* ref counts for args are incremented below */
+ framePtr->procPtr = pmPtr->procPtr;
+
+ if (contextPtr->flags & OO_UNKNOWN_METHOD) {
+ skip--;
+ }
+ result = TclObjInterpProcCore(interp, framePtr, nameObj, skip);
+ if (contextPtr->flags & (CONSTRUCTOR | DESTRUCTOR)) {
+ TclDecrRefCount(nameObj);
+ }
+ return result;
+}
+
+/*
+ * ----------------------------------------------------------------------
+ *
+ * DeleteProcedureMethod, CloneProcedureMethod --
+ *
+ * How to delete and clone procedure-like methods.
+ *
+ * ----------------------------------------------------------------------
+ */
+
+static void
+DeleteProcedureMethod(
+ ClientData clientData)
+{
+ register ProcedureMethod *pmPtr = (ProcedureMethod *) clientData;
+
+ TclProcDeleteProc(pmPtr->procPtr);
+ ckfree((char *) pmPtr);
+}
+
+static int
+CloneProcedureMethod(
+ ClientData clientData,
+ ClientData *newClientData)
+{
+ ProcedureMethod *pmPtr = (ProcedureMethod *) clientData;
+ ProcedureMethod *pm2Ptr = (ProcedureMethod *)
+ ckalloc(sizeof(ProcedureMethod));
+
+ pm2Ptr->procPtr = pmPtr->procPtr;
+ pm2Ptr->procPtr->refCount++;
+ *newClientData = pm2Ptr;
+ return TCL_OK;
+}
+
+/*
+ * ----------------------------------------------------------------------
+ *
+ * TclOONewForwardMethod --
+ *
+ * Create a forwarded method for an object.
+ *
+ * ----------------------------------------------------------------------
+ */
+
+Method *
+TclOONewForwardMethod(
+ Tcl_Interp *interp, /* Interpreter for error reporting. */
+ Object *oPtr, /* The object to attach the method to. */
+ int isPublic, /* Whether the method is public or not. */
+ Tcl_Obj *nameObj, /* The name of the method. */
+ Tcl_Obj *prefixObj) /* List of arguments that form the command
+ * prefix to forward to. */
+{
+ int prefixLen;
+ register ForwardMethod *fmPtr;
+
+ if (Tcl_ListObjLength(interp, prefixObj, &prefixLen) != TCL_OK) {
+ return NULL;
+ }
+ if (prefixLen < 1) {
+ Tcl_AppendResult(interp, "method forward prefix must be non-empty",
+ NULL);
+ return NULL;
+ }
+
+ fmPtr = (ForwardMethod *) ckalloc(sizeof(ForwardMethod));
+ fmPtr->prefixObj = prefixObj;
+ Tcl_IncrRefCount(prefixObj);
+ return (Method *) Tcl_NewMethod(interp, (Tcl_Object) oPtr, nameObj,
+ isPublic, &fwdMethodType, fmPtr);
+}
+
+/*
+ * ----------------------------------------------------------------------
+ *
+ * TclOONewForwardClassMethod --
+ *
+ * Create a new forwarded method for a class.
+ *
+ * ----------------------------------------------------------------------
+ */
+
+Method *
+TclOONewForwardClassMethod(
+ Tcl_Interp *interp, /* Interpreter for error reporting. */
+ Class *clsPtr, /* The class to attach the method to. */
+ int isPublic, /* Whether the method is public or not. */
+ Tcl_Obj *nameObj, /* The name of the method. */
+ Tcl_Obj *prefixObj) /* List of arguments that form the command
+ * prefix to forward to. */
+{
+ int prefixLen;
+ register ForwardMethod *fmPtr;
+
+ if (Tcl_ListObjLength(interp, prefixObj, &prefixLen) != TCL_OK) {
+ return NULL;
+ }
+ if (prefixLen < 1) {
+ Tcl_AppendResult(interp, "method forward prefix must be non-empty",
+ NULL);
+ return NULL;
+ }
+
+ fmPtr = (ForwardMethod *) ckalloc(sizeof(ForwardMethod));
+ fmPtr->prefixObj = prefixObj;
+ Tcl_IncrRefCount(prefixObj);
+ return (Method *) Tcl_NewClassMethod(interp, (Tcl_Class) clsPtr, nameObj,
+ isPublic, &fwdMethodType, fmPtr);
+}
+
+/*
+ * ----------------------------------------------------------------------
+ *
+ * InvokeForwardMethod --
+ *
+ * How to invoke a forwarded method. Works by doing some ensemble-like
+ * command rearranging and then invokes some other Tcl command.
+ *
+ * ----------------------------------------------------------------------
+ */
+
+static int
+InvokeForwardMethod(
+ ClientData clientData, /* Pointer to some per-method context. */
+ Tcl_Interp *interp,
+ Tcl_ObjectContext context, /* The method calling context. */
+ int objc, /* Number of arguments. */
+ Tcl_Obj *const *objv) /* Arguments as actually seen. */
+{
+ CallContext *contextPtr = (CallContext *) context;
+ ForwardMethod *fmPtr = (ForwardMethod *) clientData;
+ Tcl_Obj **argObjs, **prefixObjs;
+ int numPrefixes, result, len;
+
+ /*
+ * Build the real list of arguments to use. Note that we know that the
+ * prefixObj field of the ForwardMethod structure holds a reference to a
+ * non-empty list, so there's a whole class of failures ("not a list") we
+ * can ignore here.
+ */
+
+ Tcl_ListObjGetElements(NULL, fmPtr->prefixObj, &numPrefixes, &prefixObjs);
+ argObjs = InitEnsembleRewrite(interp, objc, objv, contextPtr->skip,
+ numPrefixes, prefixObjs, &len);
+
+ result = Tcl_EvalObjv(interp, len, argObjs, TCL_EVAL_INVOKE);
+ ckfree((char *) argObjs);
+ return result;
+}
+
+/*
+ * ----------------------------------------------------------------------
+ *
+ * DeleteForwardMethod, CloneForwardMethod --
+ *
+ * How to delete and clone forwarded methods.
+ *
+ * ----------------------------------------------------------------------
+ */
+
+static void
+DeleteForwardMethod(
+ ClientData clientData)
+{
+ ForwardMethod *fmPtr = (ForwardMethod *) clientData;
+
+ TclDecrRefCount(fmPtr->prefixObj);
+ ckfree((char *) fmPtr);
+}
+
+static int
+CloneForwardMethod(
+ ClientData clientData,
+ ClientData *newClientData)
+{
+ ForwardMethod *fmPtr = (ForwardMethod *) clientData;
+ ForwardMethod *fm2Ptr = (ForwardMethod *) ckalloc(sizeof(ForwardMethod));
+
+ fm2Ptr->prefixObj = fmPtr->prefixObj;
+ Tcl_IncrRefCount(fm2Ptr->prefixObj);
+ *newClientData = fm2Ptr;
+ return TCL_OK;
+}
+
+/*
+ * ----------------------------------------------------------------------
+ *
+ * Tcl_ClassGetMetadata, Tcl_ClassSetMetadata, Tcl_ObjectGetMetadata,
+ * Tcl_ObjectSetMetadata --
+ *
+ * Metadata management API. The metadata system allows code in extensions
+ * to attach arbitrary non-NULL pointers to objects and classes without
+ * the different things that might be interested being able to interfere
+ * with each other. Apart from non-NULL-ness, these routines attach no
+ * interpretation to the meaning of the metadata pointers.
+ *
+ * The Tcl_*GetMetadata routines get the metadata pointer attached that
+ * has been related with a particular type, or NULL if no metadata
+ * associated with the given type has been attached.
+ *
+ * The Tcl_*SetMetadata routines set or delete the metadata pointer that
+ * is related to a particular type. The value associated with the type is
+ * deleted (if present; no-op otherwise) if the value is NULL, and
+ * attached (replacing the previous value, which is deleted if present)
+ * otherwise. This means it is impossible to attach a NULL value for any
+ * metadata type.
+ *
+ * ----------------------------------------------------------------------
+ */
+
+ClientData
+Tcl_ClassGetMetadata(
+ Tcl_Class clazz,
+ const Tcl_ObjectMetadataType *typePtr)
+{
+ Class *clsPtr = (Class *) clazz;
+ Tcl_HashEntry *hPtr;
+
+ /*
+ * If there's no metadata store attached, the type in question has
+ * definitely not been attached either!
+ */
+
+ if (clsPtr->metadataPtr == NULL) {
+ return NULL;
+ }
+
+ /*
+ * There is a metadata store, so look in it for the given type.
+ */
+
+ hPtr = Tcl_FindHashEntry(clsPtr->metadataPtr, (char *) typePtr);
+
+ /*
+ * Return the metadata value if we found it, otherwise NULL.
+ */
+
+ if (hPtr == NULL) {
+ return NULL;
+ } else {
+ return Tcl_GetHashValue(hPtr);
+ }
+}
+
+void
+Tcl_ClassSetMetadata(
+ Tcl_Class clazz,
+ const Tcl_ObjectMetadataType *typePtr,
+ ClientData metadata)
+{
+ Class *clsPtr = (Class *) clazz;
+ Tcl_HashEntry *hPtr;
+ int isNew;
+
+ /*
+ * Attach the metadata store if not done already.
+ */
+
+ if (clsPtr->metadataPtr == NULL) {
+ if (metadata == NULL) {
+ return;
+ }
+ clsPtr->metadataPtr = (Tcl_HashTable*) ckalloc(sizeof(Tcl_HashTable));
+ Tcl_InitHashTable(clsPtr->metadataPtr, TCL_ONE_WORD_KEYS);
+ }
+
+ /*
+ * If the metadata is NULL, we're deleting the metadata for the type.
+ */
+
+ if (metadata == NULL) {
+ hPtr = Tcl_FindHashEntry(clsPtr->metadataPtr, (char *) typePtr);
+ if (hPtr != NULL) {
+ Tcl_DeleteHashEntry(hPtr);
+ }
+ return;
+ }
+
+ /*
+ * Otherwise we're attaching the metadata. Note that if there was already
+ * some metadata attached of this type, we delete that first.
+ */
+
+ hPtr = Tcl_CreateHashEntry(clsPtr->metadataPtr, (char *) typePtr, &isNew);
+ if (!isNew) {
+ typePtr->deleteProc(Tcl_GetHashValue(hPtr));
+ }
+ Tcl_SetHashValue(hPtr, metadata);
+}
+
+ClientData
+Tcl_ObjectGetMetadata(
+ Tcl_Object object,
+ const Tcl_ObjectMetadataType *typePtr)
+{
+ Object *oPtr = (Object *) object;
+ Tcl_HashEntry *hPtr;
+
+ /*
+ * If there's no metadata store attached, the type in question has
+ * definitely not been attached either!
+ */
+
+ if (oPtr->metadataPtr == NULL) {
+ return NULL;
+ }
+
+ /*
+ * There is a metadata store, so look in it for the given type.
+ */
+
+ hPtr = Tcl_FindHashEntry(oPtr->metadataPtr, (char *) typePtr);
+
+ /*
+ * Return the metadata value if we found it, otherwise NULL.
+ */
+
+ if (hPtr == NULL) {
+ return NULL;
+ } else {
+ return Tcl_GetHashValue(hPtr);
+ }
+}
+
+void
+Tcl_ObjectSetMetadata(
+ Tcl_Object object,
+ const Tcl_ObjectMetadataType *typePtr,
+ ClientData metadata)
+{
+ Object *oPtr = (Object *) object;
+ Tcl_HashEntry *hPtr;
+ int isNew;
+
+ /*
+ * Attach the metadata store if not done already.
+ */
+
+ if (oPtr->metadataPtr == NULL) {
+ if (metadata == NULL) {
+ return;
+ }
+ oPtr->metadataPtr = (Tcl_HashTable *) ckalloc(sizeof(Tcl_HashTable));
+ Tcl_InitHashTable(oPtr->metadataPtr, TCL_ONE_WORD_KEYS);
+ }
+
+ /*
+ * If the metadata is NULL, we're deleting the metadata for the type.
+ */
+
+ if (metadata == NULL) {
+ hPtr = Tcl_FindHashEntry(oPtr->metadataPtr, (char *) typePtr);
+ if (hPtr != NULL) {
+ Tcl_DeleteHashEntry(hPtr);
+ }
+ return;
+ }
+
+ /*
+ * Otherwise we're attaching the metadata. Note that if there was already
+ * some metadata attached of this type, we delete that first.
+ */
+
+ hPtr = Tcl_CreateHashEntry(oPtr->metadataPtr, (char *) typePtr, &isNew);
+ if (!isNew) {
+ typePtr->deleteProc(Tcl_GetHashValue(hPtr));
+ }
+ Tcl_SetHashValue(hPtr, metadata);
+}
+
+/*
+ * ----------------------------------------------------------------------
+ *
+ * PublicObjectCmd, PrivateObjectCmd, ObjectCmd --
+ *
+ * Main entry point for object invokations. The Public* and Private*
+ * wrapper functions are just thin wrappers round the main ObjectCmd
+ * function that does call chain creation, management and invokation.
+ *
+ * ----------------------------------------------------------------------
+ */
+
+static int
+PublicObjectCmd(
+ ClientData clientData,
+ Tcl_Interp *interp,
+ int objc,
+ Tcl_Obj *const *objv)
+{
+ return ObjectCmd(clientData, interp, objc, objv, 1,
+ &((Object *)clientData)->publicContextCache);
+}
+
+static int
+PrivateObjectCmd(
+ ClientData clientData,
+ Tcl_Interp *interp,
+ int objc,
+ Tcl_Obj *const *objv)
+{
+ return ObjectCmd(clientData, interp, objc, objv, 0,
+ &((Object *)clientData)->privateContextCache);
+}
+
+static int
+ObjectCmd(
+ Object *oPtr, /* The object being invoked. */
+ Tcl_Interp *interp, /* The interpreter containing the object. */
+ int objc, /* How many arguments are being passed in. */
+ Tcl_Obj *const *objv, /* The array of arguments. */
+ int publicOnly, /* Whether this is an invokation through the
+ * public or the private command interface. */
+ Tcl_HashTable *cachePtr) /* What call chain cache to use. */
+{
+ Interp *iPtr = (Interp *) interp;
+ CallContext *contextPtr;
+ int result;
+
+ if (objc < 2) {
+ Tcl_WrongNumArgs(interp, 1, objv, "method ?arg ...?");
+ return TCL_ERROR;
+ }
+
+ contextPtr = TclOOGetCallContext(iPtr->ooFoundation, oPtr, objv[1],
+ (publicOnly ? PUBLIC_METHOD :0) | (oPtr->flags & FILTER_HANDLING),
+ cachePtr);
+ if (contextPtr == NULL) {
+ Tcl_AppendResult(interp, "impossible to invoke method \"",
+ TclGetString(objv[1]),
+ "\": no defined method or unknown method", NULL);
+ return TCL_ERROR;
+ }
+
+ Tcl_Preserve(oPtr);
+ result = TclOOInvokeContext(interp, contextPtr, objc, objv);
+ if (!(contextPtr->flags & OO_UNKNOWN_METHOD)
+ && !(oPtr->flags & OBJECT_DELETED)) {
+ Tcl_HashEntry *hPtr;
+
+ hPtr = Tcl_FindHashEntry(cachePtr, (char *) objv[1]);
+ if (hPtr != NULL && Tcl_GetHashValue(hPtr) == NULL) {
+ Tcl_SetHashValue(hPtr, contextPtr);
+ } else {
+ TclOODeleteContext(contextPtr);
+ }
+ } else {
+ TclOODeleteContext(contextPtr);
+ }
+ Tcl_Release(oPtr);
+
+ return result;
+}
+
+/*
+ * ----------------------------------------------------------------------
+ *
+ * ClassCreate --
+ *
+ * Implementation for oo::class->create method.
+ *
+ * ----------------------------------------------------------------------
+ */
+
+static int
+ClassCreate(
+ ClientData clientData, /* Ignored. */
+ Tcl_Interp *interp, /* Interpreter in which to create the object;
+ * also used for error reporting. */
+ Tcl_ObjectContext context, /* The object/call context. */
+ int objc, /* Number of arguments. */
+ Tcl_Obj *const *objv) /* The actual arguments. */
+{
+ Object *oPtr = (Object *) Tcl_ObjectContextObject(context);
+ Tcl_Object newObject;
+ const char *objName;
+ int len;
+
+ /*
+ * Sanity check; should not be possible to invoke this method on a
+ * non-class.
+ */
+
+ if (oPtr->classPtr == NULL) {
+ Tcl_Obj *cmdnameObj;
+
+ TclNewObj(cmdnameObj);
+ Tcl_GetCommandFullName(interp, oPtr->command, cmdnameObj);
+ Tcl_AppendResult(interp, "object \"", TclGetString(cmdnameObj),
+ "\" is not a class", NULL);
+ TclDecrRefCount(cmdnameObj);
+ return TCL_ERROR;
+ }
+
+ /*
+ * Check we have the right number of (sensible) arguments.
+ */
+
+ if (objc - Tcl_ObjectContextSkippedArgs(context) < 1) {
+ Tcl_WrongNumArgs(interp, Tcl_ObjectContextSkippedArgs(context), objv,
+ "objectName ?arg ...?");
+ return TCL_ERROR;
+ }
+ objName = Tcl_GetStringFromObj(
+ objv[Tcl_ObjectContextSkippedArgs(context)], &len);
+ if (len == 0) {
+ Tcl_AppendResult(interp, "object name must not be empty", NULL);
+ return TCL_ERROR;
+ }
+
+ /*
+ * Make the object and return its name.
+ */
+
+ newObject = Tcl_NewObjectInstance(interp, (Tcl_Class) oPtr->classPtr,
+ objName, objc, objv, Tcl_ObjectContextSkippedArgs(context)+1);
+ if (newObject == NULL) {
+ return TCL_ERROR;
+ }
+ Tcl_GetCommandFullName(interp, Tcl_GetObjectCommand(newObject),
+ Tcl_GetObjResult(interp));
+ return TCL_OK;
+}
+
+/*
+ * ----------------------------------------------------------------------
+ *
+ * ClassNew --
+ *
+ * Implementation for oo::class->new method.
+ *
+ * ----------------------------------------------------------------------
+ */
+
+static int
+ClassNew(
+ ClientData clientData, /* Ignored. */
+ Tcl_Interp *interp, /* Interpreter in which to create the object;
+ * also used for error reporting. */
+ Tcl_ObjectContext context, /* The object/call context. */
+ int objc, /* Number of arguments. */
+ Tcl_Obj *const *objv) /* The actual arguments. */
+{
+ Object *oPtr = (Object *) Tcl_ObjectContextObject(context);
+ Tcl_Object newObject;
+
+ /*
+ * Sanity check; should not be possible to invoke this method on a
+ * non-class.
+ */
+
+ if (oPtr->classPtr == NULL) {
+ Tcl_Obj *cmdnameObj;
+
+ TclNewObj(cmdnameObj);
+ Tcl_GetCommandFullName(interp, oPtr->command, cmdnameObj);
+ Tcl_AppendResult(interp, "object \"", TclGetString(cmdnameObj),
+ "\" is not a class", NULL);
+ TclDecrRefCount(cmdnameObj);
+ return TCL_ERROR;
+ }
+
+ /*
+ * Make the object and return its name.
+ */
+
+ newObject = Tcl_NewObjectInstance(interp, (Tcl_Class) oPtr->classPtr,
+ NULL, objc, objv, Tcl_ObjectContextSkippedArgs(context));
+ if (newObject == NULL) {
+ return TCL_ERROR;
+ }
+ Tcl_GetCommandFullName(interp, Tcl_GetObjectCommand(newObject),
+ Tcl_GetObjResult(interp));
+ return TCL_OK;
+}
+
+/*
+ * ----------------------------------------------------------------------
+ *
+ * ObjectDestroy --
+ *
+ * Implementation for oo::object->destroy method.
+ *
+ * ----------------------------------------------------------------------
+ */
+
+static int
+ObjectDestroy(
+ ClientData clientData, /* Ignored. */
+ Tcl_Interp *interp, /* Interpreter in which to create the object;
+ * also used for error reporting. */
+ Tcl_ObjectContext context, /* The object/call context. */
+ int objc, /* Number of arguments. */
+ Tcl_Obj *const *objv) /* The actual arguments. */
+{
+ if (objc != Tcl_ObjectContextSkippedArgs(context)) {
+ Tcl_WrongNumArgs(interp, Tcl_ObjectContextSkippedArgs(context), objv,
+ NULL);
+ return TCL_ERROR;
+ }
+ Tcl_DeleteCommandFromToken(interp,
+ Tcl_GetObjectCommand(Tcl_ObjectContextObject(context)));
+ return TCL_OK;
+}
+
+/*
+ * ----------------------------------------------------------------------
+ *
+ * ObjectEval --
+ *
+ * Implementation for oo::object->eval method.
+ *
+ * ----------------------------------------------------------------------
+ */
+
+static int
+ObjectEval(
+ ClientData clientData, /* Ignored. */
+ Tcl_Interp *interp, /* Interpreter in which to create the object;
+ * also used for error reporting. */
+ Tcl_ObjectContext context, /* The object/call context. */
+ int objc, /* Number of arguments. */
+ Tcl_Obj *const *objv) /* The actual arguments. */
+{
+ CallContext *contextPtr = (CallContext *) context;
+ Tcl_Object object = Tcl_ObjectContextObject(context);
+ CallFrame *framePtr, **framePtrPtr;
+ Tcl_Obj *objnameObj;
+ int result;
+
+ if (objc-1 < Tcl_ObjectContextSkippedArgs(context)) {
+ Tcl_WrongNumArgs(interp, Tcl_ObjectContextSkippedArgs(context), objv,
+ "arg ?arg ...?");
+ return TCL_ERROR;
+ }
+
+ /*
+ * Make the object's namespace the current namespace and evaluate the
+ * command(s).
+ */
+
+ /* This is needed to satisfy GCC 3.3's strict aliasing rules */
+ framePtrPtr = &framePtr;
+ result = TclPushStackFrame(interp, (Tcl_CallFrame **) framePtrPtr,
+ Tcl_GetObjectNamespace(object), 0);
+ if (result != TCL_OK) {
+ return TCL_ERROR;
+ }
+ framePtr->objc = objc;
+ framePtr->objv = objv; /* Reference counts do not need to be
+ * incremented here. */
+
+ if (contextPtr->flags & PUBLIC_METHOD) {
+ TclNewObj(objnameObj);
+ Tcl_GetCommandFullName(interp, Tcl_GetObjectCommand(object),
+ objnameObj);
+ } else {
+ TclNewStringObj(objnameObj, "my", 2);
+ }
+ Tcl_IncrRefCount(objnameObj);
+
+ if (objc == Tcl_ObjectContextSkippedArgs(context)+1) {
+ result = Tcl_EvalObjEx(interp,
+ objv[Tcl_ObjectContextSkippedArgs(context)], 0);
+ } else {
+ Tcl_Obj *objPtr;
+
+ /*
+ * More than one argument: concatenate them together with spaces
+ * between, then evaluate the result. Tcl_EvalObjEx will delete the
+ * object when it decrements its refcount after eval'ing it.
+ */
+
+ objPtr = Tcl_ConcatObj(objc-Tcl_ObjectContextSkippedArgs(context),
+ objv+Tcl_ObjectContextSkippedArgs(context));
+ result = Tcl_EvalObjEx(interp, objPtr, TCL_EVAL_DIRECT);
+ }
+
+ if (result == TCL_ERROR) {
+ TclFormatToErrorInfo(interp,
+ "\n (in \"%s eval\" script line %d)",
+ TclGetString(objnameObj), interp->errorLine);
+ }
+
+ /*
+ * Restore the previous "current" namespace.
+ */
+
+ TclPopStackFrame(interp);
+ TclDecrRefCount(objnameObj);
+ return result;
+}
+
+/*
+ * ----------------------------------------------------------------------
+ *
+ * ObjectUnknown --
+ *
+ * Default unknown method handler method (defined in oo::object). This
+ * just creates a suitable error message.
+ *
+ * ----------------------------------------------------------------------
+ */
+
+static int
+ObjectUnknown(
+ ClientData clientData, /* Ignored. */
+ Tcl_Interp *interp, /* Interpreter in which to create the object;
+ * also used for error reporting. */
+ Tcl_ObjectContext context, /* The object/call context. */
+ int objc, /* Number of arguments. */
+ Tcl_Obj *const *objv) /* The actual arguments. */
+{
+ CallContext *contextPtr = (CallContext *) context;
+ Object *oPtr = contextPtr->oPtr;
+ const char **methodNames;
+ int numMethodNames, i;
+
+ /*
+ * Get the list of methods that we want to know about.
+ */
+
+ numMethodNames = TclOOGetSortedMethodList(oPtr,
+ contextPtr->flags & PUBLIC_METHOD, &methodNames);
+
+ /*
+ * Special message when there are no visible methods at all.
+ */
+
+ if (numMethodNames == 0) {
+ Tcl_Obj *tmpBuf;
+
+ TclNewObj(tmpBuf);
+ Tcl_GetCommandFullName(interp, oPtr->command, tmpBuf);
+ Tcl_AppendResult(interp, "object \"", TclGetString(tmpBuf),
+ "\" has no visible methods", NULL);
+ TclDecrRefCount(tmpBuf);
+ return TCL_ERROR;
+ }
+
+ Tcl_AppendResult(interp, "unknown method \"",
+ TclGetString(objv[Tcl_ObjectContextSkippedArgs(context)-1]),
+ "\": must be ", NULL);
+ for (i=0 ; i<numMethodNames-1 ; i++) {
+ if (i) {
+ Tcl_AppendResult(interp, ", ", NULL);
+ }
+ Tcl_AppendResult(interp, methodNames[i], NULL);
+ }
+ if (i) {
+ Tcl_AppendResult(interp, " or ", NULL);
+ }
+ Tcl_AppendResult(interp, methodNames[i], NULL);
+ ckfree((char *) methodNames);
+ return TCL_ERROR;
+}
+
+/*
+ * ----------------------------------------------------------------------
+ *
+ * ObjectLinkVar --
+ *
+ * Implementation of oo::object->variable method.
+ *
+ * ----------------------------------------------------------------------
+ */
+
+static int
+ObjectLinkVar(
+ ClientData clientData, /* Ignored. */
+ Tcl_Interp *interp, /* Interpreter in which to create the object;
+ * also used for error reporting. */
+ Tcl_ObjectContext context, /* The object/call context. */
+ int objc, /* Number of arguments. */
+ Tcl_Obj *const *objv) /* The actual arguments. */
+{
+ Interp *iPtr = (Interp *) interp;
+ Tcl_Object object = Tcl_ObjectContextObject(context);
+ Namespace *savedNsPtr;
+ int i;
+
+ if (objc-Tcl_ObjectContextSkippedArgs(context) < 1) {
+ Tcl_WrongNumArgs(interp, Tcl_ObjectContextSkippedArgs(context), objv,
+ "varName ?varName ...?");
+ return TCL_ERROR;
+ }
+
+ /*
+ * Do nothing if we are not called from the body of a method. In this
+ * respect, we are like the [global] command.
+ */
+
+ if (iPtr->varFramePtr == NULL ||
+ !(iPtr->varFramePtr->isProcCallFrame & FRAME_IS_METHOD)) {
+ return TCL_OK;
+ }
+
+ for (i=Tcl_ObjectContextSkippedArgs(context) ; i<objc ; i++) {
+ Var *varPtr, *aryPtr;
+ Tcl_Obj **argObjs;
+ const char *varName;
+ int len;
+
+ /*
+ * Parse to see if we have a single value in the argument (just the
+ * name of a variable to use in both the namespace and local scope) or
+ * a two-argument list (namespace variable name and local variable
+ * name). Other cases are an error.
+ */
+
+ if (Tcl_ListObjGetElements(interp, objv[i], &len, &argObjs)!=TCL_OK) {
+ return TCL_ERROR;
+ }
+ if (len != 1 && len != 2) {
+ Tcl_AppendResult(interp, "argument must be list "
+ "of one or two variable names", NULL);
+ return TCL_ERROR;
+ }
+
+ varName = TclGetString(argObjs[len-1]);
+ if (strstr(varName, "::") != NULL) {
+ /*
+ * The local var name must not contain a '::' but the ns name is
+ * OK. Naturally, if they're the same, then the restriction is
+ * applied equally to both.
+ */
+
+ Tcl_AppendResult(interp, "variable name \"", varName,
+ "\" illegal: must not contain namespace separator", NULL);
+ return TCL_ERROR;
+ }
+
+ /*
+ * Switch to the object's namespace for the duration of this call.
+ * Like this, the variable is looked up in the namespace of the
+ * object, and not in the namespace of the caller. Otherwise this
+ * would only work if the caller was a method of the object itself,
+ * which might not be true if the method was exported. This is a bit
+ * of a hack, but the simplest way to do this (pushing a stack frame
+ * would be horribly expensive by comparison). We never have to worry
+ * about the case where we're dealing with the global namespace; we've
+ * already checked that we are inside a method.
+ */
+
+ savedNsPtr = iPtr->varFramePtr->nsPtr;
+ iPtr->varFramePtr->nsPtr = (Namespace *)
+ Tcl_GetObjectNamespace(object);
+ varPtr = TclObjLookupVar(interp, argObjs[0], NULL, TCL_NAMESPACE_ONLY,
+ "define", 1, 0, &aryPtr);
+ iPtr->varFramePtr->nsPtr = savedNsPtr;
+
+ if (varPtr == NULL || aryPtr != NULL) {
+ /*
+ * Variable cannot be an element in an array. If aryPtr is not
+ * NULL, it is an element, so throw up an error and return.
+ */
+
+ TclVarErrMsg(interp, TclGetString(argObjs[0]), NULL, "define",
+ "name refers to an element in an array");
+ return TCL_ERROR;
+ }
+
+ /*
+ * Arrange for the lifetime of the variable to be correctly managed.
+ * This is copied out of Tcl_VariableObjCmd...
+ */
+
+ if (!TclIsVarNamespaceVar(varPtr)) {
+ TclSetVarNamespaceVar(varPtr);
+ varPtr->refCount++;
+ }
+
+ if (TclPtrMakeUpvar(interp, varPtr, varName, 0, -1) != TCL_OK) {
+ return TCL_ERROR;
+ }
+ }
+ return TCL_OK;
+}
+
+/*
+ * ----------------------------------------------------------------------
+ *
+ * ObjectVarName --
+ *
+ * Implementation of the oo::object->varname method.
+ *
+ * ----------------------------------------------------------------------
+ */
+
+static int
+ObjectVarName(
+ ClientData clientData, /* Ignored. */
+ Tcl_Interp *interp, /* Interpreter in which to create the object;
+ * also used for error reporting. */
+ Tcl_ObjectContext context, /* The object/call context. */
+ int objc, /* Number of arguments. */
+ Tcl_Obj *const *objv) /* The actual arguments. */
+{
+ Interp *iPtr = (Interp *) interp;
+ Var *varPtr, *aryVar;
+ Tcl_Obj *varNamePtr;
+
+ if (Tcl_ObjectContextSkippedArgs(context)+1 != objc) {
+ Tcl_WrongNumArgs(interp, Tcl_ObjectContextSkippedArgs(context), objv,
+ "varName");
+ return TCL_ERROR;
+ }
+
+ /*
+ * Switch to the object's namespace for the duration of this call. Like
+ * this, the variable is looked up in the namespace of the object, and not
+ * in the namespace of the caller. Otherwise this would only work if the
+ * caller was a method of the object itself, which might not be true if
+ * the method was exported. This is a bit of a hack, but the simplest way
+ * to do this (pushing a stack frame would be horribly expensive by
+ * comparison, and is only done when we'd otherwise interfere with the
+ * global namespace).
+ */
+
+ if (iPtr->varFramePtr == NULL) {
+ Tcl_CallFrame *dummyFrame;
+
+ TclPushStackFrame(interp, &dummyFrame,
+ Tcl_GetObjectNamespace(Tcl_ObjectContextObject(context)),0);
+ varPtr = TclObjLookupVar(interp, objv[objc-1], NULL,
+ TCL_NAMESPACE_ONLY|TCL_LEAVE_ERR_MSG, "refer to",1,1,&aryVar);
+ TclPopStackFrame(interp);
+ } else {
+ Namespace *savedNsPtr;
+
+ savedNsPtr = iPtr->varFramePtr->nsPtr;
+ iPtr->varFramePtr->nsPtr = (Namespace *)
+ Tcl_GetObjectNamespace(Tcl_ObjectContextObject(context));
+ varPtr = TclObjLookupVar(interp, objv[objc-1], NULL,
+ TCL_NAMESPACE_ONLY|TCL_LEAVE_ERR_MSG, "refer to",1,1,&aryVar);
+ iPtr->varFramePtr->nsPtr = savedNsPtr;
+ }
+
+ if (varPtr == NULL) {
+ return TCL_ERROR;
+ }
+
+ TclNewObj(varNamePtr);
+ Tcl_GetVariableFullName(interp, (Tcl_Var) varPtr, varNamePtr);
+ Tcl_SetObjResult(interp, varNamePtr);
+ return TCL_OK;
+}
+
+/*
+ * ----------------------------------------------------------------------
+ *
+ * NextObjCmd --
+ *
+ * Implementation of the [next] command. Note that this command is only
+ * ever to be used inside the body of a procedure-like method.
+ *
+ * ----------------------------------------------------------------------
+ */
+
+static int
+NextObjCmd(
+ ClientData clientData,
+ Tcl_Interp *interp,
+ int objc,
+ Tcl_Obj *const *objv)
+{
+ Interp *iPtr = (Interp *) interp;
+ CallFrame *framePtr = iPtr->varFramePtr, *savedFramePtr;
+ CallContext *contextPtr;
+ int index, result, skip;
+
+ /*
+ * Start with sanity checks on the calling context and the method context.
+ */
+
+ if (framePtr == NULL || !(framePtr->isProcCallFrame & FRAME_IS_METHOD)) {
+ Tcl_AppendResult(interp, TclGetString(objv[0]),
+ " may only be called from inside a method", NULL);
+ return TCL_ERROR;
+ }
+
+ contextPtr = framePtr->ooContextPtr;
+
+ index = contextPtr->index;
+ skip = contextPtr->skip;
+ if (index+1 >= contextPtr->numCallChain) {
+ Tcl_AppendResult(interp, "no superclass ",
+ (contextPtr->flags & CONSTRUCTOR ? "constructor" :
+ (contextPtr->flags & DESTRUCTOR ? "destructor" : "method")),
+ " implementation", NULL);
+ return TCL_ERROR;
+ }
+
+ /*
+ * Advance to the next method implementation in the chain in the method
+ * call context while we process the body. However, need to adjust the
+ * argument-skip control because we're guaranteed to have a single prefix
+ * arg (i.e., 'next') and not the variable amount that can happen because
+ * method invokations (i.e., '$obj meth' and 'my meth'), constructors
+ * (i.e., '$cls new' and '$cls create obj') and destructors (no args at
+ * all) come through the same code. From here on, the skip is always 1.
+ */
+
+ contextPtr->index = index+1;
+ contextPtr->skip = 1;
+
+ /*
+ * Invoke the (advanced) method call context in the caller context. Note
+ * that this is like [uplevel 1] and not [eval].
+ */
+
+ savedFramePtr = iPtr->varFramePtr;
+ iPtr->varFramePtr = savedFramePtr->callerVarPtr;
+ result = TclOOInvokeContext(interp, contextPtr, objc, objv);
+ iPtr->varFramePtr = savedFramePtr;
+
+ /*
+ * Restore the call chain context index as we've finished the inner invoke
+ * and want to operate in the outer context again.
+ */
+
+ contextPtr->index = index;
+ contextPtr->skip = skip;
+
+ return result;
+}
+
+/*
+ * ----------------------------------------------------------------------
+ *
+ * SelfObjCmd --
+ *
+ * Implementation of the [self] command, which provides introspection of
+ * the call context.
+ *
+ * ----------------------------------------------------------------------
+ */
+
+static int
+SelfObjCmd(
+ ClientData clientData,
+ Tcl_Interp *interp,
+ int objc,
+ Tcl_Obj *const *objv)
+{
+ static const char *subcmds[] = {
+ "caller", "class", "filter", "method", "namespace", "next", "object",
+ "target", NULL
+ };
+ enum SelfCmds {
+ SELF_CALLER, SELF_CLASS, SELF_FILTER, SELF_METHOD, SELF_NS, SELF_NEXT,
+ SELF_OBJECT, SELF_TARGET
+ };
+ Interp *iPtr = (Interp *) interp;
+ CallFrame *framePtr = iPtr->varFramePtr;
+ CallContext *contextPtr;
+ int index;
+
+ /*
+ * Start with sanity checks on the calling context and the method context.
+ */
+
+ if (framePtr == NULL || !(framePtr->isProcCallFrame & FRAME_IS_METHOD)) {
+ Tcl_AppendResult(interp, TclGetString(objv[0]),
+ " may only be called from inside a method", NULL);
+ return TCL_ERROR;
+ }
+
+ contextPtr = framePtr->ooContextPtr;
+
+ /*
+ * Now we do "conventional" argument parsing for a while. Note that no
+ * subcommand takes arguments.
+ */
+
+ if (objc > 2) {
+ Tcl_WrongNumArgs(interp, 1, objv, "subcommand");
+ return TCL_ERROR;
+ }
+ if (objc == 1) {
+ index = SELF_OBJECT;
+ } else if (Tcl_GetIndexFromObj(interp, objv[1], subcmds, "subcommand", 0,
+ &index) != TCL_OK) {
+ return TCL_ERROR;
+ }
+
+ switch ((enum SelfCmds) index) {
+ case SELF_OBJECT:
+ Tcl_GetCommandFullName(interp, contextPtr->oPtr->command,
+ Tcl_GetObjResult(interp));
+ return TCL_OK;
+ case SELF_NS:
+ Tcl_SetObjResult(interp, Tcl_NewStringObj(
+ contextPtr->oPtr->namespacePtr->fullName,-1));
+ return TCL_OK;
+ case SELF_CLASS: {
+ Method *mPtr = contextPtr->callChain[contextPtr->index].mPtr;
+ Object *declarerPtr;
+
+ if (mPtr->declaringClassPtr != NULL) {
+ declarerPtr = mPtr->declaringClassPtr->thisPtr;
+ } else if (mPtr->declaringObjectPtr != NULL) {
+ declarerPtr = mPtr->declaringObjectPtr;
+ } else {
+ /*
+ * This should be unreachable code.
+ */
+
+ Tcl_AppendResult(interp, "method without declarer!", NULL);
+ return TCL_ERROR;
+ }
+
+ Tcl_GetCommandFullName(interp, declarerPtr->command,
+ Tcl_GetObjResult(interp));
+ return TCL_OK;
+ }
+ case SELF_METHOD:
+ if (contextPtr->flags & CONSTRUCTOR) {
+ Tcl_AppendResult(interp, "<constructor>", NULL);
+ } else if (contextPtr->flags & DESTRUCTOR) {
+ Tcl_AppendResult(interp, "<destructor>", NULL);
+ } else {
+ Method *mPtr = contextPtr->callChain[contextPtr->index].mPtr;
+
+ Tcl_SetObjResult(interp, mPtr->namePtr);
+ }
+ return TCL_OK;
+ case SELF_FILTER:
+ if (!contextPtr->callChain[contextPtr->index].isFilter) {
+ Tcl_AppendResult(interp, "not inside a filtering context", NULL);
+ return TCL_ERROR;
+ } else {
+ Method *mPtr =
+ contextPtr->callChain[contextPtr->filterLength].mPtr;
+ Tcl_Obj *cmdName;
+
+ // TODO: should indicate who has the filter registration, not the
+ // first non-filter after the filter!
+ TclNewObj(cmdName);
+ Tcl_GetCommandFullName(interp, contextPtr->oPtr->command,
+ cmdName);
+ Tcl_ListObjAppendElement(NULL, Tcl_GetObjResult(interp), cmdName);
+ // TODO: Add what type of filter this is
+ Tcl_ListObjAppendElement(NULL, Tcl_GetObjResult(interp),
+ mPtr->namePtr);
+ return TCL_OK;
+ }
+ case SELF_CALLER:
+ if ((framePtr->callerVarPtr != NULL) &&
+ (framePtr->callerVarPtr->isProcCallFrame & FRAME_IS_METHOD)) {
+ CallContext *callerPtr = framePtr->callerVarPtr->ooContextPtr;
+ Method *mPtr = callerPtr->callChain[callerPtr->index].mPtr;
+ Object *declarerPtr;
+ Tcl_Obj *tmpObj;
+
+ if (mPtr->declaringClassPtr != NULL) {
+ declarerPtr = mPtr->declaringClassPtr->thisPtr;
+ } else if (mPtr->declaringObjectPtr != NULL) {
+ declarerPtr = mPtr->declaringObjectPtr;
+ } else {
+ /*
+ * This should be unreachable code.
+ */
+
+ Tcl_AppendResult(interp, "method without declarer!", NULL);
+ return TCL_ERROR;
+ }
+
+ TclNewObj(tmpObj);
+ Tcl_GetCommandFullName(interp, declarerPtr->command, tmpObj);
+ Tcl_ListObjAppendElement(NULL, Tcl_GetObjResult(interp), tmpObj);
+ TclNewObj(tmpObj);
+ Tcl_GetCommandFullName(interp, callerPtr->oPtr->command, tmpObj);
+ Tcl_ListObjAppendElement(NULL, Tcl_GetObjResult(interp), tmpObj);
+ if (callerPtr->flags & CONSTRUCTOR) {
+ Tcl_ListObjAppendElement(NULL, Tcl_GetObjResult(interp),
+ Tcl_NewStringObj("<constructor>", -1));
+ } else if (callerPtr->flags & DESTRUCTOR) {
+ Tcl_ListObjAppendElement(NULL, Tcl_GetObjResult(interp),
+ Tcl_NewStringObj("<destructor>", -1));
+ } else {
+ Tcl_ListObjAppendElement(NULL, Tcl_GetObjResult(interp),
+ mPtr->namePtr);
+ }
+ return TCL_OK;
+ } else {
+ Tcl_AppendResult(interp, "caller is not an object", NULL);
+ return TCL_ERROR;
+ }
+ case SELF_NEXT:
+ if (contextPtr->index < contextPtr->numCallChain-1) {
+ Method *mPtr = contextPtr->callChain[contextPtr->index+1].mPtr;
+ Object *declarerPtr;
+ Tcl_Obj *tmpObj;
+
+ if (mPtr->declaringClassPtr != NULL) {
+ declarerPtr = mPtr->declaringClassPtr->thisPtr;
+ } else if (mPtr->declaringObjectPtr != NULL) {
+ declarerPtr = mPtr->declaringObjectPtr;
+ } else {
+ /*
+ * This should be unreachable code.
+ */
+
+ Tcl_AppendResult(interp, "method without declarer!", NULL);
+ return TCL_ERROR;
+ }
+
+ TclNewObj(tmpObj);
+ Tcl_GetCommandFullName(interp, declarerPtr->command, tmpObj);
+ Tcl_ListObjAppendElement(NULL, Tcl_GetObjResult(interp), tmpObj);
+ if (contextPtr->flags & CONSTRUCTOR) {
+ Tcl_ListObjAppendElement(NULL, Tcl_GetObjResult(interp),
+ Tcl_NewStringObj("<constructor>", -1));
+ } else if (contextPtr->flags & DESTRUCTOR) {
+ Tcl_ListObjAppendElement(NULL, Tcl_GetObjResult(interp),
+ Tcl_NewStringObj("<destructor>", -1));
+ } else {
+ Tcl_ListObjAppendElement(NULL, Tcl_GetObjResult(interp),
+ mPtr->namePtr);
+ }
+ }
+ return TCL_OK;
+ case SELF_TARGET:
+ if (!contextPtr->callChain[contextPtr->index].isFilter) {
+ Tcl_AppendResult(interp, "not inside a filtering context", NULL);
+ return TCL_ERROR;
+ } else {
+ Method *mPtr;
+ Object *declarerPtr;
+ Tcl_Obj *cmdName;
+ int i;
+
+ for (i=contextPtr->index ; i<contextPtr->numCallChain ; i++) {
+ if (!contextPtr->callChain[i].isFilter) {
+ break;
+ }
+ }
+ if (i == contextPtr->numCallChain) {
+ Tcl_Panic("filtering call chain without terminal non-filter");
+ }
+ mPtr = contextPtr->callChain[i].mPtr;
+ if (mPtr->declaringClassPtr != NULL) {
+ declarerPtr = mPtr->declaringClassPtr->thisPtr;
+ } else if (mPtr->declaringObjectPtr != NULL) {
+ declarerPtr = mPtr->declaringObjectPtr;
+ } else {
+ /*
+ * This should be unreachable code.
+ */
+
+ Tcl_AppendResult(interp, "method without declarer!", NULL);
+ return TCL_ERROR;
+ }
+ TclNewObj(cmdName);
+ Tcl_GetCommandFullName(interp, declarerPtr->command, cmdName);
+ Tcl_ListObjAppendElement(NULL, Tcl_GetObjResult(interp), cmdName);
+ Tcl_ListObjAppendElement(NULL, Tcl_GetObjResult(interp),
+ mPtr->namePtr);
+ return TCL_OK;
+ }
+ }
+ return TCL_ERROR;
+}
+
+/*
+ * ----------------------------------------------------------------------
+ *
+ * Tcl_GetObjectFromObj --
+ *
+ * Utility function to get an object from a Tcl_Obj containing its name.
+ *
+ * ----------------------------------------------------------------------
+ */
+
+Tcl_Object
+Tcl_GetObjectFromObj(
+ Tcl_Interp *interp,
+ Tcl_Obj *objPtr)
+{
+ Command *cmdPtr = (Command *) Tcl_GetCommandFromObj(interp, objPtr);
+
+ if (cmdPtr == NULL || cmdPtr->objProc != PublicObjectCmd) {
+ Tcl_AppendResult(interp, TclGetString(objPtr),
+ " does not refer to an object", NULL);
+ return NULL;
+ }
+ return cmdPtr->objClientData;
+}
+
+/*
+ * ----------------------------------------------------------------------
+ *
+ * TclOOIsReachable --
+ *
+ * Utility function that tests whether a class is a subclass (whether
+ * directly or indirectly) of another class.
+ *
+ * ----------------------------------------------------------------------
+ */
+
+int
+TclOOIsReachable(
+ Class *targetPtr,
+ Class *startPtr)
+{
+ int i;
+ Class *superPtr;
+
+ tailRecurse:
+ if (startPtr == targetPtr) {
+ return 1;
+ }
+ if (startPtr->superclasses.num == 1) {
+ startPtr = startPtr->superclasses.list[0];
+ goto tailRecurse;
+ }
+ FOREACH(superPtr, startPtr->superclasses) {
+ if (TclOOIsReachable(targetPtr, superPtr)) {
+ return 1;
+ }
+ }
+ return 0;
+}
+
+/*
+ * ----------------------------------------------------------------------
+ *
+ * TclOOGetProcFromMethod, TclOOGetFwdFromMethod --
+ *
+ * Utility functions used for procedure-like and forwarding method
+ * introspection.
+ *
+ * ----------------------------------------------------------------------
+ */
+
+Proc *
+TclOOGetProcFromMethod(
+ Method *mPtr)
+{
+ if (mPtr->typePtr == &procMethodType) {
+ ProcedureMethod *pmPtr = mPtr->clientData;
+
+ return pmPtr->procPtr;
+ }
+ return NULL;
+}
+
+Tcl_Obj *
+TclOOGetFwdFromMethod(
+ Method *mPtr)
+{
+ if (mPtr->typePtr == &fwdMethodType) {
+ ForwardMethod *fwPtr = mPtr->clientData;
+
+ return fwPtr->prefixObj;
+ }
+ return NULL;
+}
+
+/*
+ * ----------------------------------------------------------------------
+ *
+ * InitEnsembleRewrite --
+ *
+ * Utility function that wraps up a lot of the complexity involved in
+ * doing ensemble-like command forwarding. Here is a picture of memory
+ * management plan:
+ *
+ * <-----------------objc---------------------->
+ * objv: |=============|===============================|
+ * <-toRewrite-> |
+ * \
+ * <-rewriteLength-> \
+ * rewriteObjs: |=================| \
+ * | |
+ * V V
+ * argObjs: |=================|===============================|
+ * <------------------*lengthPtr------------------->
+ *
+ * ----------------------------------------------------------------------
+ */
+
+static Tcl_Obj **
+InitEnsembleRewrite(
+ Tcl_Interp *interp, /* Place to log the rewrite info. */
+ int objc, /* Number of real arguments. */
+ Tcl_Obj *const *objv, /* The real arguments. */
+ int toRewrite, /* Number of real arguments to replace. */
+ int rewriteLength, /* Number of arguments to insert instead. */
+ Tcl_Obj *const *rewriteObjs,/* Arguments to insert instead. */
+ int *lengthPtr) /* Where to write the resulting length of the
+ * array of rewritten arguments. */
+{
+ Interp *iPtr = (Interp *) interp;
+ int isRootEnsemble = (iPtr->ensembleRewrite.sourceObjs == NULL);
+ Tcl_Obj **argObjs;
+ unsigned len = rewriteLength + objc - toRewrite;
+
+ argObjs = (Tcl_Obj **) ckalloc(sizeof(Tcl_Obj *) * len);
+ memcpy(argObjs, rewriteObjs, rewriteLength * sizeof(Tcl_Obj *));
+ memcpy(argObjs + rewriteLength, objv + toRewrite,
+ sizeof(Tcl_Obj *) * (objc - toRewrite));
+
+ /*
+ * Now plumb this into the core ensemble rewrite logging system so that
+ * Tcl_WrongNumArgs() can rewrite its result appropriately. The rules for
+ * how to store the rewrite rules get complex solely because of the case
+ * where an ensemble rewrites itself out of the picture; when that
+ * happens, the quality of the error message rewrite falls drastically
+ * (and unavoidably).
+ */
+
+ if (isRootEnsemble) {
+ iPtr->ensembleRewrite.sourceObjs = objv;
+ iPtr->ensembleRewrite.numRemovedObjs = toRewrite;
+ iPtr->ensembleRewrite.numInsertedObjs = rewriteLength;
+ } else {
+ int numIns = iPtr->ensembleRewrite.numInsertedObjs;
+
+ if (numIns < toRewrite) {
+ iPtr->ensembleRewrite.numRemovedObjs += toRewrite - numIns;
+ iPtr->ensembleRewrite.numInsertedObjs += rewriteLength - 1;
+ } else {
+ iPtr->ensembleRewrite.numInsertedObjs +=
+ rewriteLength - toRewrite;
+ }
+ }
+
+ *lengthPtr = len;
+ return argObjs;
+}
+
+Tcl_Method
+Tcl_ObjectContextMethod(
+ Tcl_ObjectContext context)
+{
+ CallContext *contextPtr = (CallContext *) context;
+ return (Tcl_Method) contextPtr->callChain[contextPtr->index].mPtr;
+}
+
+int
+Tcl_ObjectContextIsFiltering(
+ Tcl_ObjectContext context)
+{
+ CallContext *contextPtr = (CallContext *) context;
+ return contextPtr->callChain[contextPtr->index].isFilter;
+}
+
+Tcl_Object
+Tcl_ObjectContextObject(
+ Tcl_ObjectContext context)
+{
+ return (Tcl_Object) ((CallContext *)context)->oPtr;
+}
+
+int
+Tcl_ObjectContextSkippedArgs(
+ Tcl_ObjectContext context)
+{
+ return ((CallContext *)context)->skip;
+}
+
+Tcl_Object
+Tcl_MethodDeclarerObject(
+ Tcl_Method method)
+{
+ return (Tcl_Object) ((Method *) method)->declaringObjectPtr;
+}
+
+Tcl_Class
+Tcl_MethodDeclarerClass(
+ Tcl_Method method)
+{
+ return (Tcl_Class) ((Method *) method)->declaringClassPtr;
+}
+
+Tcl_Obj *
+Tcl_MethodName(
+ Tcl_Method method)
+{
+ return ((Method *) method)->namePtr;
+}
+
+int
+Tcl_MethodIsType(
+ Tcl_Method method,
+ const Tcl_MethodType *typePtr,
+ ClientData *clientDataPtr)
+{
+ Method *mPtr = (Method *) method;
+
+ if (mPtr->typePtr == typePtr) {
+ if (clientDataPtr != NULL) {
+ *clientDataPtr = mPtr->clientData;
+ }
+ return 1;
+ }
+ return 0;
+}
+
+int
+Tcl_MethodIsPublic(
+ Tcl_Method method)
+{
+ return (((Method *)method)->flags & PUBLIC_METHOD) ? 1 : 0;
+}
+
+Tcl_Namespace *
+Tcl_GetObjectNamespace(
+ Tcl_Object object)
+{
+ return ((Object *)object)->namespacePtr;
+}
+
+Tcl_Command
+Tcl_GetObjectCommand(
+ Tcl_Object object)
+{
+ return ((Object *)object)->command;
+}
+
+Tcl_Class
+Tcl_GetObjectAsClass(
+ Tcl_Object object)
+{
+ return (Tcl_Class) ((Object *)object)->classPtr;
+}
+
+int
+Tcl_ObjectDeleted(
+ Tcl_Object object)
+{
+ return (((Object *)object)->flags & OBJECT_DELETED) ? 1 : 0;
+}
+
+Tcl_Object
+Tcl_GetClassAsObject(
+ Tcl_Class clazz)
+{
+ return (Tcl_Object) ((Class *)clazz)->thisPtr;
+}
+
+/*
+ * Local Variables:
+ * mode: c
+ * c-basic-offset: 4
+ * fill-column: 78
+ * End:
+ */
diff --git a/generic/tclOO.h b/generic/tclOO.h
new file mode 100644
index 0000000..bfe66d6
--- /dev/null
+++ b/generic/tclOO.h
@@ -0,0 +1,389 @@
+/*
+ * tclOO.h --
+ *
+ * This file contains the structure definitions and some of the function
+ * declarations for the object-system (NB: not Tcl_Obj, but ::oo).
+ *
+ * Copyright (c) 2006 by Donal K. Fellows
+ *
+ * See the file "license.terms" for information on usage and redistribution of
+ * this file, and for a DISCLAIMER OF ALL WARRANTIES.
+ *
+ * RCS: @(#) $Id: tclOO.h,v 1.2 2006/10/20 14:04:01 dkf Exp $
+ */
+
+// vvvvvvvvvvvvvvvvvvvvvv MOVE TO TCL.DECLS vvvvvvvvvvvvvvvvvvvvvv
+Tcl_Object Tcl_CopyObjectInstance(Tcl_Interp *interp,
+ Tcl_Object sourceObject, const char *targetName);
+Tcl_Object Tcl_GetClassAsObject(Tcl_Class clazz);
+Tcl_Class Tcl_GetObjectAsClass(Tcl_Object object);
+Tcl_Command Tcl_GetObjectCommand(Tcl_Object object);
+Tcl_Object Tcl_GetObjectFromObj(Tcl_Interp *interp,
+ Tcl_Obj *objPtr);
+Tcl_Namespace * Tcl_GetObjectNamespace(Tcl_Object object);
+Tcl_Class Tcl_MethodDeclarerClass(Tcl_Method method);
+Tcl_Object Tcl_MethodDeclarerObject(Tcl_Method method);
+int Tcl_MethodIsPublic(Tcl_Method method);
+int Tcl_MethodIsType(Tcl_Method method,
+ const Tcl_MethodType *typePtr,
+ ClientData *clientDataPtr);
+Tcl_Obj * Tcl_MethodName(Tcl_Method method);
+Tcl_Method Tcl_NewMethod(Tcl_Interp *interp, Tcl_Object object,
+ Tcl_Obj *nameObj, int isPublic,
+ const Tcl_MethodType *typePtr,
+ ClientData clientData);
+Tcl_Method Tcl_NewClassMethod(Tcl_Interp *interp, Tcl_Class cls,
+ Tcl_Obj *nameObj, int isPublic,
+ const Tcl_MethodType *typePtr,
+ ClientData clientData);
+Tcl_Object Tcl_NewObjectInstance(Tcl_Interp *interp,
+ Tcl_Class cls, const char *name, int objc,
+ Tcl_Obj *const *objv, int skip);
+int Tcl_ObjectDeleted(Tcl_Object object);
+int Tcl_ObjectContextIsFiltering(
+ Tcl_ObjectContext context);
+Tcl_Method Tcl_ObjectContextMethod(Tcl_ObjectContext context);
+Tcl_Object Tcl_ObjectContextObject(Tcl_ObjectContext context);
+int Tcl_ObjectContextSkippedArgs(
+ Tcl_ObjectContext context);
+ClientData Tcl_ClassGetMetadata(Tcl_Class clazz,
+ const Tcl_ObjectMetadataType *typePtr);
+void Tcl_ClassSetMetadata(Tcl_Class clazz,
+ const Tcl_ObjectMetadataType *typePtr,
+ ClientData metadata);
+ClientData Tcl_ObjectGetMetadata(Tcl_Object object,
+ const Tcl_ObjectMetadataType *typePtr);
+void Tcl_ObjectSetMetadata(Tcl_Object object,
+ const Tcl_ObjectMetadataType *typePtr,
+ ClientData metadata);
+// ^^^^^^^^^^^^^^^^^^^^^^ MOVE TO TCL.DECLS ^^^^^^^^^^^^^^^^^^^^^^
+
+/*
+ * Forward declarations.
+ */
+
+struct Class;
+struct Object;
+
+/*
+ * The data that needs to be stored per method. This record is used to collect
+ * information about all sorts of methods, including forwards, constructors
+ * and destructors.
+ */
+
+typedef struct Method {
+ const Tcl_MethodType *typePtr;
+ /* The type of method. If NULL, this is a
+ * special flag record which is just used for
+ * the setting of the flags field. */
+ ClientData clientData; /* Type-specific data. */
+ Tcl_Obj *namePtr; /* Name of the method. */
+ struct Object *declaringObjectPtr;
+ /* The object that declares this method, or
+ * NULL if it was declared by a class. */
+ struct Class *declaringClassPtr;
+ /* The class that declares this method, or
+ * NULL if it was declared directly on an
+ * object. */
+ int flags; /* Assorted flags. Includes whether this
+ * method is public/exported or not. */
+} Method;
+
+/*
+ * Procedure-like methods have the following extra information. It is a
+ * single-field structure because this allows for future expansion without
+ * changing vast amounts of code.
+ */
+
+typedef struct ProcedureMethod {
+ Proc *procPtr;
+} ProcedureMethod;
+
+/*
+ * Forwarded methods have the following extra information. It is a
+ * single-field structure because this allows for future expansion without
+ * changing vast amounts of code.
+ */
+
+typedef struct ForwardMethod {
+ Tcl_Obj *prefixObj;
+} ForwardMethod;
+
+/*
+ * Helper definitions that declare a "list" array. The two varieties are
+ * either optimized for simplicity (in the case that the whole array is
+ * typically assigned at once) or efficiency (in the case that the array is
+ * expected to be expanded over time). These lists are designed to be iterated
+ * over with the help of the FOREACH macro (see later in this file).
+ *
+ * The "num" field always counts the number of listType_t elements used in the
+ * "list" field. When a "size" field exists, it describes how many elements
+ * are present in the list; when absent, exactly "num" elements are present.
+ */
+
+#define LIST_STATIC(listType_t) \
+ struct { int num; listType_t *list; }
+#define LIST_DYNAMIC(listType_t) \
+ struct { int num, size; listType_t *list; }
+
+/*
+ * Now, the definition of what an object actually is.
+ */
+
+typedef struct Object {
+ Tcl_Namespace *namespacePtr;/* This object's tame namespace. */
+ Tcl_Command command; /* Reference to this object's public
+ * command. */
+ Tcl_Command myCommand; /* Reference to this object's internal
+ * command. */
+ struct Class *selfCls; /* This object's class. */
+ Tcl_HashTable methods; /* Object-local Tcl_Obj (method name) to
+ * Method* mapping. */
+ LIST_STATIC(struct Class *) mixins;
+ /* Classes mixed into this object. */
+ LIST_STATIC(Tcl_Obj *) filters;
+ /* List of filter names. */
+ struct Class *classPtr; /* All classes have this non-NULL; it points
+ * to the class structure. Everything else has
+ * this NULL. */
+ int flags;
+ int epoch; /* Per-object epoch, incremented when the way
+ * an object should resolve call chains is
+ * changed. */
+ Tcl_HashTable *metadataPtr; /* Mapping from pointers to metadata type to
+ * the ClientData values that are the values
+ * of each piece of attached metadata. This
+ * field starts out as NULL and is only
+ * allocated if metadata is attached. */
+ Tcl_HashTable publicContextCache; /* Place to keep unused contexts. */
+ Tcl_HashTable privateContextCache; /* Place to keep unused contexts. */
+} Object;
+
+#define OBJECT_DELETED 1 /* Flag to say that an object has been
+ * destroyed. */
+#define ROOT_OBJECT 0x1000 /* Flag to say that this object is the root of
+ * the class hierarchy and should be treated
+ * specially during teardown. */
+#define FILTER_HANDLING 0x2000 /* Flag set when the object is processing a
+ * filter; when set, filters are *not*
+ * processed on the object, preventing nasty
+ * recursive filtering problems. */
+
+/*
+ * And the definition of a class. Note that every class also has an associated
+ * object, through which it is manipulated.
+ */
+
+typedef struct Class {
+ Object *thisPtr; /* Reference to the object associated with
+ * this class. */
+ int flags; /* Assorted flags. */
+ LIST_STATIC(struct Class *) superclasses;
+ /* List of superclasses, used for generation
+ * of method call chains. */
+ LIST_DYNAMIC(struct Class *) subclasses;
+ /* List of subclasses, used to ensure deletion
+ * of dependent entities happens properly when
+ * the class itself is deleted. */
+ LIST_DYNAMIC(Object *) instances;
+ /* List of instances, used to ensure deletion
+ * of dependent entities happens properly when
+ * the class itself is deleted. */
+ LIST_STATIC(Tcl_Obj *) filters;
+ /* List of filter names, used for generation
+ * of method call chains. */
+ LIST_STATIC(struct Class *) mixins;
+ /* List of mixin classes, used for generation
+ * of method call chains. */
+ LIST_DYNAMIC(struct Class *) mixinSubs;
+ /* List of classes that this class is mixed
+ * into, used to ensure deletion of dependent
+ * entities happens properly when the class
+ * itself is deleted. */
+ LIST_STATIC(struct Class *) classHierarchy;
+ /* List of classes that comprise the basic
+ * class hierarchy for this class's
+ * superclasses. If NULL (and this isn't the
+ * root object class) then this needs
+ * recomputing. */
+ int classHierarchyEpoch; /* Differs from the global epoch when it is
+ * time to recompute the class hierarchy. */
+ Tcl_HashTable classMethods; /* Hash table of all methods. Hash maps from
+ * the (Tcl_Obj*) method name to the (Method*)
+ * method record. */
+ Method *constructorPtr; /* Method record of the class constructor (if
+ * any). */
+ Method *destructorPtr; /* Method record of the class destructor (if
+ * any). */
+ Tcl_HashTable *metadataPtr; /* Mapping from pointers to metadata type to
+ * the ClientData values that are the values
+ * of each piece of attached metadata. This
+ * field starts out as NULL and is only
+ * allocated if metadata is attached. */
+} 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.
+ */
+
+typedef struct Foundation {
+ Class *objectCls; /* The root of the object system. */
+ Class *classCls; /* The class of all classes. */
+ Tcl_Namespace *ooNs; /* Master ::oo namespace. */
+ Tcl_Namespace *defineNs; /* Namespace containing special commands for
+ * manipulating objects and classes. The
+ * "oo::define" command acts as a special kind
+ * of ensemble for this namespace. */
+ Tcl_Namespace *helpersNs; /* Namespace containing the commands that are
+ * only valid when executing inside a
+ * procedural method. */
+ int epoch; /* Used to invalidate method chains when the
+ * class structure changes. */
+ int nsCount; /* Counter so we can allocate a unique
+ * namespace to each object. */
+ Tcl_Obj *unknownMethodNameObj;
+ /* Shared object containing the name of the
+ * unknown method handler method. */
+} Foundation;
+
+/*
+ * A call context structure is built when a method is called. They contain the
+ * chain of method implementations that are to be invoked by a particular
+ * call, and the process of calling walks the chain, with the [next] command
+ * proceeding to the next entry in the chain.
+ */
+
+#define CALL_CHAIN_STATIC_SIZE 4
+
+struct MInvoke {
+ Method *mPtr; /* Reference to the method implementation
+ * record. */
+ int isFilter; /* Whether this is a filter invokation. */
+};
+
+typedef struct CallContext {
+ Object *oPtr; /* The object associated with this call. */
+ int globalEpoch; /* Global (class) epoch counter snapshot. */
+ int localEpoch; /* Local (single object) epoch counter
+ * snapshot. */
+ int flags; /* Assorted flags, see below. */
+ int index; /* Index into the call chain of the currently
+ * executing method implementation. */
+ int skip;
+ int numCallChain; /* Size of the call chain. */
+ struct MInvoke *callChain; /* Array of call chain entries. May point to
+ * staticCallChain if the number of entries is
+ * small. */
+ struct MInvoke staticCallChain[CALL_CHAIN_STATIC_SIZE];
+ int filterLength; /* Number of entries in the call chain that
+ * are due to processing filters and not the
+ * main call chain. */
+} CallContext;
+
+/*
+ * Bits for the 'flags' field of the call context.
+ */
+
+#define OO_UNKNOWN_METHOD 1 /* This is an unknown method. */
+#define PUBLIC_METHOD 2 /* This is a public (exported) method. */
+#define CONSTRUCTOR 4 /* This is a constructor. */
+#define DESTRUCTOR 8 /* This is a destructor. */
+
+/*
+ * Private definitions, some of which perhaps ought to be exposed properly or
+ * maybe just put in the internal stubs table.
+ */
+
+MODULE_SCOPE Method * TclOONewProcMethod(Tcl_Interp *interp, Object *oPtr,
+ int isPublic, Tcl_Obj *nameObj, Tcl_Obj *argsObj,
+ Tcl_Obj *bodyObj);
+MODULE_SCOPE Method * TclOONewForwardMethod(Tcl_Interp *interp, Object *oPtr,
+ int isPublic, Tcl_Obj *nameObj,
+ Tcl_Obj *prefixObj);
+MODULE_SCOPE Method * TclOONewProcClassMethod(Tcl_Interp *interp,
+ Class *clsPtr, int isPublic, Tcl_Obj *nameObj,
+ Tcl_Obj *argsObj, Tcl_Obj *bodyObj);
+MODULE_SCOPE Method * TclOONewForwardClassMethod(Tcl_Interp *interp,
+ Class *clsPtr, int isPublic, Tcl_Obj *nameObj,
+ Tcl_Obj *prefixObj);
+MODULE_SCOPE void TclOODeleteMethod(Method *method);
+MODULE_SCOPE int TclObjInterpProcCore(register Tcl_Interp *interp,
+ CallFrame *framePtr, Tcl_Obj *procNameObj,
+ int skip);
+MODULE_SCOPE void TclOOAddToInstances(Object *oPtr, Class *clsPtr);
+MODULE_SCOPE void TclOOAddToSubclasses(Class *subPtr, Class *superPtr);
+MODULE_SCOPE void TclOOAddToMixinSubs(Class *subPtr, Class *mixinPtr);
+MODULE_SCOPE Proc * TclOOGetProcFromMethod(Method *mPtr);
+MODULE_SCOPE Tcl_Obj * TclOOGetFwdFromMethod(Method *mPtr);
+MODULE_SCOPE int TclOOIsReachable(Class *targetPtr, Class *startPtr);
+MODULE_SCOPE void TclOORemoveFromInstances(Object *oPtr, Class *clsPtr);
+MODULE_SCOPE void TclOORemoveFromSubclasses(Class *subPtr,
+ Class *superPtr);
+MODULE_SCOPE void TclOORemoveFromMixinSubs(Class *subPtr,
+ Class *mixinPtr);
+MODULE_SCOPE void TclOODeleteContext(CallContext *contextPtr);
+MODULE_SCOPE CallContext *TclOOGetCallContext(Foundation *fPtr, Object *oPtr,
+ Tcl_Obj *methodNameObj, int flags,
+ Tcl_HashTable *cachePtr);
+MODULE_SCOPE int TclOOInvokeContext(Tcl_Interp *interp,
+ CallContext *contextPtr, int objc,
+ Tcl_Obj *const *objv);
+MODULE_SCOPE int TclOOGetSortedMethodList(Object *oPtr,
+ int publicOnly, const char ***stringsPtr);
+
+/*
+ * A convenience macro for iterating through the lists used in the internal
+ * memory management of objects. This is a bit gnarly because we want to do
+ * the assignment of the picked-out value only when the body test succeeds,
+ * but we cannot rely on the assigned value being useful, forcing us to do
+ * some nasty stuff with the comma operator. The compiler's optimizer should
+ * be able to sort it all out!
+ *
+ * REQUIRES DECLARATION: int i;
+ */
+
+#define FOREACH(var,ary) \
+ for(i=0 ; (i<(ary).num?((var=(ary).list[i]),1):0) ; i++)
+
+/*
+ * Convenience macros for iterating through hash tables. FOREACH_HASH_DECLS
+ * sets up the declarations needed for the main macro, FOREACH_HASH, which
+ * does the actual iteration. FOREACH_HASH_VALUE is a restricted version that
+ * only iterates over values.
+ */
+
+#define FOREACH_HASH_DECLS \
+ Tcl_HashEntry *hPtr;Tcl_HashSearch search
+#define FOREACH_HASH(key,val,tablePtr) \
+ for(hPtr=Tcl_FirstHashEntry((tablePtr),&search); hPtr!=NULL ? \
+ ((key)=(void *)Tcl_GetHashKey((tablePtr),hPtr),\
+ (val)=Tcl_GetHashValue(hPtr),1):0; hPtr=Tcl_NextHashEntry(&search))
+#define FOREACH_HASH_VALUE(val,tablePtr) \
+ for(hPtr=Tcl_FirstHashEntry((tablePtr),&search); hPtr!=NULL ? \
+ ((val)=Tcl_GetHashValue(hPtr),1):0;hPtr=Tcl_NextHashEntry(&search))
+
+/*
+ * Convenience macro for duplicating a list. Needs no external declaration,
+ * but all arguments are used multiple times and so must have no side effects.
+ */
+
+#define DUPLICATE(target,source,type) \
+ do { \
+ register unsigned len = sizeof(type) * ((target).num=(source).num);\
+ if (len != 0) { \
+ memcpy(((target).list=(type*)ckalloc(len)), (source).list, len); \
+ } else { \
+ (target).list = NULL; \
+ } \
+ } while(0)
+
+/*
+ * Local Variables:
+ * mode: c
+ * c-basic-offset: 4
+ * fill-column: 78
+ * End:
+ */
diff --git a/generic/tclOOCall.c b/generic/tclOOCall.c
new file mode 100644
index 0000000..71663e4
--- /dev/null
+++ b/generic/tclOOCall.c
@@ -0,0 +1,803 @@
+/*
+ * tclOO.c --
+ *
+ * This file contains the method call chain management code for the
+ * object-system core.
+ *
+ * Copyright (c) 2005-2006 by Donal K. Fellows
+ *
+ * See the file "license.terms" for information on usage and redistribution of
+ * this file, and for a DISCLAIMER OF ALL WARRANTIES.
+ *
+ * RCS: @(#) $Id: tclOOCall.c,v 1.2 2006/10/20 14:04:01 dkf Exp $
+ */
+
+#include "tclInt.h"
+#include "tclOO.h"
+
+/*
+ * Extra flags used for call chain management.
+ */
+
+#define DEFINITE_PRIVATE 0x100000
+#define DEFINITE_PUBLIC 0x200000
+#define KNOWN_STATE (DEFINITE_PRIVATE | DEFINITE_PUBLIC)
+#define SPECIAL (CONSTRUCTOR | DESTRUCTOR)
+
+/*
+ * Function declarations for things defined in this file.
+ */
+
+static void AddClassFiltersToCallContext(Object *oPtr,
+ Class *clsPtr, CallContext *contextPtr,
+ Tcl_HashTable *doneFilters);
+static void AddClassMethodNames(Class *clsPtr, int publicOnly,
+ Tcl_HashTable *namesPtr);
+static void AddMethodToCallChain(Method *mPtr,
+ CallContext *contextPtr,
+ Tcl_HashTable *doneFilters);
+static void AddSimpleChainToCallContext(Object *oPtr,
+ Tcl_Obj *methodNameObj, CallContext *contextPtr,
+ Tcl_HashTable *doneFilters, int isPublic);
+static void AddSimpleClassChainToCallContext(Class *classPtr,
+ Tcl_Obj *methodNameObj, CallContext *contextPtr,
+ Tcl_HashTable *doneFilters, int isPublic);
+static int CmpStr(const void *ptr1, const void *ptr2);
+static void InitClassHierarchy(Foundation *fPtr, Class *classPtr);
+
+/*
+ * ----------------------------------------------------------------------
+ *
+ * TclOODeleteContext --
+ *
+ * Destroys a method call-chain context, which should not be in use.
+ *
+ * ----------------------------------------------------------------------
+ */
+
+void
+TclOODeleteContext(
+ CallContext *contextPtr)
+{
+ if (contextPtr->callChain != contextPtr->staticCallChain) {
+ ckfree((char *) contextPtr->callChain);
+ }
+ ckfree((char *) contextPtr);
+}
+
+/*
+ * ----------------------------------------------------------------------
+ *
+ * TclOOInvokeContext --
+ *
+ * Invokes a single step along a method call-chain context. Note that the
+ * invokation of a step along the chain can cause further steps along the
+ * chain to be invoked. Note that this function is written to be as light
+ * in stack usage as possible.
+ *
+ * ----------------------------------------------------------------------
+ */
+
+int
+TclOOInvokeContext(
+ Tcl_Interp *interp, /* Interpreter for error reporting, and many
+ * other sorts of context handling (e.g.,
+ * commands, variables) depending on method
+ * implementation. */
+ CallContext *contextPtr, /* The method call context. */
+ int objc, /* The number of arguments. */
+ Tcl_Obj *const *objv) /* The arguments as actually seen. */
+{
+ Method *mPtr = contextPtr->callChain[contextPtr->index].mPtr;
+ int result, isFirst = (contextPtr->index == 0);
+ int isFilter = contextPtr->callChain[contextPtr->index].isFilter;
+ int wasFilter;
+
+ /*
+ * If this is the first step along the chain, we preserve the method
+ * entries in the chain so that they do not get deleted out from under our
+ * feet.
+ */
+
+ if (isFirst) {
+ int i;
+
+ for (i=0 ; i<contextPtr->numCallChain ; i++) {
+ Tcl_Preserve(contextPtr->callChain[i].mPtr);
+ }
+ }
+
+ /*
+ * Save whether we were in a filter and set up whether we are now.
+ */
+
+ wasFilter = contextPtr->oPtr->flags & FILTER_HANDLING;
+ if (isFilter || contextPtr->flags & FILTER_HANDLING) {
+ contextPtr->oPtr->flags |= FILTER_HANDLING;
+ } else {
+ contextPtr->oPtr->flags &= ~FILTER_HANDLING;
+ }
+
+ /*
+ * Run the method implementation.
+ */
+
+ result = mPtr->typePtr->callProc(mPtr->clientData, interp,
+ (Tcl_ObjectContext) contextPtr, objc, objv);
+
+ /*
+ * Restore the old filter-ness, release any locks on method
+ * implementations, and return the result code.
+ */
+
+ if (wasFilter) {
+ contextPtr->oPtr->flags |= FILTER_HANDLING;
+ } else {
+ contextPtr->oPtr->flags &= ~FILTER_HANDLING;
+ }
+ if (isFirst) {
+ int i;
+
+ for (i=0 ; i<contextPtr->numCallChain ; i++) {
+ Tcl_Release(contextPtr->callChain[i].mPtr);
+ }
+ }
+ return result;
+}
+
+static void
+InitClassHierarchy(
+ Foundation *fPtr,
+ Class *classPtr)
+{
+ if (classPtr == fPtr->objectCls) {
+ return;
+ }
+ if (classPtr->classHierarchyEpoch != fPtr->epoch) {
+ int i;
+ Class *superPtr;
+
+ if (classPtr->classHierarchy.num != 0) {
+ ckfree((char *) classPtr->classHierarchy.list);
+ }
+ FOREACH(superPtr, classPtr->superclasses) {
+ InitClassHierarchy(fPtr, superPtr);
+ }
+ if (i == 1) {
+ Class **hierlist = (Class **)
+ ckalloc(sizeof(Class*) * (1+superPtr->classHierarchy.num));
+
+ hierlist[0] = superPtr;
+ memcpy(hierlist+1, superPtr->classHierarchy.list,
+ sizeof(Class*) * superPtr->classHierarchy.num);
+ classPtr->classHierarchy.num = 1 + superPtr->classHierarchy.num;
+ classPtr->classHierarchy.list = hierlist;
+ classPtr->classHierarchyEpoch = fPtr->epoch;
+ return;
+ } else {
+ int num = classPtr->superclasses.num, j = 0, k, realNum;
+ Class **hierlist; /* Temporary work space. */
+
+ FOREACH(superPtr, classPtr->superclasses) {
+ num += superPtr->classHierarchy.num;
+ }
+ hierlist = (Class **) ckalloc(sizeof(Class *) * num);
+ FOREACH(superPtr, classPtr->superclasses) {
+ hierlist[j++] = superPtr;
+ if (superPtr == fPtr->objectCls) {
+ continue;
+ }
+ memcpy(hierlist+j, superPtr->classHierarchy.list,
+ sizeof(Class *) * superPtr->classHierarchy.num);
+ j += superPtr->classHierarchy.num;
+ }
+ realNum = num;
+ for (j=0 ; j<num-1 ; j++) {
+ for (k=num-1 ; k>j ; k--) {
+ if (hierlist[j] == hierlist[k]) {
+ hierlist[j] = NULL;
+ realNum--;
+ break;
+ }
+ }
+ }
+ classPtr->classHierarchy.num = realNum;
+ classPtr->classHierarchy.list = (Class **)
+ ckalloc(sizeof(Class *) * realNum);
+ for (j=k=0 ; j<num ; j++) {
+ if (hierlist[j] != NULL) {
+ classPtr->classHierarchy.list[k++] = hierlist[j];
+ }
+ }
+ ckfree((char *) hierlist);
+ }
+ }
+}
+
+/*
+ * ----------------------------------------------------------------------
+ *
+ * TclOOGetSortedMethodList --
+ *
+ * Discovers the list of method names supported by an object.
+ *
+ * ----------------------------------------------------------------------
+ */
+
+int
+TclOOGetSortedMethodList(
+ Object *oPtr, /* The object to get the method names for. */
+ int publicOnly, /* Whether we just want the public method
+ * names. */
+ const char ***stringsPtr) /* Where to write a pointer to the array of
+ * strings to. */
+{
+ Tcl_HashTable names;
+ FOREACH_HASH_DECLS;
+ int i;
+ const char **strings;
+ Class *mixinPtr;
+ Tcl_Obj *namePtr;
+ Method *mPtr;
+ void *isWanted;
+
+ Tcl_InitObjHashTable(&names);
+
+ FOREACH_HASH(namePtr, mPtr, &oPtr->methods) {
+ int isNew;
+
+ hPtr = Tcl_CreateHashEntry(&names, (char *) namePtr, &isNew);
+ if (isNew) {
+ isWanted = (void *) (!publicOnly || mPtr->flags & PUBLIC_METHOD);
+ Tcl_SetHashValue(hPtr, isWanted);
+ }
+ }
+
+ AddClassMethodNames(oPtr->selfCls, publicOnly, &names);
+ FOREACH(mixinPtr, oPtr->mixins) {
+ AddClassMethodNames(mixinPtr, publicOnly, &names);
+ }
+
+ if (names.numEntries == 0) {
+ Tcl_DeleteHashTable(&names);
+ return 0;
+ }
+
+ strings = (const char **) ckalloc(sizeof(char *) * names.numEntries);
+ i = 0;
+ FOREACH_HASH(namePtr, isWanted, &names) {
+ if (!publicOnly || isWanted) {
+ strings[i++] = TclGetString(namePtr);
+ }
+ }
+
+ /*
+ * Note that 'i' may well be less than names.numEntries when we are
+ * dealing with public method names.
+ */
+
+ qsort(strings, (unsigned) i, sizeof(char *), CmpStr);
+
+ Tcl_DeleteHashTable(&names);
+ *stringsPtr = strings;
+ return i;
+}
+
+/* Comparator for GetSortedMethodList */
+static int
+CmpStr(
+ const void *ptr1,
+ const void *ptr2)
+{
+ const char **strPtr1 = (const char **) ptr1;
+ const char **strPtr2 = (const char **) ptr2;
+
+ return TclpUtfNcmp2(*strPtr1, *strPtr2, strlen(*strPtr1)+1);
+}
+
+/*
+ * ----------------------------------------------------------------------
+ *
+ * AddClassMethodNames --
+ *
+ * Adds the method names defined by a class (or its superclasses) to the
+ * collection being built. The collection is built in a hash table to
+ * ensure that duplicates are excluded. Helper for GetSortedMethodList().
+ *
+ * ----------------------------------------------------------------------
+ */
+
+static void
+AddClassMethodNames(
+ Class *clsPtr, /* Class to get method names from. */
+ const int publicOnly, /* Whether we are interested in just the
+ * public method names. */
+ Tcl_HashTable *const namesPtr)
+ /* Reference to the hash table to put the
+ * information in. The hash table maps the
+ * Tcl_Obj * method name to an integral value
+ * describing whether the method is wanted.
+ * This ensures that public/private override
+ * semantics are handled correctly.*/
+{
+ /*
+ * Scope all declarations so that the compiler can stand a good chance of
+ * making the recursive step highly efficient. We also hand-implement the
+ * tail-recursive case using a while loop; C compilers typically cannot do
+ * tail-recursion optimization usefully.
+ */
+
+ if (clsPtr->mixins.num != 0) {
+ Class *mixinPtr;
+ int i;
+
+ // TODO: Beware of infinite loops!
+ FOREACH(mixinPtr, clsPtr->mixins) {
+ AddClassMethodNames(mixinPtr, publicOnly, namesPtr);
+ }
+ }
+
+ while (1) {
+ FOREACH_HASH_DECLS;
+ Tcl_Obj *namePtr;
+ Method *mPtr;
+
+ FOREACH_HASH(namePtr, mPtr, &clsPtr->classMethods) {
+ int isNew;
+
+ hPtr = Tcl_CreateHashEntry(namesPtr, (char *) namePtr, &isNew);
+ if (isNew) {
+ int isWanted = (!publicOnly || mPtr->flags & PUBLIC_METHOD);
+
+ Tcl_SetHashValue(hPtr, (void *) isWanted);
+ }
+ }
+
+ if (clsPtr->superclasses.num != 1) {
+ break;
+ }
+ clsPtr = clsPtr->superclasses.list[0];
+ }
+ if (clsPtr->superclasses.num != 0) {
+ Class *superPtr;
+ int i;
+
+ FOREACH(superPtr, clsPtr->superclasses) {
+ AddClassMethodNames(superPtr, publicOnly, namesPtr);
+ }
+ }
+}
+
+/*
+ * ----------------------------------------------------------------------
+ *
+ * TclOOGetCallContext --
+ *
+ * Responsible for constructing the call context, an ordered list of all
+ * method implementations to be called as part of a method invokation.
+ * This method is central to the whole operation of the OO system.
+ *
+ * ----------------------------------------------------------------------
+ */
+
+CallContext *
+TclOOGetCallContext(
+ Foundation *fPtr, /* The foundation of the object system. */
+ Object *oPtr, /* The object to get the context for. */
+ Tcl_Obj *methodNameObj, /* The name of the method to get the context
+ * for. NULL when getting a constructor or
+ * destructor chain. */
+ int flags, /* What sort of context are we looking for.
+ * Only the bits OO_PUBLIC_METHOD,
+ * CONSTRUCTOR, DESTRUCTOR and FILTER_HANDLING
+ * are useful. */
+ Tcl_HashTable *cachePtr) /* Where to cache the chain. Ignored for both
+ * constructors and destructors. */
+{
+ CallContext *contextPtr;
+ int i, count, doFilters;
+ Tcl_HashEntry *hPtr;
+ Tcl_HashTable doneFilters;
+
+ if (flags&(SPECIAL|FILTER_HANDLING) || (oPtr->flags&FILTER_HANDLING)) {
+ hPtr = NULL;
+ doFilters = 0;
+ } else {
+ doFilters = 1;
+ hPtr = Tcl_FindHashEntry(cachePtr, (char *) methodNameObj);
+ if (hPtr != NULL && Tcl_GetHashValue(hPtr) != NULL) {
+ contextPtr = Tcl_GetHashValue(hPtr);
+ Tcl_SetHashValue(hPtr, NULL);
+ if ((contextPtr->globalEpoch == fPtr->epoch)
+ && (contextPtr->localEpoch == oPtr->epoch)) {
+ return contextPtr;
+ }
+ TclOODeleteContext(contextPtr);
+ }
+ }
+ contextPtr = (CallContext *) ckalloc(sizeof(CallContext));
+ contextPtr->numCallChain = 0;
+ contextPtr->callChain = contextPtr->staticCallChain;
+ contextPtr->filterLength = 0;
+ contextPtr->globalEpoch = fPtr->epoch;
+ contextPtr->localEpoch = oPtr->epoch;
+ contextPtr->flags = 0;
+ contextPtr->skip = 2;
+ if (flags & (PUBLIC_METHOD | SPECIAL | FILTER_HANDLING)) {
+ contextPtr->flags |= flags & (PUBLIC_METHOD|SPECIAL|FILTER_HANDLING);
+ }
+ contextPtr->oPtr = oPtr;
+ contextPtr->index = 0;
+
+ /*
+ * Ensure that the class hierarchy is trivially iterable.
+ */
+
+ InitClassHierarchy(fPtr, oPtr->selfCls);
+
+ /*
+ * Add all defined filters (if any, and if we're going to be processing
+ * them; they're not processed for constructors, destructors or when we're
+ * in the middle of processing a filter).
+ */
+
+ if (doFilters) {
+ Tcl_Obj *filterObj;
+ Class *mixinPtr;
+
+ doFilters = 1;
+ Tcl_InitObjHashTable(&doneFilters);
+ FOREACH(mixinPtr, oPtr->mixins) {
+ AddClassFiltersToCallContext(oPtr, mixinPtr, contextPtr,
+ &doneFilters);
+ }
+ FOREACH(filterObj, oPtr->filters) {
+ AddSimpleChainToCallContext(oPtr, filterObj, contextPtr,
+ &doneFilters, 0);
+ }
+ AddClassFiltersToCallContext(oPtr, oPtr->selfCls, contextPtr,
+ &doneFilters);
+ Tcl_DeleteHashTable(&doneFilters);
+ }
+ count = contextPtr->filterLength = contextPtr->numCallChain;
+
+ /*
+ * Add the actual method implementations.
+ */
+
+ AddSimpleChainToCallContext(oPtr, methodNameObj, contextPtr, NULL, flags);
+
+ /*
+ * Check to see if the method has no implementation. If so, we probably
+ * need to add in a call to the unknown method. Otherwise, set up the
+ * cacheing of the method implementation (if relevant).
+ */
+
+ if (count == contextPtr->numCallChain) {
+ /*
+ * Method does not actually exist. If we're dealing with constructors
+ * or destructors, this isn't a problem.
+ */
+
+ if (flags & SPECIAL) {
+ TclOODeleteContext(contextPtr);
+ return NULL;
+ }
+ AddSimpleChainToCallContext(oPtr, fPtr->unknownMethodNameObj,
+ contextPtr, NULL, 0);
+ contextPtr->flags |= OO_UNKNOWN_METHOD;
+ contextPtr->globalEpoch = -1;
+ if (count == contextPtr->numCallChain) {
+ TclOODeleteContext(contextPtr);
+ return NULL;
+ }
+ } else if (doFilters) {
+ if (hPtr == NULL) {
+ hPtr = Tcl_CreateHashEntry(cachePtr, (char *) methodNameObj, &i);
+ }
+ Tcl_SetHashValue(hPtr, NULL);
+ }
+ return contextPtr;
+}
+
+/*
+ * ----------------------------------------------------------------------
+ *
+ * AddClassFiltersToCallContext --
+ *
+ * Logic to make extracting all the filters from the class context much
+ * easier.
+ *
+ * ----------------------------------------------------------------------
+ */
+
+static void
+AddClassFiltersToCallContext(
+ Object *const oPtr, /* Object that the filters operate on. */
+ Class *clsPtr, /* Class to get the filters from. */
+ CallContext *const contextPtr,
+ /* Context to fill with call chain entries. */
+ Tcl_HashTable *const doneFilters)
+ /* Where to record what filters have been
+ * processed. Keys are objects, values are
+ * ignored. */
+{
+ int i;
+ Class *superPtr;
+ Tcl_Obj *filterObj;
+
+ tailRecurse:
+ if (clsPtr == NULL) {
+ return;
+ }
+
+ /*
+ * Add all the class filters from the current class. Note that the filters
+ * are added starting at the object root, as this allows the object to
+ * override how filters work to extend their behaviour.
+ */
+
+ FOREACH(filterObj, clsPtr->filters) {
+ int isNew;
+
+ (void) Tcl_CreateHashEntry(doneFilters, (char *) filterObj, &isNew);
+ if (isNew) {
+ AddSimpleChainToCallContext(oPtr, filterObj, contextPtr,
+ doneFilters, 0);
+ }
+ }
+
+ /*
+ * Now process the recursive case. Notice the tail-call optimization.
+ */
+
+ switch (clsPtr->superclasses.num) {
+ case 1:
+ clsPtr = clsPtr->superclasses.list[0];
+ goto tailRecurse;
+ default:
+ FOREACH(superPtr, clsPtr->superclasses) {
+ AddClassFiltersToCallContext(oPtr, superPtr, contextPtr,
+ doneFilters);
+ }
+ case 0:
+ return;
+ }
+}
+
+/*
+ * ----------------------------------------------------------------------
+ *
+ * AddSimpleChainToCallContext --
+ *
+ * The core of the call-chain construction engine, this handles calling a
+ * particular method on a particular object. Note that filters and
+ * unknown handling are already handled by the logic that uses this
+ * function.
+ *
+ * ----------------------------------------------------------------------
+ */
+
+static void
+AddSimpleChainToCallContext(
+ Object *oPtr, /* Object to add call chain entries for. */
+ Tcl_Obj *methodNameObj, /* Name of method to add the call chain
+ * entries for. */
+ CallContext *contextPtr, /* Where to add the call chain entries. */
+ Tcl_HashTable *doneFilters, /* Where to record what call chain entries
+ * have been processed. */
+ int flags) /* What sort of call chain are we building. */
+{
+ int i;
+
+ if (!(flags & (KNOWN_STATE | SPECIAL))) {
+ Tcl_HashEntry *hPtr = Tcl_FindHashEntry(&oPtr->methods,
+ (char *) methodNameObj);
+
+ if (hPtr != NULL) {
+ Method *mPtr = Tcl_GetHashValue(hPtr);
+
+ if (flags & PUBLIC_METHOD) {
+ if (!(mPtr->flags & PUBLIC_METHOD)) {
+ return;
+ } else {
+ flags |= DEFINITE_PUBLIC;
+ }
+ } else {
+ flags |= DEFINITE_PRIVATE;
+ }
+ }
+ }
+ if (!(flags & SPECIAL)) {
+ Tcl_HashEntry *hPtr;
+ Class *mixinPtr, *superPtr;
+
+ FOREACH(mixinPtr, oPtr->mixins) {
+ AddSimpleClassChainToCallContext(mixinPtr, methodNameObj,
+ contextPtr, doneFilters, flags);
+ }
+ FOREACH(mixinPtr, oPtr->selfCls->mixins) {
+ AddSimpleClassChainToCallContext(mixinPtr, methodNameObj,
+ contextPtr, doneFilters, flags);
+ }
+ FOREACH(superPtr, oPtr->selfCls->classHierarchy) {
+ int j=i;// HACK: save index so we can nest FOREACHes
+ FOREACH(mixinPtr, superPtr->mixins) {
+ AddSimpleClassChainToCallContext(mixinPtr, methodNameObj,
+ contextPtr, doneFilters, flags);
+ }
+ i=j;
+ }
+ hPtr = Tcl_FindHashEntry(&oPtr->methods, (char *) methodNameObj);
+ if (hPtr != NULL) {
+ AddMethodToCallChain(Tcl_GetHashValue(hPtr), contextPtr,
+ doneFilters);
+ }
+ }
+ AddSimpleClassChainToCallContext(oPtr->selfCls, methodNameObj, contextPtr,
+ doneFilters, flags);
+}
+
+/*
+ * ----------------------------------------------------------------------
+ *
+ * AddSimpleClassChainToCallContext --
+ *
+ * Construct a call-chain from a class hierarchy.
+ *
+ * ----------------------------------------------------------------------
+ */
+
+static void
+AddSimpleClassChainToCallContext(
+ Class *classPtr, /* Class to add the call chain entries for. */
+ Tcl_Obj *const methodNameObj,
+ /* Name of method to add the call chain
+ * entries for. */
+ CallContext *const contextPtr,
+ /* Where to add the call chain entries. */
+ Tcl_HashTable *const doneFilters,
+ /* Where to record what call chain entries
+ * have been processed. */
+ int flags) /* What sort of call chain are we building. */
+{
+ /*
+ * We hard-code the tail-recursive form. It's by far the most common case
+ * *and* it is much more gentle on the stack.
+ */
+
+ tailRecurse:
+ if (flags & CONSTRUCTOR) {
+ AddMethodToCallChain(classPtr->constructorPtr, contextPtr,
+ doneFilters);
+ } else if (flags & DESTRUCTOR) {
+ AddMethodToCallChain(classPtr->destructorPtr, contextPtr,
+ doneFilters);
+ } else {
+ Tcl_HashEntry *hPtr = Tcl_FindHashEntry(&classPtr->classMethods,
+ (char *) methodNameObj);
+
+ if (hPtr != NULL) {
+ register Method *mPtr = Tcl_GetHashValue(hPtr);
+
+ if (!(flags & KNOWN_STATE)) {
+ if (flags & PUBLIC_METHOD) {
+ if (mPtr->flags & PUBLIC_METHOD) {
+ flags |= DEFINITE_PUBLIC;
+ } else {
+ return;
+ }
+ } else {
+ flags |= DEFINITE_PRIVATE;
+ }
+ }
+ AddMethodToCallChain(mPtr, contextPtr, doneFilters);
+ }
+ }
+
+ switch (classPtr->superclasses.num) {
+ case 1:
+ classPtr = classPtr->superclasses.list[0];
+ goto tailRecurse;
+ default:
+ {
+ int i;
+ Class *superPtr;
+
+ FOREACH(superPtr, classPtr->superclasses) {
+ AddSimpleClassChainToCallContext(superPtr, methodNameObj,
+ contextPtr, doneFilters, flags);
+ }
+ }
+ case 0:
+ return;
+ }
+}
+
+/*
+ * ----------------------------------------------------------------------
+ *
+ * AddMethodToCallChain --
+ *
+ * Utility method that manages the adding of a particular method
+ * implementation to a call-chain.
+ *
+ * ----------------------------------------------------------------------
+ */
+
+static void
+AddMethodToCallChain(
+ Method *mPtr, /* Actual method implementation to add to call
+ * chain (or NULL, a no-op). */
+ CallContext *contextPtr, /* The call chain to add the method
+ * implementation to. */
+ Tcl_HashTable *doneFilters) /* Where to record what filters have been
+ * processed. If NULL, not processing filters.
+ * Note that this function does not update
+ * this hashtable. */
+{
+ int i;
+
+ /*
+ * Return if this is just an entry used to record whether this is a public
+ * method. If so, there's nothing real to call and so nothing to add to
+ * the call chain.
+ */
+
+ if (mPtr == NULL || mPtr->typePtr == NULL) {
+ return;
+ }
+
+ /*
+ * First test whether the method is already in the call chain. Skip over
+ * any leading filters.
+ */
+
+ for (i=contextPtr->filterLength ; i<contextPtr->numCallChain ; i++) {
+ if (contextPtr->callChain[i].mPtr == mPtr
+ && contextPtr->callChain[i].isFilter == (doneFilters!=NULL)) {
+ /*
+ * Call chain semantics states that methods come as *late* in the
+ * call chain as possible. This is done by copying down the
+ * following methods. Note that this does not change the number of
+ * method invokations in the call chain; it just rearranges them.
+ */
+
+ for (; i+1<contextPtr->numCallChain ; i++) {
+ contextPtr->callChain[i] = contextPtr->callChain[i+1];
+ }
+ contextPtr->callChain[i].mPtr = mPtr;
+ contextPtr->callChain[i].isFilter = (doneFilters != NULL);
+ return;
+ }
+ }
+
+ /*
+ * Need to really add the method. This is made a bit more complex by the
+ * fact that we are using some "static" space initially, and only start
+ * realloc-ing if the chain gets long.
+ */
+
+ if (contextPtr->numCallChain == CALL_CHAIN_STATIC_SIZE) {
+ contextPtr->callChain = (struct MInvoke *)
+ ckalloc(sizeof(struct MInvoke)*(contextPtr->numCallChain+1));
+ memcpy(contextPtr->callChain, contextPtr->staticCallChain,
+ sizeof(struct MInvoke) * (contextPtr->numCallChain + 1));
+ } else if (contextPtr->numCallChain > CALL_CHAIN_STATIC_SIZE) {
+ contextPtr->callChain = (struct MInvoke *)
+ ckrealloc((char *) contextPtr->callChain,
+ sizeof(struct MInvoke) * (contextPtr->numCallChain + 1));
+ }
+ contextPtr->callChain[contextPtr->numCallChain].mPtr = mPtr;
+ contextPtr->callChain[contextPtr->numCallChain].isFilter =
+ (doneFilters != NULL);
+ contextPtr->numCallChain++;
+}
+
+/*
+ * Local Variables:
+ * mode: c
+ * c-basic-offset: 4
+ * fill-column: 78
+ * End:
+ */
diff --git a/generic/tclOODefineCmds.c b/generic/tclOODefineCmds.c
new file mode 100644
index 0000000..9f2635b
--- /dev/null
+++ b/generic/tclOODefineCmds.c
@@ -0,0 +1,953 @@
+/*
+ * tclOODefineCmds.c --
+ *
+ * This file contains the implementation of the ::oo::define command,
+ * part of the object-system core (NB: not Tcl_Obj, but ::oo).
+ *
+ * Copyright (c) 2006 by Donal K. Fellows
+ *
+ * See the file "license.terms" for information on usage and redistribution of
+ * this file, and for a DISCLAIMER OF ALL WARRANTIES.
+ *
+ * RCS: @(#) $Id: tclOODefineCmds.c,v 1.2 2006/10/20 14:04:01 dkf Exp $
+ */
+
+#include "tclInt.h"
+#include "tclOO.h"
+
+static Object * GetDefineCmdContext(Tcl_Interp *interp);
+
+int
+TclOODefineObjCmd(
+ ClientData clientData,
+ Tcl_Interp *interp,
+ int objc,
+ Tcl_Obj *const *objv)
+{
+ CallFrame *framePtr, **framePtrPtr;
+ Foundation *fPtr = ((Interp *) interp)->ooFoundation;
+ int result;
+ Object *oPtr;
+
+ 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::define namespace the current namespace and evaluate the
+ * command(s).
+ */
+
+ /* This is needed to satisfy GCC 3.3's strict aliasing rules */
+ framePtrPtr = &framePtr;
+ result = TclPushStackFrame(interp, (Tcl_CallFrame **) framePtrPtr,
+ (Tcl_Namespace *) fPtr->defineNs, FRAME_IS_OO_DEFINE);
+ if (result != TCL_OK) {
+ return TCL_ERROR;
+ }
+ framePtr->ooContextPtr = oPtr;
+ framePtr->objc = objc;
+ framePtr->objv = objv; /* Reference counts do not need to be
+ * incremented here. */
+
+ if (objc == 3) {
+ result = Tcl_EvalObjEx(interp, objv[2], 0);
+
+ if (result == TCL_ERROR) {
+ int length;
+ const char *objName = Tcl_GetStringFromObj(objv[1], &length);
+ int limit = 200;
+ int overflow = (length > limit);
+
+ TclFormatToErrorInfo(interp,
+ "\n (in definition script for object \"%.*s%s\" line %d)",
+ (overflow ? limit : length), objName,
+ (overflow ? "..." : ""), interp->errorLine);
+ }
+ } else {
+ Tcl_Obj *objPtr, *obj2Ptr, **objs;
+ Interp *iPtr = (Interp *) interp;
+ Tcl_Command cmd;
+ int dummy;
+
+ /*
+ * More than one argument: fire them through the ensemble processing
+ * engine so that everything appears to be good and proper in error
+ * messages. Note that we cannot just concatenate and send through
+ * Tcl_EvalObjEx, as that doesn't do ensemble processing, and we
+ * cannot go through Tcl_EvalObjv without the extra work to pre-find
+ * the command, as that finds command names in the wrong namespace at
+ * the moment. Ugly!
+ */
+
+ if (iPtr->ensembleRewrite.sourceObjs == NULL) {
+ iPtr->ensembleRewrite.sourceObjs = objv;
+ iPtr->ensembleRewrite.numRemovedObjs = 3;
+ iPtr->ensembleRewrite.numInsertedObjs = 1;
+ } else {
+ int ni = iPtr->ensembleRewrite.numInsertedObjs;
+ if (ni < 3) {
+ iPtr->ensembleRewrite.numRemovedObjs += 3 - ni;
+ } else {
+ iPtr->ensembleRewrite.numInsertedObjs -= 2;
+ }
+ }
+
+ /*
+ * Build the list of arguments using a Tcl_Obj as a workspace. See
+ * comments above for why these contortions are necessary.
+ */
+
+ TclNewObj(objPtr);
+ TclNewObj(obj2Ptr);
+ cmd = Tcl_FindCommand(interp, TclGetString(objv[2]), fPtr->defineNs,
+ TCL_NAMESPACE_ONLY);
+ if (cmd == NULL) {
+ /* punt this case! */
+ Tcl_AppendObjToObj(obj2Ptr, objv[2]);
+ } else {
+ Tcl_GetCommandFullName(interp, cmd, obj2Ptr);
+ }
+ Tcl_ListObjAppendElement(NULL, objPtr, obj2Ptr);
+ Tcl_ListObjReplace(NULL, objPtr, 1, 0, objc-3, objv+3);
+ Tcl_ListObjGetElements(NULL, objPtr, &dummy, &objs);
+
+ result = Tcl_EvalObjv(interp, objc-2, objs, TCL_EVAL_INVOKE);
+ TclDecrRefCount(objPtr);
+ }
+
+ /*
+ * Restore the previous "current" namespace.
+ */
+
+ TclPopStackFrame(interp);
+ return result;
+}
+
+static Object *
+GetDefineCmdContext(
+ Tcl_Interp *interp)
+{
+ Interp *iPtr = (Interp *) interp;
+
+ if ((iPtr->framePtr == NULL)
+ || (iPtr->framePtr->isProcCallFrame != FRAME_IS_OO_DEFINE)) {
+ Tcl_AppendResult(interp, "this command may only be called from within"
+ " the context of the ::oo::define command", NULL);
+ return NULL;
+ }
+ return (Object *) iPtr->framePtr->ooContextPtr;
+}
+
+int
+TclOODefineConstructorObjCmd(
+ ClientData clientData,
+ Tcl_Interp *interp,
+ int objc,
+ Tcl_Obj *const *objv)
+{
+ Object *oPtr;
+ Class *clsPtr;
+ int bodyLength;
+
+ if (objc != 3) {
+ Tcl_WrongNumArgs(interp, 1, objv, "arguments body");
+ return TCL_ERROR;
+ }
+
+ /*
+ * Extract and validate the context, which is the class that we wish to
+ * modify.
+ */
+
+ oPtr = GetDefineCmdContext(interp);
+ if (oPtr == NULL) {
+ return TCL_ERROR;
+ }
+ if (oPtr->classPtr == NULL) {
+ Tcl_AppendResult(interp, "only classes may have constructors defined",
+ NULL);
+ return TCL_ERROR;
+ }
+ clsPtr = oPtr->classPtr;
+
+ (void) Tcl_GetStringFromObj(objv[2], &bodyLength);
+ if (bodyLength > 0) {
+ /*
+ * Create the method structure.
+ */
+
+ Method *mPtr;
+
+ mPtr = TclOONewProcClassMethod(interp, clsPtr, 1, NULL, objv[1],
+ objv[2]);
+ if (mPtr == NULL) {
+ return TCL_ERROR;
+ }
+
+ /*
+ * Place the method structure in the class record. Note that we might
+ * not immediately delete the constructor as this might be being done
+ * during execution of the constructor itself.
+ */
+
+ TclOODeleteMethod(clsPtr->constructorPtr);
+ clsPtr->constructorPtr = mPtr;
+ } else {
+ /*
+ * Delete the constructor method record and set the field in the class
+ * record to NULL.
+ */
+
+ TclOODeleteMethod(clsPtr->constructorPtr);
+ clsPtr->constructorPtr = NULL;
+ }
+
+ return TCL_OK;
+}
+
+int
+TclOODefineCopyObjCmd(
+ ClientData clientData,
+ Tcl_Interp *interp,
+ int objc,
+ Tcl_Obj *const *objv)
+{
+ Tcl_Object oPtr, o2Ptr;
+
+ if (objc > 2) {
+ Tcl_WrongNumArgs(interp, 1, objv, "?targetName?");
+ return TCL_ERROR;
+ }
+
+ oPtr = (Tcl_Object) GetDefineCmdContext(interp);
+ if (oPtr == NULL) {
+ return TCL_ERROR;
+ }
+
+ /*
+ * Create a cloned object of the correct class. Note that constructors are
+ * not called. Also note that we must resolve the object name ourselves
+ * because we do not want to create the object in the current namespace,
+ * but rather in the context of the namespace of the caller of the overall
+ * [oo::define] command.
+ */
+
+ if (objc == 1) {
+ o2Ptr = Tcl_CopyObjectInstance(interp, oPtr, NULL);
+ } else {
+ char *name;
+ Tcl_DString buffer;
+
+ name = TclGetString(objv[1]);
+ Tcl_DStringInit(&buffer);
+ if (name[0]!=':' || name[1]!=':') {
+ Interp *iPtr = (Interp *) interp;
+ CallFrame *callerFramePtr = iPtr->varFramePtr->callerVarPtr;
+
+ if (callerFramePtr != NULL) {
+ Tcl_DStringAppend(&buffer,
+ callerFramePtr->nsPtr->fullName, -1);
+ }
+ Tcl_DStringAppend(&buffer, "::", 2);
+ Tcl_DStringAppend(&buffer, name, -1);
+ name = Tcl_DStringValue(&buffer);
+ }
+ o2Ptr = Tcl_CopyObjectInstance(interp, oPtr, name);
+ Tcl_DStringFree(&buffer);
+ }
+
+ if (o2Ptr == NULL) {
+ return TCL_ERROR;
+ }
+
+ /*
+ * Return the name of the cloned object.
+ */
+
+ Tcl_GetCommandFullName(interp, Tcl_GetObjectCommand(o2Ptr),
+ Tcl_GetObjResult(interp));
+ return TCL_OK;
+}
+
+int
+TclOODefineDestructorObjCmd(
+ ClientData clientData,
+ Tcl_Interp *interp,
+ int objc,
+ Tcl_Obj *const *objv)
+{
+ Object *oPtr;
+ Class *clsPtr;
+ int bodyLength;
+
+ if (objc != 2) {
+ Tcl_WrongNumArgs(interp, 1, objv, "body");
+ return TCL_ERROR;
+ }
+
+ oPtr = GetDefineCmdContext(interp);
+ if (oPtr == NULL) {
+ return TCL_ERROR;
+ }
+ if (oPtr->classPtr == NULL) {
+ Tcl_AppendResult(interp, "only classes may have destructors defined",
+ NULL);
+ return TCL_ERROR;
+ }
+ clsPtr = oPtr->classPtr;
+
+ (void) Tcl_GetStringFromObj(objv[1], &bodyLength);
+ if (bodyLength > 0) {
+ /*
+ * Create the method structure.
+ */
+
+ Method *mPtr;
+
+ mPtr = TclOONewProcClassMethod(interp, clsPtr, 1, NULL, NULL,
+ objv[1]);
+ if (mPtr == NULL) {
+ return TCL_ERROR;
+ }
+
+ /*
+ * Place the method structure in the class record. Note that we might
+ * not immediately delete the destructor as this might be being done
+ * during execution of the destructor itself.
+ */
+
+ TclOODeleteMethod(clsPtr->destructorPtr);
+ clsPtr->destructorPtr = mPtr;
+ } else {
+ /*
+ * Delete the destructor method record and set the field in the class
+ * record to NULL.
+ */
+
+ TclOODeleteMethod(clsPtr->destructorPtr);
+ clsPtr->destructorPtr = NULL;
+ }
+
+ return TCL_OK;
+}
+
+int
+TclOODefineExportObjCmd(
+ ClientData clientData,
+ Tcl_Interp *interp,
+ int objc,
+ Tcl_Obj *const *objv)
+{
+ int isSelfExport = (clientData != NULL);
+ Object *oPtr;
+ Method *mPtr;
+ Tcl_HashEntry *hPtr;
+ Class *clsPtr;
+ int i, isNew;
+
+ if (objc < 2) {
+ Tcl_WrongNumArgs(interp, 1, objv, "name ?name ...?");
+ return TCL_ERROR;
+ }
+
+ oPtr = GetDefineCmdContext(interp);
+ if (oPtr == NULL) {
+ return TCL_ERROR;
+ }
+ clsPtr = oPtr->classPtr;
+ isSelfExport |= (clsPtr == NULL);
+
+ for (i=1 ; i<objc ; i++) {
+ if (isSelfExport) {
+ hPtr = Tcl_CreateHashEntry(&oPtr->methods, (char *) objv[i],
+ &isNew);
+ } else {
+ hPtr = Tcl_CreateHashEntry(&clsPtr->classMethods, (char*) objv[i],
+ &isNew);
+ }
+
+ if (isNew) {
+ mPtr = (Method *) ckalloc(sizeof(Method));
+ memset(mPtr, 0, sizeof(Method));
+ Tcl_SetHashValue(hPtr, mPtr);
+ } else {
+ mPtr = Tcl_GetHashValue(hPtr);
+ }
+ mPtr->flags |= PUBLIC_METHOD;
+ }
+ if (isSelfExport) {
+ oPtr->epoch++;
+ } else {
+ ((Interp *)interp)->ooFoundation->epoch++;
+ }
+ return TCL_OK;
+}
+
+int
+TclOODefineFilterObjCmd(
+ ClientData clientData,
+ Tcl_Interp *interp,
+ int objc,
+ Tcl_Obj *const *objv)
+{
+ int isSelfFilter = (clientData != NULL);
+ Object *oPtr;
+ int i;
+
+ oPtr = GetDefineCmdContext(interp);
+ if (oPtr == NULL) {
+ return TCL_ERROR;
+ }
+ isSelfFilter |= (oPtr->classPtr == NULL);
+
+ if (!isSelfFilter) {
+ if (oPtr->classPtr->filters.num) {
+ Tcl_Obj *filterObj;
+
+ FOREACH(filterObj, oPtr->classPtr->filters) {
+ TclDecrRefCount(filterObj);
+ }
+ }
+
+ if (objc == 1) {
+ // deleting filters
+ ckfree((char *) oPtr->classPtr->filters.list);
+ oPtr->classPtr->filters.list = NULL;
+ oPtr->classPtr->filters.num = 0;
+ } else {
+ // creating filters
+ Tcl_Obj **filters;
+
+ if (oPtr->classPtr->filters.num == 0) {
+ filters = (Tcl_Obj **) ckalloc(sizeof(Tcl_Obj *) * (objc-1));
+ } else {
+ filters = (Tcl_Obj **) ckrealloc(
+ (char *) oPtr->classPtr->filters.list,
+ sizeof(Tcl_Obj *) * (objc-1));
+ }
+ for (i=1 ; i<objc ; i++) {
+ filters[i-1] = objv[i];
+ Tcl_IncrRefCount(objv[i]);
+ }
+ oPtr->classPtr->filters.list = filters;
+ oPtr->classPtr->filters.num = objc-1;
+ }
+ // may be many objects affected
+ ((Interp *)interp)->ooFoundation->epoch++;
+ } else {
+ if (oPtr->filters.num) {
+ Tcl_Obj *filterObj;
+
+ FOREACH(filterObj, oPtr->filters) {
+ TclDecrRefCount(filterObj);
+ }
+ }
+ if (objc == 1) {
+ // deleting filters
+ ckfree((char *) oPtr->filters.list);
+ oPtr->filters.list = NULL;
+ oPtr->filters.num = 0;
+ } else {
+ // creating filters
+ Tcl_Obj **filters;
+
+ if (oPtr->filters.num == 0) {
+ filters = (Tcl_Obj **) ckalloc(sizeof(Tcl_Obj *) * (objc-1));
+ } else {
+ filters = (Tcl_Obj **) ckrealloc((char *) oPtr->filters.list,
+ sizeof(Tcl_Obj *) * (objc-1));
+ }
+ for (i=1 ; i<objc ; i++) {
+ filters[i-1] = objv[i];
+ Tcl_IncrRefCount(objv[i]);
+ }
+ oPtr->filters.list = filters;
+ oPtr->filters.num = objc-1;
+ }
+ oPtr->epoch++; // per-object
+ }
+ return TCL_OK;
+}
+
+int
+TclOODefineForwardObjCmd(
+ ClientData clientData,
+ Tcl_Interp *interp,
+ int objc,
+ Tcl_Obj *const *objv)
+{
+ int isSelfForward = (clientData != NULL);
+ Object *oPtr;
+ Method *mPtr;
+ int isPublic;
+ Tcl_Obj *prefixObj;
+
+ if (objc < 3) {
+ Tcl_WrongNumArgs(interp, 1, objv, "name cmdName ?arg ...?");
+ return TCL_ERROR;
+ }
+
+ oPtr = GetDefineCmdContext(interp);
+ if (oPtr == NULL) {
+ return TCL_ERROR;
+ }
+ isSelfForward |= (oPtr->classPtr == NULL);
+ isPublic = Tcl_StringMatch(TclGetString(objv[1]), "[a-z]*");
+
+ /*
+ * Create the method structure.
+ */
+
+ prefixObj = Tcl_NewListObj(objc-2, objv+2);
+ if (isSelfForward) {
+ mPtr = TclOONewForwardMethod(interp, oPtr, isPublic, objv[1],
+ prefixObj);
+ } else {
+ mPtr = TclOONewForwardClassMethod(interp, oPtr->classPtr, isPublic,
+ objv[1], prefixObj);
+ }
+ if (mPtr == NULL) {
+ TclDecrRefCount(prefixObj);
+ return TCL_ERROR;
+ }
+ return TCL_OK;
+}
+
+int
+TclOODefineMethodObjCmd(
+ ClientData clientData,
+ Tcl_Interp *interp,
+ int objc,
+ Tcl_Obj *const *objv)
+{
+ int isSelfMethod = (clientData != NULL);
+ Object *oPtr;
+ int bodyLength;
+
+ if (objc != 4) {
+ Tcl_WrongNumArgs(interp, 1, objv, "name args body");
+ return TCL_ERROR;
+ }
+
+ oPtr = GetDefineCmdContext(interp);
+ if (oPtr == NULL) {
+ return TCL_ERROR;
+ }
+ isSelfMethod |= (oPtr->classPtr == NULL);
+
+ (void) Tcl_GetStringFromObj(objv[3], &bodyLength);
+ if (bodyLength > 0) {
+ /*
+ * Create the method structure.
+ */
+
+ Method *mPtr;
+ int isPublic = Tcl_StringMatch(TclGetString(objv[1]), "[a-z]*");
+
+ if (isSelfMethod) {
+ mPtr = TclOONewProcMethod(interp, oPtr, isPublic, objv[1],
+ objv[2], objv[3]);
+ } else {
+ mPtr = TclOONewProcClassMethod(interp, oPtr->classPtr, isPublic,
+ objv[1], objv[2], objv[3]);
+ }
+ if (mPtr == NULL) {
+ return TCL_ERROR;
+ }
+ } else {
+ /*
+ * Delete the method structure from the appropriate hash table.
+ */
+
+ Tcl_HashEntry *hPtr;
+
+ if (isSelfMethod) {
+ hPtr = Tcl_FindHashEntry(&oPtr->methods, (char *)objv[1]);
+ } else {
+ hPtr = Tcl_FindHashEntry(&oPtr->classPtr->classMethods,
+ (char *)objv[1]);
+ }
+ if (hPtr != NULL) {
+ Method *mPtr = (Method *) Tcl_GetHashValue(hPtr);
+
+ Tcl_DeleteHashEntry(hPtr);
+ TclOODeleteMethod(mPtr);
+ }
+ }
+
+ return TCL_OK;
+}
+
+int
+TclOODefineMixinObjCmd(
+ ClientData clientData,
+ Tcl_Interp *interp,
+ const int objc,
+ Tcl_Obj *const *objv)
+{
+ int isSelfMixin = (clientData != NULL);
+ Object *oPtr = GetDefineCmdContext(interp);
+ Class *mixinPtr;
+ int i;
+
+ if (oPtr == NULL) {
+ return TCL_ERROR;
+ }
+ isSelfMixin |= (oPtr->classPtr == NULL);
+
+ if (isSelfMixin) {
+ if (objc == 1) {
+ if (oPtr->mixins.num != 0) {
+ FOREACH(mixinPtr, oPtr->mixins) {
+ TclOORemoveFromInstances(oPtr, mixinPtr);
+ }
+ ckfree((char *) oPtr->mixins.list);
+ oPtr->mixins.num = 0;
+ }
+ } else {
+ Class **mixins = (Class **) ckalloc(sizeof(Class *) * (objc-1));
+
+ for (i=1 ; i<objc ; i++) {
+ Object *o2Ptr;
+
+ o2Ptr = (Object *) Tcl_GetObjectFromObj(interp, objv[i]);
+ if (o2Ptr == NULL) {
+ goto freeAndErrorSelf;
+ }
+ if (o2Ptr->classPtr == NULL) {
+ Tcl_AppendResult(interp, "may only mix in classes; \"",
+ TclGetString(objv[i]), "\" is not a class", NULL);
+ freeAndErrorSelf:
+ ckfree((char *) mixins);
+ return TCL_ERROR;
+ }
+ mixins[i-1] = o2Ptr->classPtr;
+ }
+ if (oPtr->mixins.num != 0) {
+ FOREACH(mixinPtr, oPtr->mixins) {
+ if (mixinPtr != oPtr->selfCls) {
+ TclOORemoveFromInstances(oPtr, mixinPtr);
+ }
+ }
+ ckfree((char *) oPtr->mixins.list);
+ }
+ oPtr->mixins.num = objc-1;
+ oPtr->mixins.list = mixins;
+ FOREACH(mixinPtr, oPtr->mixins) {
+ if (mixinPtr != oPtr->selfCls) {
+ TclOOAddToInstances(oPtr, mixinPtr);
+ }
+ }
+ }
+ oPtr->epoch++;
+ } else {
+ register Class *clsPtr = oPtr->classPtr;
+
+ if (objc == 1) {
+ if (clsPtr->mixins.num != 0) {
+ FOREACH(mixinPtr, clsPtr->mixins) {
+ TclOORemoveFromMixinSubs(clsPtr, mixinPtr);
+ }
+ ckfree((char *) clsPtr->mixins.list);
+ clsPtr->mixins.num = 0;
+ }
+ } else {
+ Class **mixins = (Class **) ckalloc(sizeof(Class *) * (objc-1));
+
+ for (i=1 ; i<objc ; i++) {
+ Object *o2Ptr;
+
+ o2Ptr = (Object *) Tcl_GetObjectFromObj(interp, objv[i]);
+ if (o2Ptr == NULL) {
+ goto freeAndErrorClass;
+ }
+ if (o2Ptr->classPtr == NULL) {
+ Tcl_AppendResult(interp, "may only mix in classes; \"",
+ TclGetString(objv[i]), "\" is not a class", NULL);
+ freeAndErrorClass:
+ ckfree((char *) mixins);
+ return TCL_ERROR;
+ }
+ mixins[i-1] = o2Ptr->classPtr;
+ }
+ if (clsPtr->mixins.num != 0) {
+ FOREACH(mixinPtr, clsPtr->mixins) {
+ TclOORemoveFromMixinSubs(clsPtr, mixinPtr);
+ }
+ ckfree((char *) clsPtr->mixins.list);
+ }
+ clsPtr->mixins.num = objc-1;
+ clsPtr->mixins.list = mixins;
+ FOREACH(mixinPtr, clsPtr->mixins) {
+ TclOOAddToMixinSubs(clsPtr, mixinPtr);
+ }
+ }
+ ((Interp *)interp)->ooFoundation->epoch++;
+ }
+ return TCL_OK;
+}
+
+#ifdef SUPPORT_OO_PARAMETERS
+// Not sure whether we want to retain this in the core oo system since it is
+// easy to add "after market".
+int
+TclOODefineParameterObjCmd(
+ ClientData clientData,
+ Tcl_Interp *interp,
+ int objc,
+ Tcl_Obj *const *objv)
+{
+ Object *oPtr = GetDefineCmdContext(interp);
+
+ if (oPtr == NULL) {
+ return TCL_ERROR;
+ }
+
+ /*
+ * Must nail down the semantics of this!
+ */
+
+ Tcl_AppendResult(interp, "TODO: not yet finished", NULL);
+ return TCL_ERROR;
+}
+#endif
+
+int
+TclOODefineSelfClassObjCmd(
+ ClientData clientData,
+ Tcl_Interp *interp,
+ int objc,
+ Tcl_Obj *const *objv)
+{
+ Object *oPtr, *o2Ptr;
+ Foundation *fPtr = ((Interp *)interp)->ooFoundation;
+
+ /*
+ * Parse the context to get the object to operate on.
+ */
+
+ oPtr = GetDefineCmdContext(interp);
+ if (oPtr == NULL) {
+ return TCL_ERROR;
+ }
+ if (oPtr == fPtr->objectCls->thisPtr) {
+ Tcl_AppendResult(interp,
+ "may not modify the class of the root object", NULL);
+ return TCL_ERROR;
+ }
+ if (oPtr == fPtr->classCls->thisPtr) {
+ Tcl_AppendResult(interp,
+ "may not modify the class of the class of classes", NULL);
+ return TCL_ERROR;
+ }
+
+ /*
+ * Parse the argument to get the class to set the object's class to.
+ */
+
+ if (objc != 2) {
+ Tcl_WrongNumArgs(interp, 1, objv, "className");
+ return TCL_ERROR;
+ }
+ o2Ptr = (Object *) Tcl_GetObjectFromObj(interp, objv[1]);
+ if (o2Ptr == NULL) {
+ return TCL_ERROR;
+ }
+ if (o2Ptr->classPtr == NULL) {
+ Tcl_AppendResult(interp, "the class of an object must be a class",
+ NULL);
+ return TCL_ERROR;
+ }
+
+ /*
+ * Apply semantic checks. In particular, classes and non-classes are not
+ * interchangable (too complicated to do the conversion!) so we must
+ * produce an error if any attempt is made to swap from one to the other.
+ */
+
+ if ((oPtr->classPtr == NULL) == TclOOIsReachable(fPtr->classCls,
+ o2Ptr->classPtr)) {
+ Tcl_AppendResult(interp, "may not change a ",
+ (oPtr->classPtr==NULL ? "non-" : ""), "class object into a ",
+ (oPtr->classPtr==NULL ? "" : "non-"), "class object", NULL);
+ return TCL_ERROR;
+ }
+
+ /*
+ * Set the object's class.
+ */
+
+ if (oPtr->selfCls != o2Ptr->classPtr) {
+ TclOORemoveFromInstances(oPtr, oPtr->selfCls);
+ oPtr->selfCls = o2Ptr->classPtr;
+ TclOOAddToInstances(oPtr, oPtr->selfCls);
+ if (oPtr->classPtr != NULL) {
+ fPtr->epoch++;
+ } else {
+ oPtr->epoch++;
+ }
+ }
+ return TCL_OK;
+}
+
+int
+TclOODefineSuperclassObjCmd(
+ ClientData clientData,
+ Tcl_Interp *interp,
+ int objc,
+ Tcl_Obj *const *objv)
+{
+ Object *oPtr, *o2Ptr;
+ Foundation *fPtr = ((Interp *)interp)->ooFoundation;
+ Class **superclasses, *superPtr;
+ int i, j;
+
+ if (objc < 2) {
+ Tcl_WrongNumArgs(interp, 1, objv, "className ?className ...?");
+ return TCL_ERROR;
+ }
+
+ /*
+ * Get the class to operate on.
+ */
+
+ oPtr = GetDefineCmdContext(interp);
+ if (oPtr == NULL) {
+ return TCL_ERROR;
+ }
+ if (oPtr->classPtr == NULL) {
+ Tcl_AppendResult(interp, "only classes may have superclasses defined",
+ NULL);
+ return TCL_ERROR;
+ }
+ if (oPtr == fPtr->objectCls->thisPtr) {
+ Tcl_AppendResult(interp,
+ "may not modify the superclass of the root object", NULL);
+ return TCL_ERROR;
+ }
+
+ /*
+ * Allocate some working space.
+ */
+
+ superclasses = (Class **) ckalloc(sizeof(Class *) * (objc-1));
+
+ /*
+ * Parse the arguments to get the class to use as superclasses.
+ */
+
+ for (i=0 ; i<objc-1 ; i++) {
+ o2Ptr = (Object *) Tcl_GetObjectFromObj(interp, objv[i+1]);
+ if (o2Ptr == NULL) {
+ goto failedAfterAlloc;
+ }
+ if (o2Ptr->classPtr == NULL) {
+ Tcl_AppendResult(interp, "only a class can be a superclass",NULL);
+ goto failedAfterAlloc;
+ }
+ for (j=0 ; j<i ; j++) {
+ if (superclasses[j] == o2Ptr->classPtr) {
+ Tcl_AppendResult(interp,
+ "class should only be a direct superclass once",NULL);
+ goto failedAfterAlloc;
+ }
+ }
+ if (TclOOIsReachable(oPtr->classPtr, o2Ptr->classPtr)) {
+ Tcl_AppendResult(interp,
+ "attempt to form circular dependency graph", NULL);
+ failedAfterAlloc:
+ ckfree((char *) superclasses);
+ return TCL_ERROR;
+ }
+ superclasses[i] = o2Ptr->classPtr;
+ }
+
+ /*
+ * Install the list of superclasses into the class. Note that this also
+ * involves splicing the class out of the superclasses' subclass list that
+ * it used to be a member of and splicing it into the new superclasses'
+ * subclass list.
+ */
+
+ if (oPtr->classPtr->superclasses.num != 0) {
+ FOREACH(superPtr, oPtr->classPtr->superclasses) {
+ TclOORemoveFromSubclasses(oPtr->classPtr, superPtr);
+ }
+ ckfree((char *) oPtr->classPtr->superclasses.list);
+ }
+ oPtr->classPtr->superclasses.list = superclasses;
+ oPtr->classPtr->superclasses.num = objc-1;
+ FOREACH(superPtr, oPtr->classPtr->superclasses) {
+ TclOOAddToSubclasses(oPtr->classPtr, superPtr);
+ }
+ fPtr->epoch++;
+
+ return TCL_OK;
+}
+
+int
+TclOODefineUnexportObjCmd(
+ ClientData clientData,
+ Tcl_Interp *interp,
+ int objc,
+ Tcl_Obj *const *objv)
+{
+ int isSelfUnexport = (clientData != NULL);
+ Object *oPtr;
+ Method *mPtr;
+ Tcl_HashEntry *hPtr;
+ Class *clsPtr;
+ int i, isNew;
+
+ if (objc < 2) {
+ Tcl_WrongNumArgs(interp, 1, objv, "name ?name ...?");
+ return TCL_ERROR;
+ }
+
+ oPtr = GetDefineCmdContext(interp);
+ if (oPtr == NULL) {
+ return TCL_ERROR;
+ }
+ clsPtr = oPtr->classPtr;
+ isSelfUnexport |= (oPtr->classPtr == NULL);
+
+ for (i=1 ; i<objc ; i++) {
+ if (isSelfUnexport) {
+ hPtr = Tcl_CreateHashEntry(&oPtr->methods, (char *) objv[i],
+ &isNew);
+ } else {
+ hPtr = Tcl_CreateHashEntry(&clsPtr->classMethods, (char*) objv[i],
+ &isNew);
+ }
+
+ if (isNew) {
+ mPtr = (Method *) ckalloc(sizeof(Method));
+ memset(mPtr, 0, sizeof(Method));
+ Tcl_SetHashValue(hPtr, mPtr);
+ } else {
+ mPtr = Tcl_GetHashValue(hPtr);
+ }
+ mPtr->flags &= ~PUBLIC_METHOD;
+ }
+ if (isSelfUnexport) {
+ oPtr->epoch++;
+ } else {
+ ((Interp *)interp)->ooFoundation->epoch++;
+ }
+ return TCL_OK;
+}
+
+/*
+ * Local Variables:
+ * mode: c
+ * c-basic-offset: 4
+ * fill-column: 78
+ * End:
+ */
diff --git a/generic/tclOOInfo.c b/generic/tclOOInfo.c
new file mode 100644
index 0000000..859aae4
--- /dev/null
+++ b/generic/tclOOInfo.c
@@ -0,0 +1,901 @@
+/*
+ * tclOODefineCmds.c --
+ *
+ * This file contains the implementation of the ::oo-related [info]
+ * subcommands.
+ *
+ * Copyright (c) 2006 by Donal K. Fellows
+ *
+ * See the file "license.terms" for information on usage and redistribution of
+ * this file, and for a DISCLAIMER OF ALL WARRANTIES.
+ *
+ * RCS: @(#) $Id: tclOOInfo.c,v 1.2 2006/10/20 14:04:01 dkf Exp $
+ */
+
+#include "tclInt.h"
+#include "tclOO.h"
+
+static int InfoObjectClassCmd(Object *oPtr, Tcl_Interp *interp,
+ int objc, Tcl_Obj *const objv[]);
+static int InfoObjectDefnCmd(Object *oPtr, Tcl_Interp *interp,
+ int objc, Tcl_Obj *const objv[]);
+static int InfoObjectFiltersCmd(Object *oPtr, Tcl_Interp *interp,
+ int objc, Tcl_Obj *const objv[]);
+static int InfoObjectForwardCmd(Object *oPtr, Tcl_Interp *interp,
+ int objc, Tcl_Obj *const objv[]);
+static int InfoObjectIsACmd(Tcl_Interp *interp, int objc,
+ Tcl_Obj *const objv[]);
+static int InfoObjectMethodsCmd(Object *oPtr, Tcl_Interp *interp,
+ int objc, Tcl_Obj *const objv[]);
+static int InfoObjectMixinsCmd(Object *oPtr, Tcl_Interp *interp,
+ int objc, Tcl_Obj *const objv[]);
+static int InfoObjectVarsCmd(Object *oPtr, Tcl_Interp *interp,
+ int objc, Tcl_Obj *const objv[]);
+static int InfoClassConstrCmd(Class *clsPtr, Tcl_Interp *interp,
+ int objc, Tcl_Obj *const objv[]);
+static int InfoClassDefnCmd(Class *clsPtr, Tcl_Interp *interp,
+ int objc, Tcl_Obj *const objv[]);
+static int InfoClassDestrCmd(Class *clsPtr, Tcl_Interp *interp,
+ int objc, Tcl_Obj *const objv[]);
+static int InfoClassFiltersCmd(Class *clsPtr, Tcl_Interp *interp,
+ int objc, Tcl_Obj *const objv[]);
+static int InfoClassForwardCmd(Class *clsPtr, Tcl_Interp *interp,
+ int objc, Tcl_Obj *const objv[]);
+static int InfoClassInstancesCmd(Class *clsPtr,
+ Tcl_Interp*interp, int objc, Tcl_Obj*const objv[]);
+static int InfoClassMethodsCmd(Class *clsPtr, Tcl_Interp *interp,
+ int objc, Tcl_Obj *const objv[]);
+static int InfoClassMixinsCmd(Class *clsPtr, Tcl_Interp *interp,
+ int objc, Tcl_Obj *const objv[]);
+#ifdef SUPPORT_OO_PARAMETERS
+static int InfoClassParametersCmd(Class *clsPtr,
+ Tcl_Interp*interp, int objc, Tcl_Obj*const objv[]);
+#endif
+static int InfoClassSubsCmd(Class *clsPtr, Tcl_Interp *interp,
+ int objc, Tcl_Obj *const objv[]);
+static int InfoClassSupersCmd(Class *clsPtr, Tcl_Interp *interp,
+ int objc, Tcl_Obj *const objv[]);
+
+int
+TclInfoObjectCmd(
+ ClientData clientData,
+ Tcl_Interp *interp,
+ int objc,
+ Tcl_Obj *const *objv)
+{
+ static const char *subcommands[] = {
+ "class", "definition", "filters", "forward", "isa", "methods",
+ "mixins", "vars", NULL
+ };
+ enum IOSubCmds {
+ IOClass, IODefinition, IOFilters, IOForward, IOIsA, IOMethods,
+ IOMixins, IOVars
+ };
+ int idx;
+ Object *oPtr;
+
+ if (objc < 4) {
+ Tcl_WrongNumArgs(interp, 2, objv, "objName subcommand ?arg ...?");
+ return TCL_ERROR;
+ }
+ if (Tcl_GetIndexFromObj(interp, objv[3], subcommands, "subcommand", 0,
+ &idx) != TCL_OK) {
+ return TCL_ERROR;
+ }
+ if (idx == IOIsA) {
+ return InfoObjectIsACmd(interp, objc, objv);
+ }
+ oPtr = (Object *) Tcl_GetObjectFromObj(interp, objv[2]);
+ if (oPtr == NULL) {
+ return TCL_ERROR;
+ }
+ switch ((enum IOSubCmds) idx) {
+ case IOClass:
+ return InfoObjectClassCmd(oPtr, interp, objc, objv);
+ case IODefinition:
+ return InfoObjectDefnCmd(oPtr, interp, objc, objv);
+ case IOFilters:
+ return InfoObjectFiltersCmd(oPtr, interp, objc, objv);
+ case IOForward:
+ return InfoObjectForwardCmd(oPtr, interp, objc, objv);
+ case IOMethods:
+ return InfoObjectMethodsCmd(oPtr, interp, objc, objv);
+ case IOMixins:
+ return InfoObjectMixinsCmd(oPtr, interp, objc, objv);
+ case IOVars:
+ return InfoObjectVarsCmd(oPtr, interp, objc, objv);
+ case IOIsA:
+ Tcl_Panic("unexpected fallthrough");
+ }
+ return TCL_ERROR; /* NOTREACHED */
+}
+
+int
+TclInfoClassCmd(
+ ClientData clientData,
+ Tcl_Interp *interp,
+ int objc,
+ Tcl_Obj *const *objv)
+{
+ static const char *subcommands[] = {
+ "constructor", "definition", "destructor", "filters", "forward",
+ "instances", "methods", "mixins",
+#ifdef SUPPORT_OO_PARAMETERS
+ "parameters",
+#endif
+ "subclasses", "superclasses", NULL
+ };
+ enum ICSubCmds {
+ ICConstructor, ICDefinition, ICDestructor, ICFilters, ICForward,
+ ICInstances, ICMethods, ICMixins,
+#ifdef SUPPORT_OO_PARAMETERS
+ ICParameters,
+#endif
+ ICSubs, ICSupers
+ };
+ int idx;
+ Object *oPtr;
+
+ if (objc < 4) {
+ Tcl_WrongNumArgs(interp, 2, objv, "className subcommand ?arg ...?");
+ return TCL_ERROR;
+ }
+ oPtr = (Object *) Tcl_GetObjectFromObj(interp, objv[2]);
+ if (oPtr == NULL) {
+ return TCL_ERROR;
+ }
+ if (oPtr->classPtr == NULL) {
+ Tcl_AppendResult(interp, "\"", TclGetString(objv[2]),
+ "\" is not a class", NULL);
+ return TCL_ERROR;
+ }
+ if (Tcl_GetIndexFromObj(interp, objv[3], subcommands, "subcommand", 0,
+ &idx) != TCL_OK) {
+ return TCL_ERROR;
+ }
+
+ switch((enum ICSubCmds) idx) {
+ case ICConstructor:
+ return InfoClassConstrCmd(oPtr->classPtr, interp, objc, objv);
+ case ICDefinition:
+ return InfoClassDefnCmd(oPtr->classPtr, interp, objc, objv);
+ case ICDestructor:
+ return InfoClassDestrCmd(oPtr->classPtr, interp, objc, objv);
+ case ICFilters:
+ return InfoClassFiltersCmd(oPtr->classPtr, interp, objc, objv);
+ case ICForward:
+ return InfoClassForwardCmd(oPtr->classPtr, interp, objc, objv);
+ case ICInstances:
+ return InfoClassInstancesCmd(oPtr->classPtr, interp, objc, objv);
+ case ICMethods:
+ return InfoClassMethodsCmd(oPtr->classPtr, interp, objc, objv);
+ case ICMixins:
+ return InfoClassMixinsCmd(oPtr->classPtr, interp, objc, objv);
+#ifdef SUPPORT_OO_PARAMETERS
+ case ICParameters:
+ return InfoClassParametersCmd(oPtr->classPtr, interp, objc, objv);
+#endif
+ case ICSubs:
+ return InfoClassSubsCmd(oPtr->classPtr, interp, objc, objv);
+ case ICSupers:
+ return InfoClassSupersCmd(oPtr->classPtr, interp, objc, objv);
+ }
+ Tcl_Panic("unexpected fallthrough");
+ return TCL_ERROR; /* NOTREACHED */
+}
+
+static int
+InfoObjectClassCmd(
+ Object *oPtr,
+ Tcl_Interp *interp,
+ int objc,
+ Tcl_Obj *const objv[])
+{
+ if (objc == 4) {
+ Tcl_GetCommandFullName(interp, oPtr->selfCls->thisPtr->command,
+ Tcl_GetObjResult(interp));
+ return TCL_OK;
+ } else if (objc != 5) {
+ Tcl_WrongNumArgs(interp, 2, objv, "objName class ?className?");
+ return TCL_ERROR;
+ } else {
+ Object *o2Ptr;
+ Class *mixinPtr;
+ int i;
+
+ o2Ptr = (Object *) Tcl_GetObjectFromObj(interp, objv[4]);
+ if (o2Ptr == NULL) {
+ return TCL_ERROR;
+ }
+ if (o2Ptr->classPtr == NULL) {
+ Tcl_AppendResult(interp, "object \"", TclGetString(objv[4]),
+ "\" is not a class", NULL);
+ return TCL_ERROR;
+ }
+
+ FOREACH(mixinPtr, oPtr->mixins) {
+ if (TclOOIsReachable(o2Ptr->classPtr, mixinPtr)) {
+ Tcl_SetObjResult(interp, Tcl_NewIntObj(1));
+ return TCL_OK;
+ }
+ }
+ Tcl_SetObjResult(interp, Tcl_NewIntObj(
+ TclOOIsReachable(o2Ptr->classPtr, oPtr->selfCls)));
+ return TCL_OK;
+ }
+}
+
+static int
+InfoObjectDefnCmd(
+ Object *oPtr,
+ Tcl_Interp *interp,
+ int objc,
+ Tcl_Obj *const objv[])
+{
+ Tcl_HashEntry *hPtr;
+ Proc *procPtr;
+ CompiledLocal *localPtr;
+ Tcl_Obj *argsObj;
+
+ if (objc != 5) {
+ Tcl_WrongNumArgs(interp, 2, objv, "objName definition methodName");
+ return TCL_ERROR;
+ }
+
+ hPtr = Tcl_FindHashEntry(&oPtr->methods, (char *) objv[4]);
+ if (hPtr == NULL) {
+ Tcl_AppendResult(interp, "unknown method \"", TclGetString(objv[4]),
+ "\"", NULL);
+ return TCL_ERROR;
+ }
+ procPtr = TclOOGetProcFromMethod(Tcl_GetHashValue(hPtr));
+ if (procPtr == NULL) {
+ Tcl_AppendResult(interp,
+ "definition not available for this kind of method", NULL);
+ return TCL_ERROR;
+ }
+
+ TclNewObj(argsObj);
+ for (localPtr=procPtr->firstLocalPtr; localPtr!=NULL;
+ localPtr=localPtr->nextPtr) {
+ if (TclIsVarArgument(localPtr)) {
+ Tcl_Obj *argObj;
+
+ TclNewObj(argObj);
+ Tcl_ListObjAppendElement(NULL, argObj,
+ Tcl_NewStringObj(localPtr->name, -1));
+ if (localPtr->defValuePtr != NULL) {
+ Tcl_ListObjAppendElement(NULL, argObj, localPtr->defValuePtr);
+ }
+ Tcl_ListObjAppendElement(NULL, argsObj, argObj);
+ }
+ }
+ Tcl_ListObjAppendElement(NULL, Tcl_GetObjResult(interp), argsObj);
+
+ /*
+ * This is copied from the [info body] implementation. See the comments
+ * there for why this copy has to be done here.
+ */
+
+ if (procPtr->bodyPtr->bytes == NULL) {
+ (void) Tcl_GetString(procPtr->bodyPtr);
+ }
+ Tcl_ListObjAppendElement(NULL, Tcl_GetObjResult(interp),
+ Tcl_NewStringObj(procPtr->bodyPtr->bytes,
+ procPtr->bodyPtr->length));
+ return TCL_OK;
+}
+
+static int
+InfoObjectFiltersCmd(
+ Object *oPtr,
+ Tcl_Interp *interp,
+ int objc,
+ Tcl_Obj *const objv[])
+{
+ int i;
+ Tcl_Obj *filterObj;
+
+ if (objc != 4) {
+ Tcl_WrongNumArgs(interp, 2, objv, "objName filters");
+ return TCL_ERROR;
+ }
+ FOREACH(filterObj, oPtr->filters) {
+ Tcl_ListObjAppendElement(NULL, Tcl_GetObjResult(interp), filterObj);
+ }
+ return TCL_OK;
+}
+
+static int
+InfoObjectForwardCmd(
+ Object *oPtr,
+ Tcl_Interp *interp,
+ int objc,
+ Tcl_Obj *const objv[])
+{
+ Tcl_HashEntry *hPtr;
+ Tcl_Obj *prefixObj;
+
+ if (objc != 5) {
+ Tcl_WrongNumArgs(interp, 2, objv, "objName forward methodName");
+ return TCL_ERROR;
+ }
+
+ hPtr = Tcl_FindHashEntry(&oPtr->methods, (char *) objv[4]);
+ if (hPtr == NULL) {
+ Tcl_AppendResult(interp, "unknown method \"", TclGetString(objv[4]),
+ "\"", NULL);
+ return TCL_ERROR;
+ }
+ prefixObj = TclOOGetFwdFromMethod(Tcl_GetHashValue(hPtr));
+ if (prefixObj == NULL) {
+ Tcl_AppendResult(interp,
+ "prefix argument list not available for this kind of method",
+ NULL);
+ return TCL_ERROR;
+ }
+
+ Tcl_SetObjResult(interp, prefixObj);
+ return TCL_OK;
+}
+
+static int
+InfoObjectIsACmd(
+ Tcl_Interp *interp,
+ int objc,
+ Tcl_Obj *const objv[])
+{
+ static const char *categories[] = {
+ "class", "metaclass", "mixin", "object", "typeof", NULL
+ };
+ enum IsACats {
+ IsClass, IsMetaclass, IsMixin, IsObject, IsType
+ };
+ Object *oPtr, *o2Ptr;
+ int idx, i;
+
+ if (objc < 5) {
+ Tcl_WrongNumArgs(interp, 2, objv, "objName isa category ?arg ...?");
+ return TCL_ERROR;
+ }
+ if (Tcl_GetIndexFromObj(interp, objv[4], categories, "category", 0,
+ &idx) != TCL_OK) {
+ return TCL_ERROR;
+ }
+
+ if (idx == IsObject) {
+ int ok = (Tcl_GetObjectFromObj(interp, objv[2]) != NULL);
+
+ if (!ok) {
+ Tcl_ResetResult(interp);
+ }
+ Tcl_SetObjResult(interp, Tcl_NewIntObj(ok ? 1 : 0));
+ return TCL_OK;
+ }
+ oPtr = (Object *) Tcl_GetObjectFromObj(interp, objv[2]);
+ if (oPtr == NULL) {
+ return TCL_ERROR;
+ }
+
+ switch ((enum IsACats) idx) {
+ case IsClass:
+ if (objc != 5) {
+ Tcl_WrongNumArgs(interp, 2, objv, "objName isa class");
+ return TCL_ERROR;
+ }
+ Tcl_SetObjResult(interp, Tcl_NewIntObj(oPtr->classPtr ? 1 : 0));
+ return TCL_OK;
+ case IsMetaclass:
+ if (objc != 5) {
+ Tcl_WrongNumArgs(interp, 2, objv, "objName isa metaclass");
+ return TCL_ERROR;
+ }
+ if (oPtr->classPtr == NULL) {
+ Tcl_SetObjResult(interp, Tcl_NewIntObj(0));
+ } else {
+ Foundation *fPtr = ((Interp *)interp)->ooFoundation;
+
+ Tcl_SetObjResult(interp, Tcl_NewIntObj(
+ TclOOIsReachable(fPtr->classCls, oPtr->classPtr) ? 1 : 0));
+ }
+ return TCL_OK;
+ case IsMixin:
+ if (objc != 6) {
+ Tcl_WrongNumArgs(interp, 2, objv, "objName isa mixin className");
+ return TCL_ERROR;
+ }
+ o2Ptr = (Object *) Tcl_GetObjectFromObj(interp, objv[5]);
+ if (o2Ptr == NULL) {
+ return TCL_ERROR;
+ }
+ if (o2Ptr->classPtr == NULL) {
+ Tcl_AppendResult(interp, "non-classes cannot be mixins", NULL);
+ return TCL_ERROR;
+ } else {
+ Class *mixinPtr;
+
+ FOREACH(mixinPtr, oPtr->mixins) {
+ if (mixinPtr == o2Ptr->classPtr) {
+ Tcl_SetObjResult(interp, Tcl_NewIntObj(1));
+ return TCL_OK;
+ }
+ }
+ }
+ Tcl_SetObjResult(interp, Tcl_NewIntObj(0));
+ return TCL_OK;
+ case IsType:
+ if (objc != 6) {
+ Tcl_WrongNumArgs(interp, 2, objv, "objName isa typeof className");
+ return TCL_ERROR;
+ }
+ o2Ptr = (Object *) Tcl_GetObjectFromObj(interp, objv[5]);
+ if (o2Ptr == NULL) {
+ return TCL_ERROR;
+ }
+ if (o2Ptr->classPtr == NULL) {
+ Tcl_AppendResult(interp, "non-classes cannot be types", NULL);
+ return TCL_ERROR;
+ }
+ if (TclOOIsReachable(o2Ptr->classPtr, oPtr->selfCls)) {
+ Tcl_SetObjResult(interp, Tcl_NewIntObj(1));
+ } else {
+ Tcl_SetObjResult(interp, Tcl_NewIntObj(0));
+ }
+ return TCL_OK;
+ case IsObject:
+ Tcl_Panic("unexpected fallthrough");
+ }
+ return TCL_ERROR;
+}
+
+static int
+InfoObjectMethodsCmd(
+ Object *oPtr,
+ Tcl_Interp *interp,
+ int objc,
+ Tcl_Obj *const objv[])
+{
+ int flag = PUBLIC_METHOD;
+ FOREACH_HASH_DECLS;
+ Tcl_Obj *namePtr;
+ Method *mPtr;
+
+ if (objc != 4 && objc != 5) {
+ Tcl_WrongNumArgs(interp, 2, objv, "objName methods ?-private?");
+ return TCL_ERROR;
+ }
+ if (objc == 5) {
+ int len;
+ const char *str = Tcl_GetStringFromObj(objv[4], &len);
+
+ if (len < 2 || strncmp("-private", str, (unsigned)len)) {
+ Tcl_AppendResult(interp, "unknown switch \"", str,
+ "\": must be -private", NULL);
+ return TCL_ERROR;
+ }
+ flag = 0;
+ }
+ FOREACH_HASH(namePtr, mPtr, &oPtr->methods) {
+ if (mPtr->typePtr != NULL && (mPtr->flags & flag) == flag) {
+ Tcl_ListObjAppendElement(NULL, Tcl_GetObjResult(interp), namePtr);
+ }
+ }
+ return TCL_OK;
+}
+
+static int
+InfoObjectMixinsCmd(
+ Object *oPtr,
+ Tcl_Interp *interp,
+ int objc,
+ Tcl_Obj *const objv[])
+{
+ Class *mixinPtr;
+ int i;
+
+ if (objc != 4) {
+ Tcl_WrongNumArgs(interp, 2, objv, "objName mixins");
+ return TCL_ERROR;
+ }
+ FOREACH(mixinPtr, oPtr->mixins) {
+ Tcl_Obj *tmpObj;
+
+ TclNewObj(tmpObj);
+ Tcl_GetCommandFullName(interp, mixinPtr->thisPtr->command, tmpObj);
+ Tcl_ListObjAppendElement(NULL, Tcl_GetObjResult(interp), tmpObj);
+ }
+ return TCL_OK;
+}
+
+static int
+InfoObjectVarsCmd(
+ Object *oPtr,
+ Tcl_Interp *interp,
+ int objc,
+ Tcl_Obj *const objv[])
+{
+ const char *pattern = NULL, *name;
+ FOREACH_HASH_DECLS;
+ Var *varPtr;
+
+ if (objc != 4 && objc != 5) {
+ Tcl_WrongNumArgs(interp, 2, objv, "objName vars ?pattern?");
+ return TCL_ERROR;
+ }
+ if (objc == 5) {
+ pattern = TclGetString(objv[4]);
+ }
+
+ FOREACH_HASH(name, varPtr, &((Namespace *) oPtr->namespacePtr)->varTable) {
+ if (varPtr->flags & VAR_UNDEFINED) {
+ continue;
+ }
+ if (pattern != NULL && !Tcl_StringMatch(name, pattern)) {
+ continue;
+ }
+ Tcl_ListObjAppendElement(NULL, Tcl_GetObjResult(interp),
+ Tcl_NewStringObj(name, -1));
+ }
+
+ return TCL_OK;
+}
+
+static int
+InfoClassConstrCmd(
+ Class *clsPtr,
+ Tcl_Interp *interp,
+ int objc,
+ Tcl_Obj *const objv[])
+{
+ Proc *procPtr;
+ CompiledLocal *localPtr;
+ Tcl_Obj *argsObj;
+
+ if (objc != 4) {
+ Tcl_WrongNumArgs(interp, 2, objv, "className constructor");
+ return TCL_ERROR;
+ }
+
+ if (clsPtr->constructorPtr == NULL) {
+ return TCL_OK;
+ }
+ procPtr = TclOOGetProcFromMethod(clsPtr->constructorPtr);
+ if (procPtr == NULL) {
+ Tcl_AppendResult(interp,
+ "definition not available for this kind of method", NULL);
+ return TCL_ERROR;
+ }
+
+ TclNewObj(argsObj);
+ for (localPtr=procPtr->firstLocalPtr; localPtr!=NULL;
+ localPtr=localPtr->nextPtr) {
+ if (TclIsVarArgument(localPtr)) {
+ Tcl_Obj *argObj;
+
+ TclNewObj(argObj);
+ Tcl_ListObjAppendElement(NULL, argObj,
+ Tcl_NewStringObj(localPtr->name, -1));
+ if (localPtr->defValuePtr != NULL) {
+ Tcl_ListObjAppendElement(NULL, argObj, localPtr->defValuePtr);
+ }
+ Tcl_ListObjAppendElement(NULL, argsObj, argObj);
+ }
+ }
+ Tcl_ListObjAppendElement(NULL, Tcl_GetObjResult(interp), argsObj);
+ if (procPtr->bodyPtr->bytes == NULL) {
+ (void) Tcl_GetString(procPtr->bodyPtr);
+ }
+ Tcl_ListObjAppendElement(NULL, Tcl_GetObjResult(interp),
+ Tcl_NewStringObj(procPtr->bodyPtr->bytes,
+ procPtr->bodyPtr->length));
+ return TCL_OK;
+}
+
+static int
+InfoClassDefnCmd(
+ Class *clsPtr,
+ Tcl_Interp *interp,
+ int objc,
+ Tcl_Obj *const objv[])
+{
+ Tcl_HashEntry *hPtr;
+ Proc *procPtr;
+ CompiledLocal *localPtr;
+ Tcl_Obj *argsObj;
+
+ if (objc != 5) {
+ Tcl_WrongNumArgs(interp, 2, objv, "className definition methodName");
+ return TCL_ERROR;
+ }
+
+ hPtr = Tcl_FindHashEntry(&clsPtr->classMethods, (char *) objv[4]);
+ if (hPtr == NULL) {
+ Tcl_AppendResult(interp, "unknown method \"", TclGetString(objv[4]),
+ "\"", NULL);
+ return TCL_ERROR;
+ }
+ procPtr = TclOOGetProcFromMethod(Tcl_GetHashValue(hPtr));
+ if (procPtr == NULL) {
+ Tcl_AppendResult(interp,
+ "definition not available for this kind of method", NULL);
+ return TCL_ERROR;
+ }
+
+ TclNewObj(argsObj);
+ for (localPtr=procPtr->firstLocalPtr; localPtr!=NULL;
+ localPtr=localPtr->nextPtr) {
+ if (TclIsVarArgument(localPtr)) {
+ Tcl_Obj *argObj;
+
+ TclNewObj(argObj);
+ Tcl_ListObjAppendElement(NULL, argObj,
+ Tcl_NewStringObj(localPtr->name, -1));
+ if (localPtr->defValuePtr != NULL) {
+ Tcl_ListObjAppendElement(NULL, argObj, localPtr->defValuePtr);
+ }
+ Tcl_ListObjAppendElement(NULL, argsObj, argObj);
+ }
+ }
+ Tcl_ListObjAppendElement(NULL, Tcl_GetObjResult(interp), argsObj);
+ if (procPtr->bodyPtr->bytes == NULL) {
+ (void) Tcl_GetString(procPtr->bodyPtr);
+ }
+ Tcl_ListObjAppendElement(NULL, Tcl_GetObjResult(interp),
+ Tcl_NewStringObj(procPtr->bodyPtr->bytes,
+ procPtr->bodyPtr->length));
+ return TCL_OK;
+}
+
+static int
+InfoClassDestrCmd(
+ Class *clsPtr,
+ Tcl_Interp *interp,
+ int objc,
+ Tcl_Obj *const objv[])
+{
+ Proc *procPtr;
+
+ if (objc != 4) {
+ Tcl_WrongNumArgs(interp, 2, objv, "className destructor");
+ return TCL_ERROR;
+ }
+
+ if (clsPtr->destructorPtr == NULL) {
+ return TCL_OK;
+ }
+ procPtr = TclOOGetProcFromMethod(clsPtr->destructorPtr);
+ if (procPtr == NULL) {
+ Tcl_AppendResult(interp,
+ "definition not available for this kind of method", NULL);
+ return TCL_ERROR;
+ }
+
+ if (procPtr->bodyPtr->bytes == NULL) {
+ (void) Tcl_GetString(procPtr->bodyPtr);
+ }
+ Tcl_ListObjAppendElement(NULL, Tcl_GetObjResult(interp),
+ Tcl_NewStringObj(procPtr->bodyPtr->bytes,
+ procPtr->bodyPtr->length));
+ return TCL_OK;
+}
+
+static int
+InfoClassFiltersCmd(
+ Class *clsPtr,
+ Tcl_Interp *interp,
+ int objc,
+ Tcl_Obj *const objv[])
+{
+ int i;
+ Tcl_Obj *filterObj;
+
+ if (objc != 4) {
+ Tcl_WrongNumArgs(interp, 2, objv, "className filters");
+ return TCL_ERROR;
+ }
+ FOREACH(filterObj, clsPtr->filters) {
+ Tcl_ListObjAppendElement(NULL, Tcl_GetObjResult(interp), filterObj);
+ }
+ return TCL_OK;
+}
+
+static int
+InfoClassForwardCmd(
+ Class *clsPtr,
+ Tcl_Interp *interp,
+ int objc,
+ Tcl_Obj *const objv[])
+{
+ Tcl_HashEntry *hPtr;
+ Tcl_Obj *prefixObj;
+
+ if (objc != 5) {
+ Tcl_WrongNumArgs(interp, 2, objv, "className forward methodName");
+ return TCL_ERROR;
+ }
+
+ hPtr = Tcl_FindHashEntry(&clsPtr->classMethods, (char *) objv[4]);
+ if (hPtr == NULL) {
+ Tcl_AppendResult(interp, "unknown method \"", TclGetString(objv[4]),
+ "\"", NULL);
+ return TCL_ERROR;
+ }
+ prefixObj = TclOOGetFwdFromMethod(Tcl_GetHashValue(hPtr));
+ if (prefixObj == NULL) {
+ Tcl_AppendResult(interp,
+ "prefix argument list not available for this kind of method",
+ NULL);
+ return TCL_ERROR;
+ }
+
+ Tcl_SetObjResult(interp, prefixObj);
+ return TCL_OK;
+}
+
+static int
+InfoClassInstancesCmd(
+ Class *clsPtr,
+ Tcl_Interp *interp,
+ int objc,
+ Tcl_Obj *const objv[])
+{
+ Object *oPtr;
+ int i;
+ const char *pattern = NULL;
+
+ if (objc != 4 && objc != 5) {
+ Tcl_WrongNumArgs(interp, 2, objv, "className instances ?pattern?");
+ return TCL_ERROR;
+ }
+ if (objc == 5) {
+ pattern = TclGetString(objv[4]);
+ }
+ FOREACH(oPtr, clsPtr->instances) {
+ Tcl_Obj *tmpObj;
+
+ TclNewObj(tmpObj);
+ Tcl_GetCommandFullName(interp, oPtr->command, tmpObj);
+ if (pattern && !Tcl_StringMatch(TclGetString(tmpObj), pattern)) {
+ TclDecrRefCount(tmpObj);
+ continue;
+ }
+ Tcl_ListObjAppendElement(NULL, Tcl_GetObjResult(interp), tmpObj);
+ }
+ return TCL_OK;
+}
+
+static int
+InfoClassMethodsCmd(
+ Class *clsPtr,
+ Tcl_Interp *interp,
+ int objc,
+ Tcl_Obj *const objv[])
+{
+ int flag = PUBLIC_METHOD;
+ FOREACH_HASH_DECLS;
+ Tcl_Obj *namePtr;
+ Method *mPtr;
+
+ if (objc != 4 && objc != 5) {
+ Tcl_WrongNumArgs(interp, 2, objv, "className methods ?-private?");
+ return TCL_ERROR;
+ }
+ if (objc == 5) {
+ int len;
+ const char *str = Tcl_GetStringFromObj(objv[4], &len);
+
+ if (len < 2 || strncmp("-private", str, (unsigned) len)) {
+ Tcl_AppendResult(interp, "unknown switch \"", str,
+ "\": must be -private", NULL);
+ return TCL_ERROR;
+ }
+ flag = 0;
+ }
+ FOREACH_HASH(namePtr, mPtr, &clsPtr->classMethods) {
+ if (mPtr->typePtr != NULL && (mPtr->flags & flag) == flag) {
+ Tcl_ListObjAppendElement(NULL, Tcl_GetObjResult(interp), namePtr);
+ }
+ }
+ return TCL_OK;
+}
+
+static int
+InfoClassMixinsCmd(
+ Class *clsPtr,
+ Tcl_Interp *interp,
+ int objc,
+ Tcl_Obj *const objv[])
+{
+ Class *mixinPtr;
+ int i;
+
+ if (objc != 4) {
+ Tcl_WrongNumArgs(interp, 2, objv, "className mixins");
+ return TCL_ERROR;
+ }
+ FOREACH(mixinPtr, clsPtr->mixins) {
+ Tcl_Obj *tmpObj;
+
+ TclNewObj(tmpObj);
+ Tcl_GetCommandFullName(interp, mixinPtr->thisPtr->command, tmpObj);
+ Tcl_ListObjAppendElement(NULL, Tcl_GetObjResult(interp), tmpObj);
+ }
+ return TCL_OK;
+}
+
+#ifdef SUPPORT_OO_PARAMETERS
+static int
+InfoClassParametersCmd(
+ Class *clsPtr,
+ Tcl_Interp *interp,
+ int objc,
+ Tcl_Obj *const objv[])
+{
+ Tcl_AppendResult(interp, "TODO: not yet implemented", NULL);
+ return TCL_ERROR;
+}
+#endif
+
+static int
+InfoClassSubsCmd(
+ Class *clsPtr,
+ Tcl_Interp *interp,
+ int objc,
+ Tcl_Obj *const objv[])
+{
+ Class *subclassPtr;
+ int i;
+ const char *pattern = NULL;
+
+ if (objc != 4 && objc != 5) {
+ Tcl_WrongNumArgs(interp, 2, objv, "className subclasses ?pattern?");
+ return TCL_ERROR;
+ }
+ if (objc == 5) {
+ pattern = TclGetString(objv[4]);
+ }
+ FOREACH(subclassPtr, clsPtr->subclasses) {
+ Tcl_Obj *tmpObj;
+
+ TclNewObj(tmpObj);
+ Tcl_GetCommandFullName(interp, subclassPtr->thisPtr->command, tmpObj);
+ if (pattern && !Tcl_StringMatch(TclGetString(tmpObj), pattern)) {
+ TclDecrRefCount(tmpObj);
+ continue;
+ }
+ Tcl_ListObjAppendElement(NULL, Tcl_GetObjResult(interp), tmpObj);
+ }
+ return TCL_OK;
+}
+
+static int
+InfoClassSupersCmd(
+ Class *clsPtr,
+ Tcl_Interp *interp,
+ int objc,
+ Tcl_Obj *const objv[])
+{
+ Class *superPtr;
+ int i;
+
+ if (objc != 4) {
+ Tcl_WrongNumArgs(interp, 2, objv, "className superclasses");
+ return TCL_ERROR;
+ }
+ FOREACH(superPtr, clsPtr->superclasses) {
+ Tcl_Obj *tmpObj;
+
+ TclNewObj(tmpObj);
+ Tcl_GetCommandFullName(interp, superPtr->thisPtr->command, tmpObj);
+ Tcl_ListObjAppendElement(NULL, Tcl_GetObjResult(interp), tmpObj);
+ }
+ return TCL_OK;
+}
+
+/*
+ * Local Variables:
+ * mode: c
+ * c-basic-offset: 4
+ * fill-column: 78
+ * End:
+ */
diff --git a/generic/tclProc.c b/generic/tclProc.c
index d8a959e..8577470 100644
--- a/generic/tclProc.c
+++ b/generic/tclProc.c
@@ -11,11 +11,12 @@
* See the file "license.terms" for information on usage and redistribution of
* this file, and for a DISCLAIMER OF ALL WARRANTIES.
*
- * RCS: @(#) $Id: tclProc.c,v 1.93 2006/10/16 20:36:19 msofer Exp $
+ * RCS: @(#) $Id: tclProc.c,v 1.94 2006/10/20 14:04:01 dkf Exp $
*/
#include "tclInt.h"
#include "tclCompile.h"
+#include "tclOO.h"
/*
* Prototypes for static functions in this file
@@ -33,7 +34,8 @@ static int ObjInterpProcEx(ClientData clientData,
static void ProcBodyDup(Tcl_Obj *srcPtr, Tcl_Obj *dupPtr);
static void ProcBodyFree(Tcl_Obj *objPtr);
static int ProcessProcResultCode(Tcl_Interp *interp,
- char *procName, int nameLen, int returnCode);
+ Tcl_Obj *procNameObj, int returnCode,
+ int isMethod);
static int SetLambdaFromAny(Tcl_Interp *interp, Tcl_Obj *objPtr);
static int ProcCompileProc (Tcl_Interp *interp, Proc *procPtr,
Tcl_Obj *bodyPtr, Namespace *nsPtr,
@@ -109,12 +111,12 @@ Tcl_ProcObjCmd(
ClientData dummy, /* Not used. */
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
- Tcl_Obj *CONST objv[]) /* Argument objects. */
+ Tcl_Obj *const objv[]) /* Argument objects. */
{
register Interp *iPtr = (Interp *) interp;
Proc *procPtr;
char *fullName;
- CONST char *procName, *procArgs, *procBody;
+ const char *procName, *procArgs, *procBody;
Namespace *nsPtr, *altNsPtr, *cxtNsPtr;
Tcl_Command cmd;
Tcl_DString ds;
@@ -278,17 +280,17 @@ int
TclCreateProc(
Tcl_Interp *interp, /* interpreter containing proc */
Namespace *nsPtr, /* namespace containing this proc */
- CONST char *procName, /* unqualified name of this proc */
+ const char *procName, /* unqualified name of this proc */
Tcl_Obj *argsPtr, /* description of arguments */
Tcl_Obj *bodyPtr, /* command body */
Proc **procPtrPtr) /* returns: pointer to proc data */
{
Interp *iPtr = (Interp*)interp;
- CONST char **argArray = NULL;
+ const char **argArray = NULL;
register Proc *procPtr;
int i, length, result, numArgs;
- CONST char *args, *bytes, *p;
+ const char *args, *bytes, *p;
register CompiledLocal *localPtr = NULL;
Tcl_Obj *defPtr;
int precompiled = 0;
@@ -382,7 +384,7 @@ TclCreateProc(
for (i = 0; i < numArgs; i++) {
int fieldCount, nameLength, valueLength;
- CONST char **fieldValues;
+ const char **fieldValues;
/*
* Now divide the specifier up into name and default.
@@ -420,7 +422,7 @@ TclCreateProc(
p = fieldValues[0];
while (*p != '\0') {
if (*p == '(') {
- CONST char *q = p;
+ const char *q = p;
do {
q++;
} while (*q != '\0');
@@ -591,7 +593,7 @@ TclCreateProc(
int
TclGetFrame(
Tcl_Interp *interp, /* Interpreter in which to find frame. */
- CONST char *name, /* String describing frame. */
+ const char *name, /* String describing frame. */
CallFrame **framePtrPtr) /* Store pointer to frame here (or NULL if
* global frame indicated). */
{
@@ -680,7 +682,7 @@ TclObjGetFrame(
register Interp *iPtr = (Interp *) interp;
int curLevel, level, result;
CallFrame *framePtr;
- CONST char *name = TclGetString(objPtr);
+ const char *name = TclGetString(objPtr);
/*
* Parse object to figure out which level number to go to.
@@ -798,7 +800,7 @@ Tcl_UplevelObjCmd(
ClientData dummy, /* Not used. */
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
- Tcl_Obj *CONST objv[]) /* Argument objects. */
+ Tcl_Obj *const objv[]) /* Argument objects. */
{
register Interp *iPtr = (Interp *) interp;
int result;
@@ -888,7 +890,7 @@ Tcl_UplevelObjCmd(
Proc *
TclFindProc(
Interp *iPtr, /* Interpreter in which to look. */
- CONST char *procName) /* Name of desired procedure. */
+ const char *procName) /* Name of desired procedure. */
{
Tcl_Command cmd;
Tcl_Command origCmd;
@@ -1118,7 +1120,7 @@ TclInitCompiledLocals(
/*
*----------------------------------------------------------------------
*
- * TclObjInterpProc --
+ * TclObjInterpProc, ObjInterpProcEx --
*
* When a Tcl procedure gets invoked during bytecode evaluation, this
* object-based routine gets invoked to interpret the procedure.
@@ -1140,9 +1142,8 @@ TclObjInterpProc(
* invoked. */
int objc, /* Count of number of arguments to this
* procedure. */
- Tcl_Obj *CONST objv[]) /* Argument value objects. */
+ Tcl_Obj *const objv[]) /* Argument value objects. */
{
-
return ObjInterpProcEx(clientData, interp, objc, objv, /*skip*/ 1);
}
@@ -1154,25 +1155,14 @@ ObjInterpProcEx(
* invoked. */
int objc, /* Count of number of arguments to this
* procedure. */
- Tcl_Obj *CONST objv[], /* Argument value objects. */
+ Tcl_Obj *const objv[], /* Argument value objects. */
int skip) /* Number of initial arguments to be skipped,
- * ie, words in the "command name" */
+ * i.e., words in the "command name" */
{
Proc *procPtr = (Proc *) clientData;
Namespace *nsPtr = procPtr->cmdPtr->nsPtr;
CallFrame *framePtr, **framePtrPtr;
- register Var *varPtr;
- register CompiledLocal *localPtr;
- char *procName;
- int nameLen, localCt, numArgs, argCt, i, imax, result;
- Var *compiledLocals;
- Tcl_Obj *CONST *argObjs;
-
- /*
- * Get the procedure's name.
- */
-
- procName = Tcl_GetStringFromObj(objv[0], &nameLen);
+ int result;
/*
* If necessary, compile the procedure's body. The compiler will allocate
@@ -1182,13 +1172,12 @@ ObjInterpProcEx(
*/
result = ProcCompileProc(interp, procPtr, procPtr->bodyPtr, nsPtr,
- "body of proc", procName, &procPtr);
+ "body of proc", TclGetString(objv[0]), &procPtr);
if (result != TCL_OK) {
return result;
}
-
/*
* Set up and push a new call frame for the new procedure invocation.
* This call frame will execute in the proc's namespace, which might be
@@ -1205,11 +1194,50 @@ ObjInterpProcEx(
return result;
}
-
framePtr->objc = objc;
framePtr->objv = objv; /* ref counts for args are incremented below */
framePtr->procPtr = procPtr;
+ return TclObjInterpProcCore(interp, framePtr, objv[0], skip);
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * TclObjInterpProcCore --
+ *
+ * When a Tcl procedure, procedure-like method or lambda term gets
+ * invoked during bytecode evaluation, this object-based routine gets
+ * invoked to interpret the body.
+ *
+ * Results:
+ * A standard Tcl object result value.
+ *
+ * Side effects:
+ * Depends on the commands in the procedure body.
+ *
+ *----------------------------------------------------------------------
+ */
+
+int
+TclObjInterpProcCore(
+ register Tcl_Interp *interp,/* Interpreter in which procedure was
+ * invoked. */
+ CallFrame *framePtr, /* The context to execute. The procPtr field
+ * must be non-NULL. */
+ Tcl_Obj *procNameObj, /* Procedure name for error reporting. */
+ int skip) /* Number of initial arguments to be skipped,
+ * i.e., words in the "command name". */
+{
+ register Proc *procPtr = framePtr->procPtr;
+ register Var *varPtr;
+ register CompiledLocal *localPtr;
+ int localCt, numArgs, argCt, i, imax, result;
+ Var *compiledLocals;
+ Tcl_Obj *const *argObjs;
+ int isMethod = (framePtr->isProcCallFrame &
+ (FRAME_IS_METHOD | FRAME_IS_CONSTRUCTOR | FRAME_IS_DESTRUCTOR));
+
/*
* Create the "compiledLocals" array. Make sure it is large enough to hold
* all the procedure's compiled local variables, including its formal
@@ -1229,8 +1257,8 @@ ObjInterpProcEx(
*/
numArgs = procPtr->numArgs;
- argCt = objc-skip; /* set it to the number of args to the proc */
- argObjs = &objv[skip];
+ argCt = framePtr->objc-skip; /* set it to the number of args to the proc */
+ argObjs = &framePtr->objv[skip];
varPtr = framePtr->compiledLocals;
localPtr = procPtr->firstLocalPtr;
if (numArgs == 0) {
@@ -1314,7 +1342,7 @@ ObjInterpProcEx(
incorrectArgs:
codePtr = (ByteCode *) procPtr->bodyPtr->internalRep.otherValuePtr;
- InitCompiledLocals(interp, codePtr, localPtr, varPtr, nsPtr);
+ InitCompiledLocals(interp, codePtr, localPtr, varPtr, framePtr->nsPtr);
/*
* Build up desired argument list for Tcl_WrongNumArgs
@@ -1324,9 +1352,9 @@ ObjInterpProcEx(
ckalloc(sizeof(Tcl_Obj *) * (unsigned)(numArgs+1));
#ifdef AVOID_HACKS_FOR_ITCL
- desiredObjs[0] = objv[0];
+ desiredObjs[0] = framePtr->objv[0];
#else
- desiredObjs[0] = Tcl_NewListObj(skip, objv);
+ desiredObjs[0] = Tcl_NewListObj(skip, framePtr->objv);
#endif /* AVOID_HACKS_FOR_ITCL */
localPtr = procPtr->firstLocalPtr;
@@ -1380,7 +1408,7 @@ ObjInterpProcEx(
ByteCode *codePtr = (ByteCode *)
procPtr->bodyPtr->internalRep.otherValuePtr;
- InitCompiledLocals(interp, codePtr, localPtr, varPtr, nsPtr);
+ InitCompiledLocals(interp, codePtr, localPtr, varPtr, framePtr->nsPtr);
}
/*
@@ -1390,8 +1418,8 @@ ObjInterpProcEx(
#ifdef TCL_COMPILE_DEBUG
if (tclTraceExec >= 1) {
fprintf(stdout, "Calling proc ");
- for (i = 0; i < objc; i++) {
- TclPrintObject(stdout, objv[i], 15);
+ for (i = 0; i < framePtr->objc; i++) {
+ TclPrintObject(stdout, framePtr->objv[i], 15);
fprintf(stdout, " ");
}
fprintf(stdout, "\n");
@@ -1408,19 +1436,19 @@ ObjInterpProcEx(
if (result != TCL_OK) {
if (skip == 1) {
- result = ProcessProcResultCode(interp, procName, nameLen, result);
+ result = ProcessProcResultCode(interp, procNameObj, result,
+ isMethod);
} else {
/*
* Use a 'procName' that contains the first skip elements of objv
* for error reporting. This insures that we do not see just
* 'apply', but also the lambda expression that caused the error.
*/
-
+
Tcl_Obj *namePtr;
- namePtr = Tcl_NewListObj(skip, objv);
- procName = Tcl_GetStringFromObj(namePtr, &nameLen);
- result = ProcessProcResultCode(interp, procName, nameLen, result);
+ namePtr = Tcl_NewListObj(skip, framePtr->objv);
+ result = ProcessProcResultCode(interp, namePtr, result, isMethod);
TclDecrRefCount(namePtr);
}
}
@@ -1474,8 +1502,8 @@ TclProcCompileProc(
* but could be any code fragment compiled in
* the context of this procedure.) */
Namespace *nsPtr, /* Namespace containing procedure. */
- CONST char *description, /* string describing this body of code. */
- CONST char *procName) /* Name of this procedure. */
+ const char *description, /* string describing this body of code. */
+ const char *procName) /* Name of this procedure. */
{
return ProcCompileProc(interp, procPtr, bodyPtr, nsPtr, description,
procName, NULL);
@@ -1680,10 +1708,11 @@ static int
ProcessProcResultCode(
Tcl_Interp *interp, /* The interpreter in which the procedure was
* called and returned returnCode. */
- char *procName, /* Name of the procedure. Used for error
+ Tcl_Obj *procNameObj, /* Name of the procedure. Used for error
* messages and trace information. */
- int nameLen, /* Number of bytes in procedure's name. */
- int returnCode) /* The unexpected result code. */
+ int returnCode, /* The unexpected result code. */
+ int isMethod) /* Whether this is a procedure, method,
+ * constructor or destructor. */
{
Interp *iPtr = (Interp *) interp;
int overflow, limit = 60;
@@ -1703,10 +1732,111 @@ ProcessProcResultCode(
((returnCode == TCL_BREAK) ? "break" : "continue"),
"\" outside of a loop", NULL);
}
+ if (isMethod & FRAME_IS_CONSTRUCTOR) {
+ if (interp->errorLine != 0xDEADBEEF) { /* hack! */
+ CallContext *contextPtr =
+ ((Interp *) interp)->varFramePtr->ooContextPtr;
+ Method *mPtr = contextPtr->callChain[contextPtr->index].mPtr;
+ Tcl_Command declarer;
+ Tcl_Obj *objectNameObj;
+ const char *objectName, *kindName;
+ int objectNameLen;
+
+ if (mPtr->declaringObjectPtr != NULL) {
+ declarer = mPtr->declaringObjectPtr->command;
+ kindName = "object";
+ } else {
+ if (mPtr->declaringClassPtr == NULL) {
+ Tcl_Panic("method not declared in class or object");
+ }
+ declarer = mPtr->declaringClassPtr->thisPtr->command;
+ kindName = "class";
+ }
+ TclNewObj(objectNameObj);
+ Tcl_GetCommandFullName(interp, declarer, objectNameObj);
+ objectName = Tcl_GetStringFromObj(objectNameObj, &objectNameLen);
+ overflow = (objectNameLen > limit);
+
+ TclFormatToErrorInfo(interp,
+ "\n (%s \"%.*s%s\" constructor line %d)",
+ kindName, (overflow ? limit : objectNameLen), objectName,
+ (overflow ? "..." : ""), interp->errorLine);
+
+ TclDecrRefCount(objectNameObj);
+ }
+ } else if (isMethod & FRAME_IS_DESTRUCTOR) {
+ CallContext *contextPtr =
+ ((Interp *) interp)->varFramePtr->ooContextPtr;
+ Method *mPtr = contextPtr->callChain[contextPtr->index].mPtr;
+ Tcl_Command declarer;
+ Tcl_Obj *objectNameObj;
+ const char *objectName, *kindName;
+ int objectNameLen;
+
+ if (mPtr->declaringObjectPtr != NULL) {
+ declarer = mPtr->declaringObjectPtr->command;
+ kindName = "object";
+ } else {
+ if (mPtr->declaringClassPtr == NULL) {
+ Tcl_Panic("method not declared in class or object");
+ }
+ declarer = mPtr->declaringClassPtr->thisPtr->command;
+ kindName = "class";
+ }
+ TclNewObj(objectNameObj);
+ Tcl_GetCommandFullName(interp, declarer, objectNameObj);
+ objectName = Tcl_GetStringFromObj(objectNameObj, &objectNameLen);
+ overflow = (objectNameLen > limit);
+
+ TclFormatToErrorInfo(interp,
+ "\n (%s \"%.*s%s\" destructor line %d)",
+ kindName, (overflow ? limit : objectNameLen), objectName,
+ (overflow ? "..." : ""), interp->errorLine);
+
+ TclDecrRefCount(objectNameObj);
+ } else if (isMethod & FRAME_IS_METHOD) {
+ int nameLen, objectNameLen, objNameOverflow;
+ CallContext *contextPtr =
+ ((Interp *) interp)->varFramePtr->ooContextPtr;
+ Method *mPtr = contextPtr->callChain[contextPtr->index].mPtr;
+ Tcl_Obj *objectNameObj;
+ const char *objectName, *kindName, *methodName =
+ Tcl_GetStringFromObj(mPtr->namePtr, &nameLen);
+ Tcl_Command declarer;
+
+ if (mPtr->declaringObjectPtr != NULL) {
+ declarer = mPtr->declaringObjectPtr->command;
+ kindName = "object";
+ } else {
+ if (mPtr->declaringClassPtr == NULL) {
+ Tcl_Panic("method not declared in class or object");
+ }
+ declarer = mPtr->declaringClassPtr->thisPtr->command;
+ kindName = "class";
+ }
+ TclNewObj(objectNameObj);
+ Tcl_GetCommandFullName(interp, declarer, objectNameObj);
+ objectName = Tcl_GetStringFromObj(objectNameObj, &objectNameLen);
+ overflow = (nameLen > limit);
+ objNameOverflow = (objectNameLen > limit);
+
+ TclFormatToErrorInfo(interp,
+ "\n (%s \"%.*s%s\" method \"%.*s%s\" line %d)", kindName,
+ (objNameOverflow ? limit : objectNameLen), objectName,
+ (objNameOverflow ? "..." : ""), (overflow ? limit : nameLen),
+ methodName, (overflow ? "..." : ""), interp->errorLine);
+
+ TclDecrRefCount(objectNameObj);
+ } else {
+ int nameLen;
+ const char *procName = Tcl_GetStringFromObj(procNameObj, &nameLen);
+
overflow = (nameLen > limit);
+
TclFormatToErrorInfo(interp, "\n (procedure \"%.*s%s\" line %d)",
(overflow ? limit : nameLen), procName,
(overflow ? "..." : ""), interp->errorLine);
+ }
return TCL_ERROR;
}
@@ -1968,11 +2098,11 @@ DupLambdaInternalRep(
Tcl_Obj *srcPtr, /* Object with internal rep to copy. */
register Tcl_Obj *copyPtr) /* Object with internal rep to set. */
{
- Proc *procPtr = (Proc *) srcPtr->internalRep.twoPtrValue.ptr1;
- Tcl_Obj *nsObjPtr = (Tcl_Obj *) srcPtr->internalRep.twoPtrValue.ptr2;
+ Proc *procPtr = srcPtr->internalRep.twoPtrValue.ptr1;
+ Tcl_Obj *nsObjPtr = srcPtr->internalRep.twoPtrValue.ptr2;
- copyPtr->internalRep.twoPtrValue.ptr1 = (void *) procPtr;
- copyPtr->internalRep.twoPtrValue.ptr2 = (void *) nsObjPtr;
+ copyPtr->internalRep.twoPtrValue.ptr1 = procPtr;
+ copyPtr->internalRep.twoPtrValue.ptr2 = nsObjPtr;
procPtr->refCount++;
Tcl_IncrRefCount(nsObjPtr);
@@ -1984,8 +2114,8 @@ FreeLambdaInternalRep(
register Tcl_Obj *objPtr) /* CmdName object with internal representation
* to free. */
{
- Proc *procPtr = (Proc *) objPtr->internalRep.twoPtrValue.ptr1;
- Tcl_Obj *nsObjPtr = (Tcl_Obj *) objPtr->internalRep.twoPtrValue.ptr2;
+ Proc *procPtr = objPtr->internalRep.twoPtrValue.ptr1;
+ Tcl_Obj *nsObjPtr = objPtr->internalRep.twoPtrValue.ptr2;
procPtr->refCount--;
if (procPtr->refCount == 0) {
@@ -2033,7 +2163,7 @@ SetLambdaFromAny(
bodyPtr, &procPtr) != TCL_OK) {
TclFormatToErrorInfo(interp,
"\n (parsing lambda expression \"%s\")",
- Tcl_GetString(objPtr), NULL);
+ TclGetString(objPtr), NULL);
return TCL_ERROR;
}
@@ -2070,18 +2200,35 @@ SetLambdaFromAny(
objPtr->typePtr->freeIntRepProc(objPtr);
- objPtr->internalRep.twoPtrValue.ptr1 = (void *) procPtr;
- objPtr->internalRep.twoPtrValue.ptr2 = (void *) nsObjPtr;
+ objPtr->internalRep.twoPtrValue.ptr1 = procPtr;
+ objPtr->internalRep.twoPtrValue.ptr2 = nsObjPtr;
objPtr->typePtr = &lambdaType;
return TCL_OK;
}
+/*
+ *----------------------------------------------------------------------
+ *
+ * Tcl_ApplyObjCmd --
+ *
+ * This object-based function is invoked to process the "apply" Tcl
+ * command. See the user documentation for details on what it does.
+ *
+ * Results:
+ * A standard Tcl object result value.
+ *
+ * Side effects:
+ * Depends on the content of the lambda term (i.e., objv[1]).
+ *
+ *----------------------------------------------------------------------
+ */
+
int
Tcl_ApplyObjCmd(
ClientData dummy, /* Not used. */
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
- Tcl_Obj *CONST objv[]) /* Argument objects. */
+ Tcl_Obj *const objv[]) /* Argument objects. */
{
Interp *iPtr = (Interp *) interp;
Proc *procPtr = NULL;
@@ -2102,7 +2249,7 @@ Tcl_ApplyObjCmd(
lambdaPtr = objv[1];
if (lambdaPtr->typePtr == &lambdaType) {
- procPtr = (Proc *) lambdaPtr->internalRep.twoPtrValue.ptr1;
+ procPtr = lambdaPtr->internalRep.twoPtrValue.ptr1;
}
#define JOE_EXTENSION 0
@@ -2129,7 +2276,7 @@ Tcl_ApplyObjCmd(
if (result != TCL_OK) {
return result;
}
- procPtr = (Proc *) lambdaPtr->internalRep.twoPtrValue.ptr1;
+ procPtr = lambdaPtr->internalRep.twoPtrValue.ptr1;
}
procPtr->cmdPtr = &cmd;
@@ -2138,7 +2285,7 @@ Tcl_ApplyObjCmd(
* for that namespace. Note that TclObjInterpProc() will pop it.
*/
- nsObjPtr = (Tcl_Obj *) lambdaPtr->internalRep.twoPtrValue.ptr2;
+ nsObjPtr = lambdaPtr->internalRep.twoPtrValue.ptr2;
result = TclGetNamespaceFromObj(interp, nsObjPtr, &nsPtr);
if (result != TCL_OK) {
return result;
diff --git a/generic/tclVar.c b/generic/tclVar.c
index 0576114..6e515d2 100644
--- a/generic/tclVar.c
+++ b/generic/tclVar.c
@@ -15,7 +15,7 @@
* See the file "license.terms" for information on usage and redistribution of
* this file, and for a DISCLAIMER OF ALL WARRANTIES.
*
- * RCS: @(#) $Id: tclVar.c,v 1.122 2006/10/05 11:38:50 msofer Exp $
+ * RCS: @(#) $Id: tclVar.c,v 1.123 2006/10/20 14:04:01 dkf Exp $
*/
#include "tclInt.h"
@@ -39,6 +39,14 @@ static CONST char *isArrayElement =
"name refers to an element in an array";
/*
+ * A test to see if we are in a call frame that has local variables. This is
+ * true if we are inside a procedure body or an object method body.
+ */
+
+#define IsLocal(framePtr) \
+ ((framePtr)->isProcCallFrame & (FRAME_IS_PROC | FRAME_IS_METHOD))
+
+/*
* Forward references to functions defined later in this file:
*/
@@ -399,7 +407,7 @@ TclObjLookupVar(
int localIndex = (int) part1Ptr->internalRep.longValue;
if ((varFramePtr != NULL)
- && (varFramePtr->isProcCallFrame & FRAME_IS_PROC)
+ && IsLocal(varFramePtr)
&& !(flags & (TCL_GLOBAL_ONLY | TCL_NAMESPACE_ONLY))
&& (localIndex < varFramePtr->numCompiledLocals)) {
/*
@@ -423,13 +431,12 @@ TclObjLookupVar(
(flags & TCL_GLOBAL_ONLY) ||
(*part1==':' && *(part1+1)==':') ||
(varFramePtr == NULL) ||
- (!(varFramePtr->isProcCallFrame & FRAME_IS_PROC)
- && (nsPtr == iPtr->globalNsPtr)));
+ (!IsLocal(varFramePtr) && (nsPtr == iPtr->globalNsPtr)));
useReference = useGlobal || ((cachedNsPtr == nsPtr) && (
(flags & TCL_NAMESPACE_ONLY) ||
(varFramePtr &&
- !(varFramePtr->isProcCallFrame & FRAME_IS_PROC) &&
+ !IsLocal(varFramePtr) &&
!(flags & TCL_GLOBAL_ONLY) &&
/*
* Careful: an undefined ns variable could be hiding a valid
@@ -745,7 +752,7 @@ TclLookupSimpleVar(
if (((flags & (TCL_GLOBAL_ONLY | TCL_NAMESPACE_ONLY)) != 0)
|| (varFramePtr == NULL)
- || !(varFramePtr->isProcCallFrame & FRAME_IS_PROC)
+ || !IsLocal(varFramePtr)
|| (strstr(varName, "::") != NULL)) {
CONST char *tail;
int lookGlobal;
@@ -3239,7 +3246,7 @@ ObjMakeUpvar(
if (((otherP2 ? arrayPtr->nsPtr : otherPtr->nsPtr) == NULL)
&& ((myFlags & (TCL_GLOBAL_ONLY | TCL_NAMESPACE_ONLY))
|| (varFramePtr == NULL)
- || !(varFramePtr->isProcCallFrame & FRAME_IS_PROC)
+ || !IsLocal(varFramePtr)
|| (strstr(myName, "::") != NULL))) {
Tcl_AppendResult((Tcl_Interp *) iPtr, "bad variable name \"",
myName, "\": upvar won't create namespace variable that ",
@@ -3290,7 +3297,7 @@ TclPtrMakeUpvar(
CONST char *p;
if (index >= 0) {
- if (!(varFramePtr->isProcCallFrame & FRAME_IS_PROC)) {
+ if (!IsLocal(varFramePtr)) {
Tcl_Panic("ObjMakeUpvar called with an index outside from a proc");
}
varPtr = &(varFramePtr->compiledLocals[index]);
@@ -3553,8 +3560,7 @@ Tcl_GlobalObjCmd(
* If we are not executing inside a Tcl procedure, just return.
*/
- if ((iPtr->varFramePtr == NULL)
- || !(iPtr->varFramePtr->isProcCallFrame & FRAME_IS_PROC)) {
+ if ((iPtr->varFramePtr == NULL) || !IsLocal(iPtr->varFramePtr)) {
return TCL_OK;
}
@@ -3705,8 +3711,7 @@ Tcl_VariableObjCmd(
* linked to the new namespace variable "varName".
*/
- if ((iPtr->varFramePtr != NULL)
- && (iPtr->varFramePtr->isProcCallFrame & FRAME_IS_PROC)) {
+ if ((iPtr->varFramePtr != NULL) && IsLocal(iPtr->varFramePtr)) {
/*
* varName might have a scope qualifier, but the name for the
* local "link" variable must be the simple name at the tail.
generated by cgit v0.12 at 2024-11-05 06:12:01 (GMT)