diff options
| -rw-r--r-- | ChangeLog | 8 | ||||
| -rw-r--r-- | doc/Class.3 | 231 | ||||
| -rw-r--r-- | doc/Method.3 | 249 | ||||
| -rw-r--r-- | doc/class.n | 126 | ||||
| -rw-r--r-- | doc/copy.n | 54 | ||||
| -rw-r--r-- | doc/define.n | 269 | ||||
| -rw-r--r-- | doc/info.n | 220 | ||||
| -rw-r--r-- | doc/my.n | 56 | ||||
| -rw-r--r-- | doc/next.n | 195 | ||||
| -rw-r--r-- | doc/object.n | 101 | ||||
| -rw-r--r-- | doc/self.n | 111 | ||||
| -rw-r--r-- | generic/tclBasic.c | 6 | ||||
| -rw-r--r-- | generic/tclInt.h | 19 | ||||
| -rw-r--r-- | generic/tclOO.c | 2179 | ||||
| -rw-r--r-- | generic/tclOO.decls | 190 | ||||
| -rw-r--r-- | generic/tclOO.h | 128 | ||||
| -rw-r--r-- | generic/tclOOBasic.c | 925 | ||||
| -rw-r--r-- | generic/tclOOCall.c | 1211 | ||||
| -rw-r--r-- | generic/tclOODecls.h | 282 | ||||
| -rw-r--r-- | generic/tclOODefineCmds.c | 1831 | ||||
| -rw-r--r-- | generic/tclOOInfo.c | 1271 | ||||
| -rw-r--r-- | generic/tclOOInt.h | 579 | ||||
| -rw-r--r-- | generic/tclOOIntDecls.h | 209 | ||||
| -rw-r--r-- | generic/tclOOMethod.c | 1425 | ||||
| -rw-r--r-- | generic/tclOOStubInit.c | 79 | ||||
| -rw-r--r-- | generic/tclOOStubLib.c | 82 | ||||
| -rw-r--r-- | tests/info.test | 10 | ||||
| -rw-r--r-- | tests/interp.test | 15 | ||||
| -rw-r--r-- | tests/oo.test | 1769 | ||||
| -rw-r--r-- | unix/Makefile.in | 52 | ||||
| -rw-r--r-- | unix/tclConfig.h.in | 6 |
31 files changed, 13866 insertions, 22 deletions
@@ -1,3 +1,11 @@ +2008-05-31 Donal K. Fellows <dkf@users.sf.net> + + TIP#257 IMPLEMENTATION + + * generic/tclOO*, doc/*, tests/oo.test: Port of implementation of + TclOO to sit directly inside Tcl. Note that this is incomplete (e.g. + no build support yet for Windows). + 2008-05-26 Jeff Hobbs <jeffh@ActiveState.com> * tests/io.test (io-53.9): need to close chan before removing file. diff --git a/doc/Class.3 b/doc/Class.3 new file mode 100644 index 0000000..8954ab7 --- /dev/null +++ b/doc/Class.3 @@ -0,0 +1,231 @@ +'\" +'\" Copyright (c) 2007 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: Class.3,v 1.1 2008/05/31 11:42:06 dkf Exp $ +'\" +.so man.macros +.TH Tcl_Class 3 0.1 TclOO "TclOO Library Functions" +.BS +'\" Note: do not modify the .SH NAME line immediately below! +.SH NAME +Tcl_ClassGetMetadata, Tcl_ClassSetMetadata, Tcl_CopyObjectInstance, Tcl_GetClassAsObject, Tcl_GetObjectAsClass, Tcl_GetObjectCommand, Tcl_GetObjectNamespace, Tcl_NewObjectInstance, Tcl_ObjectDeleted, Tcl_ObjectGetMetadata, Tcl_ObjectGetMethodNameMapper, Tcl_ObjectSetMetadata, Tcl_ObjectSetMethodNameMapper \- manipulate objects and classes +.SH SYNOPSIS +.nf +\fB#include <tclOO.h>\fR +.sp +Tcl_Object +\fBTcl_GetObjectFromObj\fR(\fIinterp, objPtr\fR) +.sp +Tcl_Object +\fBTcl_GetClassAsObject\fR(\fIclass\fR) +.sp +Tcl_Class +\fBTcl_GetObjectAsClass\fR(\fIobject\fR) +.sp +Tcl_Command +\fBTcl_GetObjectCommand\fR(\fIobject\fR) +.sp +Tcl_Namespace * +\fBTcl_GetObjectNamespace\fR(\fIobject\fR) +.sp +Tcl_Object +\fBTcl_NewObjectInstance\fR(\fIinterp, class, name, nsName, objc, objv, skip\fR) +.sp +Tcl_Object +\fBTcl_CopyObjectInstance\fR(\fIinterp, object, name, nsName\fR) +.sp +int +\fBTcl_ObjectDeleted\fR(\fIobject\fR) +.sp +ClientData +\fBTcl_ObjectGetMetadata\fR(\fIobject, metaTypePtr\fR) +.sp +\fBTcl_ObjectSetMetadata\fR(\fIobject, metaTypePtr, metadata\fR) +.sp +ClientData +\fBTcl_ClassGetMetadata\fR(\fIclass, metaTypePtr\fR) +.sp +\fBTcl_ClassSetMetadata\fR(\fIclass, metaTypePtr, metadata\fR) +.sp +Tcl_ObjectMapMethodNameProc +\fBTcl_ObjectGetMethodNameMapper\fR(\fIobject\fR) +.sp +\fBTcl_ObjectSetMethodNameMapper\fR(\fIobject\fR, \fImethodNameMapper\fR) +.SH ARGUMENTS +.AS ClientData metadata in/out +.AP Tcl_Interp *interp in/out +Interpreter providing the context for looking up or creating an object, and +into whose result error messages will be written on failure. +.AP Tcl_Obj *objPtr in +The name of the object to look up. +.AP Tcl_Object object in +Reference to the object to operate upon. +.AP Tcl_Class class in +Reference to the class to operate upon. +.AP "const char" *name in +The name of the object to create, or NULL if a new unused name is to be +automatically selected. +.AP "const char" *nsName in +The name of the namespace to create for the object's private use, or NULL if a +new unused name is to be automatically selected. +.AP int objc in +The number of elements in the \fIobjv\fR array. +.AP "Tcl_Obj *const" *objv in +The arguments to the command to create the instance of the class. +.AP int skip in +The number of arguments at the start of the argument array, \fIobjv\fR, that +are not arguments to any constructors. +.AP Tcl_ObjectMetadataType *metaTypePtr in +The type of \fImetadata\fR being set with \fBTcl_ClassSetMetadata\fR or +retrieved with \fBTcl_ClassGetMetadata\fR. +.AP ClientData metadata in +An item of metadata to attach to the class, or NULL to remove the metadata +associated with a particular \fImetaTypePtr\fR. +.AP "Tcl_ObjectMapMethodNameProc" "methodNameMapper" in +A pointer to a function to call to adjust the mapping of objects and method +names to implementations, or NULL when no such mapping is required. +.BE +.SH DESCRIPTION +.PP +Objects are typed entities that have a set of operations ("methods") +associated with them. Classes are objects that can manufacture objects. Each +class can be viewed as an object itself; the object view can be retrieved +using \fBTcl_GetClassAsObject\fR which always returns the object when applied +to a non-destroyed class, and an object can be viewed as a class with the aid +of the \fBTcl_GetObjectAsClass\fR (which either returns the class, or NULL if +the object is not a class). An object may be looked up using the +\fBTcl_GetObjectFromObj\fR function, which either returns an object or NULL +(with an error message in the interpreter result) if the object cannot be +found. The correct way to look up a class by name is to look up the object +with that name, and then to use \fBTcl_GetObjectAsClass\fR. +.PP +Every object has its own command and namespace associated with it. The command +may be retrieved using the \fBTcl_GetObjectCommand\fR function, and the +namespace may be retrieved using the \fBTcl_GetObjectNamespace\fR function. +.PP +Instances of classes are created using \fBTcl_NewObjectInstance\fR, which +takes creates an object from any class (and which is internally called by both +the \fBcreate\fR and \fBnew\fR methods of the \fBoo::class\fR class). It takes +parameters that optionally give the name of the object and namespace to +create, and which describe the arguments to pass to to the class's constructor +(if any). The result of the function will be either a reference to the newly +created object, or NULL if the creation failed (when an error message will be +left in the interpreter result). In addition, objects may be copied by using +\fBTcl_CopyObjectInstance\fR which creates a copy of an object without running +any constructors. +.SH "OBJECT AND CLASS METADATA" +.PP +Every object and every class may have arbitrary amounts of metadata attached +to it, which the object or class attaches no meaning to beyond what is +described in a Tcl_ObjectMetadataType structure instance. Metadata to be +attached is described by the the type of the metadata (given in the +\fImetaTypePtr\fR argument) and an arbitrary pointer (the \fImetadata\fR +argument) that are given to \fBTcl_ObjectSetMetadata\fR and +\fBTcl_ClassSetMetadata\fR, and a particular piece of metadata can be +retrieved given its type using \fBTcl_ObjectGetMetadata\fR and +\fBTcl_ClassGetMetadata\fR. If the \fImetadata\fR parameter to either +\fBTcl_ObjectSetMetadata\fR or \fBTcl_ClassSetMetadata\fR is NULL, the +metadata is removed if it was attached, and the results of +\fBTcl_ObjectGetMetadata\fR and \fBTcl_ClassGetMetadata\fR are NULL if the +given type of metadata was not attached. It is not an error to request or +remove a piece of metadata that was not attached. +.SS "TCL_OBJECTMETADATATYPE STRUCTURE" +.PP +The contents of the Tcl_ObjectMetadataType structure are as follows: +.PP +.CS + typedef const struct { + int \fIversion\fR; + const char *\fIname\fR; + Tcl_ObjectMetadataDeleteProc \fIdeleteProc\fR; + Tcl_CloneProc \fIcloneProc\fR; + } \fBTcl_ObjectMetadataType\fR; +.CE +.PP +The \fIversion\fR field allows for future expansion of the structure, and +should always be declared equal to TCL_OO_METADATA_VERSION_CURRENT. The +\fIname\fR field provides a human-readable name for the type, and is reserved +for debugging. +.PP +The \fIdeleteProc\fR field gives a function of type +Tcl_ObjectMetadataDeleteProc that is used to delete a particular piece of +metadata, and is called when the attached metadata is replaced or removed; the +field must not be NULL. +.PP +The \fIcloneProc\fR field gives a function that is used to copy a piece of +metadata (used when a copy of an object is created using +\fBTcl_CopyObjectInstance\fR); if NULL, the metadata will be just directly +copied. +.SS "TCL_OBJECTMETADATADELETEPROC FUNCTION SIGNATURE" +.PP +Functions matching this signature are used to delete metadata associated with +a class or object. +.PP +.CS + typedef void (*\fBTcl_ObjectMetadataDeleteProc\fR) ( + ClientData \fImetadata\fR); +.CE +.PP +The \fImetadata\fR argument gives the address of the metadata to be +deleted. +.SS "TCL_CLONEPROC FUNCTION SIGNATURE" +.PP +Functions matching this signature are used to create copies of metadata +associated with a class or object. +.PP +.CS + typedef int (*\fBTcl_CloneProc\fR) ( + Tcl_Interp *\fIinterp\fR, + ClientData \fIsrcMetadata\fR, + ClientData *\fIdstMetadataPtr\fR); +.CE +.PP +The \fIinterp\fR argument gives a place to write an error message when the +attempt to clone the object is to fail, in which case the clone procedure must +also return TCL_ERROR; it should return TCL_OK otherwise. +The \fIsrcMetadata\fR argument gives the address of the metadata to be cloned, +and the cloned metadata should be written into the variable pointed to by +\fIdstMetadataPtr\fR; a NULL should be written if the metadata is to not be +cloned but the overall object copy operation is still to succeed. +.SH "OBJECT METHOD NAME MAPPING" +It is possible to control, on a per-object basis, what methods are invoked +when a particular method is invoked. Normally this is done by looking up the +method name in the object and then in the class hierarchy, but fine control of +exactly what the value used to perform the look up is afforded through the +ability to set a method name mapper callback via +\fBTcl_ObjectSetMethodNameMapper\fR (and its introspection counterpart, +\fBTcl_ObjectGetMethodNameMapper\fR, which returns the current mapper). The +current mapper (if any) is invoked immediately before looking up what chain of +method implementations is to be used. +.SS "TCL_OBJECTMAPMETHODNAMEPROC FUNCTION SIGNATURE" +The \fITcl_ObjectMapMethodNameProc\fR callback is defined as follows: +.PP +.CS + typedef int (*\fBTcl_ObjectMapMethodNameProc\fR)( + Tcl_Interp *\fIinterp\fR, + Tcl_Object \fIobject\fR, + Tcl_Class *\fIstartClsPtr\fR, + Tcl_Obj *\fImethodNameObj\fR); +.CE +.PP +The \fIinterp\fR parameter (and the integer result) follow normal Tcl result +rules for error reporting. The \fIobject\fR parameter says which object is +being processed. The \fIstartClsPtr\fR parameter points to a variable that +contains the first class to provide a definition in the method chain to +process, or NULL if the whole chain is to be processed (the argument itself is +never NULL); this variable may be updated by the callback. The +\fImethodNameObj\fR parameter gives an unshared object containing the name of +the method being invoked, as provided by the user; this object may be updated +by the callback. +.SH "SEE ALSO" +Method(3), oo::class(n), oo::copy(n), oo::define(n), oo::object(n) +.SH KEYWORDS +class, constructor, object + +.\" Local variables: +.\" mode: nroff +.\" fill-column: 78 +.\" End: diff --git a/doc/Method.3 b/doc/Method.3 new file mode 100644 index 0000000..341dcac --- /dev/null +++ b/doc/Method.3 @@ -0,0 +1,249 @@ +'\" +'\" Copyright (c) 2007 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: Method.3,v 1.1 2008/05/31 11:42:06 dkf Exp $ +'\" +.so man.macros +.TH Tcl_Method 3 0.1 TclOO "TclOO Library Functions" +.BS +'\" Note: do not modify the .SH NAME line immediately below! +.SH NAME +Tcl_ClassSetConstructor, Tcl_ClassSetDestructor, Tcl_MethodDeclarerClass, Tcl_MethodDeclarerObject, Tcl_MethodIsPublic, Tcl_MethodIsType, Tcl_MethodName, Tcl_NewInstanceMethod, Tcl_NewMethod, Tcl_ObjectContextIsFiltering, Tcl_ObjectContextMethod, Tcl_ObjectContextObject, Tcl_ObjectContextSkippedArgs \- manipulate methods and method-call contexts +.SH SYNOPSIS +.nf +\fB#include <tclOO.h>\fR +.sp +Tcl_Method +\fBTcl_NewMethod\fR(\fIinterp, class, nameObj, isPublic, + methodTypePtr, clientData\fR) +.sp +Tcl_Method +\fBTcl_NewInstanceMethod\fR(\fIinterp, object, nameObj, isPublic, + methodTypePtr, clientData\fR) +.sp +\fBTcl_ClassSetConstructor\fR(\fIclass, method\fR) +.sp +\fBTcl_ClassSetDestructor\fR(\fIclass, method\fR) +.sp +Tcl_Class +\fBTcl_MethodDeclarerClass\fR(\fImethod\fR) +.sp +Tcl_Object +\fBTcl_MethodDeclarerObject\fR(\fImethod\fR) +.sp +Tcl_Obj * +\fBTcl_MethodName\fR(\fImethod\fR) +.sp +int +\fBTcl_MethodIsPublic\fR(\fImethod\fR) +.sp +int +\fBTcl_MethodIsType\fR(\fImethod, methodTypePtr, clientDataPtr\fR) +.sp +int +\fBTcl_ObjectContextInvokeNext\fR(\fIinterp, context, objc, objv, skip\fR) +.sp +int +\fBTcl_ObjectContextIsFiltering\fR(\fIcontext\fR) +.sp +Tcl_Method +\fBTcl_ObjectContextMethod\fR(\fIcontext\fR) +.sp +Tcl_Object +\fBTcl_ObjectContextObject\fR(\fIcontext\fR) +.sp +int +\fBTcl_ObjectContextSkippedArgs\fR(\fIcontext\fR) +.SH ARGUMENTS +.AS ClientData clientData in +.AP Tcl_Interp *interp in/out +The interpreter holding the object or class to create or update a method in. +.AP Tcl_Object object in +The object to create the method in. +.AP Tcl_Class class in +The class to create the method in. +.AP Tcl_Obj *nameObj in +The name of the method to create. Should not be NULL unless creating +constructors or destructors. +.AP int isPublic in +A boolean flag saying whether the method is to be exported. +.AP Tcl_MethodType *methodTypePtr in +A description of the type of the method to create, or the type of method to +compare against. +.AP ClientData clientData in +A piece of data that is passed to the implementation of the method without +interpretation. +.AP ClientData *clientDataPtr out +A pointer to a variable in which to write the \fIclientData\fR value supplied +when the method was created. If NULL, the \fIclientData\fR value will not be +retrieved. +.AP Tcl_Method method in +A reference to a method to query. +.AP Tcl_ObjectContext context in +A reference to a method-call context. Note that client code \fImust not\fR +retain a reference to a context. +.AP int objc in +The number of arguments to pass to the method implementation. +.AP "Tcl_Obj *const" *objv in +An array of arguments to pass to the method implementation. +.AP int skip in +The number of arguments passed to the method implementation that do not +represent "real" arguments. +.BE +.SH DESCRIPTION +.PP +A method is an operation carried out on an object that is associated with the +object. Every method must be attached to either an object or a class; methods +attached to a class are associated with all instances (direct and indirect) of +that class. +.PP +Given a method, the entity that declared it can be found using +\fBTcl_MethodDeclarerClass\fR which returns the class that the method is +attached to (or NULL if the method is not attached to any class) and +\fBTcl_MethodDeclarerObject\fR which returns the object that the method is +attached to (or NULL if the method is not attached to an object). The name of +the method can be retrieved with \fBTcl_MethodName\fR and whether the method +is exported is retrieved with \fBTcl_MethodIsPublic\fR. The type of the method +can also be introspected upon to a limited degree; the function +\fBTcl_MethodIsType\fR returns whether a method is of a particular type, +assigning the per-method \fIclientData\fR to the variable pointed to by +\fIclientDataPtr\fR if (that is non-NULL) if the type is matched. +.SS "METHOD CREATION" +.PP +Methods are created by \fBTcl_NewMethod\fR and \fBTcl_NewClassMethod\fR, which +create a method attached to an object or a class respectively. In both cases, +the \fInameObj\fR argument gives the name of the method to create, the +\fIisPublic\fR argument states whether the method should be exported +initially, the \fImethodTypePtr\fR argument describes the implementation of +the method (see the \fBMETHOD TYPES\fR section below) and the \fIclientData\fR +argument gives some implementation-specific data that is passed on to the +implementation of the method when it is called. +.PP +When the \fInameObj\fR argument to \fBTcl_NewClassMethod\fR is NULL, an +unnamed method is created, which is used for constructors and destructors. +Constructors should be installed into their class using the +\fBTcl_ClassSetConstructor\fR function, and destructors (which must not +require any arguments) should be installed into their class using the +\fBTcl_ClassSetDestructor\fR function. Unnamed methods should not be used for +any other purpose, and named methods should not be used as either constructors +or destructors. Also note that a NULL \fImethodTypePtr\fR is used to provide +internal signalling, and should not be used in client code. +.SS "METHOD CALL CONTEXTS" +.PP +When a method is called, a method-call context reference is passed in as one +of the arguments to the implementation function. This context can be inspected +to provide information about the caller, but should not be retained beyond the +moment when the method call terminates. +.PP +The method that is being called can be retrieved from the context by using +\fBTcl_ObjectContextMethod\fR, and the object that caused the method to be +invoked can be retrieved with \fBTcl_ObjectContextObject\fR. The number of +arguments that are to be skipped (e.g. the object name and method name in a +normal method call) is read with \fBTcl_ObjectContextSkippedArgs\fR, and the +context can also report whether it is working as a filter for another method +through \fBTcl_ObjectContextIsFiltering\fR. +.PP +During the execution of a method, the method implementation may choose to +invoke the stages of the method call chain that come after the current method +implementation. This (the core of the \fBnext\fR command) is done using +\fBTcl_ObjectContextInvokeNext\fR. Note that this function does not manipulate +the call-frame stack, unlike the \fBnext\fR command; if the method +implementation has pushed one or more extra frames on the stack as part of its +implementation, it is also responsible for temporarily popping those frames +from the stack while the \fBTcl_ObjectContextInvokeNext\fR function is +executing. Note also that the method-call context is \fInever\fR deleted +during the execution of this function. +.SH "METHOD TYPES" +.PP +The types of methods are described by a pointer to a Tcl_MethodType structure, +which is defined as: +.PP +.CS + typedef const struct { + int \fIversion\fR; + const char *\fIname\fR; + Tcl_MethodCallProc \fIcallProc\fR; + Tcl_MethodDeleteProc \fIdeleteProc\fR; + Tcl_CloneProc \fIcloneProc\fR; + } \fBTcl_MethodType\fR; +.CE +.PP +The \fIversion\fR field allows for future expansion of the structure, and +should always be declared equal to TCL_OO_METHOD_VERSION_CURRENT. The +\fIname\fR field provides a human-readable name for the type, and is reserved +for debugging. +.PP +The \fIcallProc\fR field gives a function that is called when the method is +invoked; it must never be NULL. +.PP +The \fIdeleteProc\fR field gives a function that is used to delete a +particular method, and is called when the method is replaced or removed; if +the field is NULL, it is assumed that the method's \fIclientData\fR needs no +special action to delete. +.PP +The \fIcloneProc\fR field is either a function that is used to copy a method's +\fIclientData\fR (as part of \fBTcl_CopyObjectInstance\fR) or NULL to indicate +that the \fIclientData\fR can just be copied directly. +.SS "TCL_METHODCALLPROC FUNCTION SIGNATURE" +.PP +Functions matching this signature are called when the method is invoked. +.PP +.CS + typedef int (*\fBTcl_MethodCallProc\fR) ( + ClientData \fIclientData\fR, + Tcl_Interp *\fIinterp\fR, + Tcl_ObjectContext \fIobjectContext\fR, + int \fIobjc\fR, + Tcl_Obj *const *\fIobjv\fR); +.CE +.PP +The \fIclientData\fR argument to a Tcl_MethodCallProc is the value that was +given when the method was created, the \fIinterp\fR is a place in which to +execute scripts and access variables as well as being where to put the result +of the method, and the \fIobjc\fR and \fIobjv\fR fields give the parameter +objects to the method. The calling context of the method can be discovered +through the \fIobjectContext\fR argument, and the return value from a +Tcl_MethodCallProc is any Tcl return code (e.g. TCL_OK, TCL_ERROR). +.SS "TCL_METHODDELETEPROC FUNCTION SIGNATURE" +.PP +Functions matching this signature are used when a method is deleted, whether +through a new method being created or because the object or class is deleted. +.PP +.CS + typedef void (*\fBTcl_MethodDeleteProc\fR) ( + ClientData \fIclientData\fR); +.CE +.PP +The \fIclientData\fR argument to a Tcl_MethodDeleteProc will be the same as +the value passed to the \fIclientData\fR argument to \fBTcl_NewMethod\fR or +\fBTcl_NewClassMethod\fR when the method was created. +.SS "TCL_CLONEPROC FUNCTION SIGNATURE" +.PP +Functions matching this signature are used to copy a method when the object or +class is copied using \fBTcl_CopyObjectInstance\fR (or \fBoo::copy\fR). +.PP +.CS + typedef int (*\fBTcl_CloneProc\fR) ( + Tcl_Interp *\fIinterp\fR, + ClientData \fIoldClientData\fR, + ClientData *\fInewClientDataPtr\fR); +.CE +.PP +The \fIinterp\fR argument gives a place to write an error message when the +attempt to clone the object is to fail, in which case the clone procedure must +also return TCL_ERROR; it should return TCL_OK otherwise. +The \fIoldClientData\fR field to a Tcl_CloneProc gives the value from the +method being copied from, and the \fInewClientDataPtr\fR field will point to +a variable in which to write the value for the method being copied to. +.SH "SEE ALSO" +Class(3), oo::class(n), oo::define(n), oo::object(n) +.SH KEYWORDS +constructor, method, object + +.\" Local variables: +.\" mode: nroff +.\" fill-column: 78 +.\" End: diff --git a/doc/class.n b/doc/class.n new file mode 100644 index 0000000..02dfc46 --- /dev/null +++ b/doc/class.n @@ -0,0 +1,126 @@ +'\" +'\" Copyright (c) 2007 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: class.n,v 1.1 2008/05/31 11:42:06 dkf Exp $ +'\" +.so man.macros +.TH class n 0.1 TclOO "TclOO Commands" +.BS +'\" Note: do not modify the .SH NAME line immediately below! +.SH NAME +oo::class \- class of all classes +.SH SYNOPSIS +.nf +package require TclOO + +\fBoo::class\fI method \fR?\fIarg ...\fR? +.fi +.SH "CLASS HIERARCHY" +.nf +\fBoo::object\fR + \(-> \fBoo::class\fR +.fi +.BE + +.SH DESCRIPTION +The \fBoo::class\fR class is the class of all classes; every class is an +instance of this class, which is consequently an instance of itself. This +class is a subclass of \fBoo::object\fR, so every class is also an object. +Additional metaclasses (i.e. classes of classes) can be defined if necessary +by subclassing \fBoo::class\fR. Note that the \fBoo::class\fR object hides the +\fBnew\fR method on itself, so new classes should always be made using the +\fBcreate\fR method. +.SS CONSTRUCTOR +The constructor of the \fBoo::class\fR class takes an optional argument which, +if present, is sent to the \fBoo::define\fR command (along with the name of +the newly-created class) to allow the class to be conveniently configured at +creation time. +.SS DESTRUCTOR +The \fBoo::class\fR class does not define an explicit destructor. However, +when a class is destroyed, all its subclasses and instances are also +destroyed, along with all objects that it has been mixed into. +.SS "EXPORTED METHODS" +.TP +\fIcls \fBcreate \fIname \fR?\fIarg ...\fR? +. +This creates a new instance of the class \fIcls\fR called \fIname\fR (which is +resolved within the calling context's namespace if not fully qualified), +passing the arguments, \fIarg ...\fR, to the constructor, and (if that returns +a successful result) returning the fully qualified name of the created object +(the result of the constructor is ignored). If the constructor fails (i.e. +returns a non-OK result) then the object is destroyed and the error message is +the result of this method call. +.TP +\fIcls \fBnew \fR?\fIarg ...\fR? +. +This creates a new instance of the class \fIcls\fR with a new unique name, +passing the arguments, \fIarg ...\fR, to the constructor, and (if that returns +a successful result) returning the fully qualified name of the created object +(the result of the constructor is ignored). If the constructor fails (i.e. +returns a non-OK result) then the object is destroyed and the error message is +the result of this method call. Note that this method is not exported by the +\fBoo::class\fR object itself, so classes should not be created using this +method. +.SS "NON-EXPORTED METHODS" +The \fBoo::class\fR class supports the following non-exported methods: +.TP +\fIobj \fBcreateWithNamespace\fI name nsName\fR ?\fIarg ...\fR? +. +This creates a new instance of the class \fIcls\fR called \fIname\fR (which is +resolved within the calling context's namespace if not fully qualified), +passing the arguments, \fIarg ...\fR, to the constructor, and (if that returns +a successful result) returning the fully qualified name of the created object +(the result of the constructor is ignored). The name of the instance's +internal namespace will be \fInsName\fR unless that namespace already exists +(when an arbitrary name will be chosen instead). If the constructor fails +(i.e. returns a non-OK result) then the object is destroyed and the error +message is the result of this method call. +.SH EXAMPLES +This example defines a simple class hierarchy and creates a new instance of +it. It then invokes a method of the object before destroying the hierarchy and +showing that the destruction is transitive. +.CS +\fBoo::class create\fR fruit { + method eat {} { + puts "yummy!" + } +} +\fBoo::class create\fR banana { + superclass fruit + constructor {} { + my variable peeled + set peeled 0 + } + method peel {} { + my variable peeled + set peeled 1 + puts "skin now off" + } + method edible? {} { + my variable peeled + return $peeled + } + method eat {} { + if {![my edible?]} { + my peel + } + next + } +} +set b [banana \fBnew\fR] +$b eat \fI\(-> prints "skin now off" and "yummy!"\fR +fruit destroy +$b eat \fI\(-> error "unknown command"\fR +.CE +.SH "SEE ALSO" +oo::define(n), oo::object(n) +.SH KEYWORDS +class, metaclass, object + +.\" Local variables: +.\" mode: nroff +.\" fill-column: 78 +.\" End: diff --git a/doc/copy.n b/doc/copy.n new file mode 100644 index 0000000..291d2fc --- /dev/null +++ b/doc/copy.n @@ -0,0 +1,54 @@ +'\" +'\" Copyright (c) 2007 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: copy.n,v 1.1 2008/05/31 11:42:12 dkf Exp $ +'\" +.so man.macros +.TH copy n 0.1 TclOO "TclOO Commands" +.BS +'\" Note: do not modify the .SH NAME line immediately below! +.SH NAME +oo::copy \- create copies of objects and classes +.SH SYNOPSIS +.nf +package require TclOO + +\fBoo::copy\fI sourceObject \fR?\fItargetObject\fR? +.fi +.BE + +.SH DESCRIPTION +The \fBoo::copy\fR command creates a copy of an object or class. It takes the +name of the object or class to be copied, \fIsourceObject\fR, and optionally +the name of the object or class to create, \fItargetObject\fR, which will be +resolved relative to the current namespace if not an absolute qualified name. +If \fItargetObject\fR is omitted, a new name is chosen. The copied object will +be of the same class as the source object, and will have all its per-object +methods copied. If it is a class, it will also have all the class methods in +the class copied, but it will not have any of its instances copied. The +contents of the source object's private namespace \fIwill not\fR be copied; it +is up to the caller to do this. The result of this command will be the +fully-qualified name of the new object or class. +.SH EXAMPLES +This example creates an object, copies it, modifies the source object, and +then demonstrates that the copied object is indeed a copy. +.CS +oo::object create src +oo::define src method msg {} {puts foo} +\fBoo::copy\fR src dst +oo::define src method msg {} {puts bar} +src msg \fI\(-> prints "bar"\fR +dst msg \fI\(-> prints "foo"\fR +.CE +.SH "SEE ALSO" +oo::class(n), oo::define(n), oo::object(n) +.SH KEYWORDS +clone, copy, duplication, object + +.\" Local variables: +.\" mode: nroff +.\" fill-column: 78 +.\" End: diff --git a/doc/define.n b/doc/define.n new file mode 100644 index 0000000..a1a92bf --- /dev/null +++ b/doc/define.n @@ -0,0 +1,269 @@ +'\" +'\" Copyright (c) 2007 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: define.n,v 1.1 2008/05/31 11:42:12 dkf Exp $ +'\" +.so man.macros +.TH define n 0.3 TclOO "TclOO Commands" +.BS +'\" Note: do not modify the .SH NAME line immediately below! +.SH NAME +oo::define, oo::objdefine \- define and configure classes and objects +.SH SYNOPSIS +.nf +package require TclOO + +\fBoo::define\fI class defScript\fR +\fBoo::define\fI class subcommand arg\fR ?\fIarg ...\fR? +\fBoo::objdefine\fI object defScript\fR +\fBoo::objdefine\fI object subcommand arg\fR ?\fIarg ...\fR? +.fi +.BE + +.SH DESCRIPTION +The \fBoo::define\fR command is used to control the configuration of classes, +and the \fBoo::objdefine\fR command is used to control the configuration of +objects (including classes as instance objects), with the configuration being +applied to the entity named in the \fIclass\fR or the \fIobject\fR argument. +Configuring a class also updates the +configuration of all subclasses of the class and all objects that are +instances of that class or which mix it in (as modified by any per-instance +configuration). The way in which the configuration is done is controlled by +either the \fIdefScript\fR argument or by the \fIsubcommand\fR and following +\fIarg\fR arguments; when the second is present, it is exactly as if all the +arguments from \fIsubcommand\fR onwards are made into a list and that list is +used as the \fIdefScript\fR argument. +.SS "CONFIGURING CLASSES" +.PP +The following commands are supported in the \fIdefScript\fR for +\fBoo::define\fR, each of which may also be used in the \fIsubcommand\fR form: +.TP +\fBconstructor\fI argList bodyScript\fR +. +This creates or updates the constructor for a class. The formal arguments to +the constructor (defined using the same format as for the Tcl \fBproc\fR +command) will be \fIargList\fR, and the body of the constructor will be +\fIbodyScript\fR. When the body of the constructor is evaluated, the current +namespace of the constructor will be a namespace that is unique to the object +being constructed. Within the constructor, the \fBnext\fR command should be +used to call the superclasses' constructors. If \fIbodyScript\fR is the empty +string, the constructor will be deleted. +.TP +\fBdeletemethod\fI name\fR ?\fIname ...\fR +. +This deletes each of the methods called \fIname\fR from a class. The methods +must have previously existed in that class. Does not affect the superclasses +of the class, nor does it affect the subclasses or instances of the class +(except when they have a call chain through the class being modified). +.TP +\fBdestructor\fI bodyScript\fR +. +This creates or updates the destructor for a class. Destructors take no +arguments, and the body of the destructor will be \fIbodyScript\fR. The +destructor is called when objects of the class are deleted, and when called +will have the object's unique namespace as the current namespace. Destructors +should use the \fBnext\fR command to call the superclasses' destructors. Note +that destructors are not called in all situations (e.g. if the interpreter is +destroyed). If \fIbodyScript\fR is the empty string, the destructor will be +deleted. +.RS +Note that errors during the evaluation of a destructor \fIare not returned\fR +to the code that causes the destruction of an object. Instead, they are passed +to the currently-defined \fBbgerror\fR handler. +.RE +.TP +\fBexport\fI name \fR?\fIname ...\fR? +. +This arranges for each of the named methods, \fIname\fR, to be exported +(i.e. usable outside an instance through the instance object's command) by the +class being defined. Note that the methods themselves may be actually defined +by a superclass; subclass exports override superclass visibility, and may in +turn be overridden by instances. +.TP +\fBfilter\fR ?\fImethodName ...\fR? +. +This sets or updates the list of method names that are used to guard whether a +method call to instances of the class may be called and what the method's +results are. Each \fImethodName\fR names a single filtering method (which may +be exposed or not exposed); it is not an error for a non-existent method to be +named since they may be defined by subclasses. If no \fImethodName\fR +arguments are present, the list of filter names is set to empty. +.TP +\fBforward\fI name cmdName \fR?\fIarg ...\fR? +. +This creates or updates a forwarded method called \fIname\fR. The method +is defined be forwarded to the command called \fIcmdName\fR, with additional +arguments, \fIarg\fR etc., added before those arguments specified by the +caller of the method. Forwarded methods should be deleted using the +\fBmethod\fR subcommand. The method will be exported if \fIname\fR starts with +a lower-case letter, and non-exported otherwise. +.TP +\fBmethod\fI name argList bodyScript\fR +. +This creates, updates or deletes a method. The name of the method is +\fIname\fR, the formal arguments to the method (defined using the same format +as for the Tcl \fBproc\fR command) will be \fIargList\fR, and the body of the +method will be \fIbodyScript\fR. When the body of the method is evaluated, the +current namespace of the method will be a namespace that is unique to the +current object. The method will be exported if \fIname\fR starts with a +lower-case letter, and non-exported otherwise; this behavior can be overridden +via \fBexport\fR and \fBunexport\fR. +.TP +\fBmixin\fR ?\fIclassName ...\fR? +. +This sets or updates the list of additional classes that are to be mixed into +all the instances of the class being defined. Each \fIclassName\fR argument +names a single class that is to be mixed in; if no classes are present, the +list of mixed-in classes is set to be empty. +.TP +\fBrenamemethod\fI fromName toName\fR +. +This renames the method called \fIfromName\fR in a class to \fItoName\fR. The +method must have previously existed in the class, and \fItoName\fR must not +previously refer to a method in that class. Does not affect the superclasses +of the class, nor does it affect the subclasses or instances of the class +(except when they have a call chain through the class being modified). Does +not change the export status of the method; if it was exported before, it will +be afterwards. +.TP +\fBself\fI subcommand arg ...\fR +.TP +\fBself\fI script\fR +. +This command is equivalent to calling \fBoo::objdefine\fR on the class being +defined (see \fBCONFIGURING OBJECTS\fR below for a description of the +supported values of \fIsubcommand\fR). It follows the same general pattern of +argument handling as the \fBoo::define\fR and \fBoo::objdefine\fR commands, +and +.QW "\fBoo::define \fIcls \fBself \fIsubcommand ...\fR" +operates identically to +.QW "\fBoo::objdefine \fIcls subcommand ...\fR" . +.TP +\fBsuperclass\fI className \fR?\fIclassName ...\fR? +. +This allows the alteration of the superclasses of the class being defined. +Each \fIclassName\fR argument names one class that is to be a superclass of +the defined class. Note that objects must not be changed from being classes to +being non-classes or vice-versa. +.TP +\fBunexport\fI name \fR?\fIname ...\fR? +. +This arranges for each of the named methods, \fIname\fR, to be not exported +(i.e. not usable outside the instance through the instance object's command, +but instead just through the \fBmy\fR command visible in each object's +context) by the class being defined. Note that the methods themselves may be +actually defined by a superclass; subclass unexports override superclass +visibility, and may be overridden by instance unexports. +.SS "CONFIGURING OBJECTS" +.PP +The following commands are supported in the \fIdefScript\fR for +\fBoo::objdefine\fR, each of which may also be used in the \fIsubcommand\fR +form: +.TP +\fBclass\fI className\fR +. +This allows the class of an object to be changed after creation. Note that the +class's constructors are not called when this is done, and so the object may +well be in an inconsistent state unless additional configuration work is done. +.TP +\fBdeletemethod\fI name\fR ?\fIname ...\fR +. +This deletes each of the methods called \fIname\fR from an object. The methods +must have previously existed in that object. Does not affect the classes that +the object is an instance of. +.TP +\fBexport\fI name \fR?\fIname ...\fR? +. +This arranges for each of the named methods, \fIname\fR, to be exported +(i.e. usable outside the object through the object's command) by the object +being defined. Note that the methods themselves may be actually defined by a +class or superclass; object exports override class visibility. +.TP +\fBfilter\fR ?\fImethodName ...\fR? +. +This sets or updates the list of method names that are used to guard whether a +method call to the object may be called and what the method's results are. +Each \fImethodName\fR names a single filtering method (which may be exposed or +not exposed); it is not an error for a non-existent method to be named. If no +\fImethodName\fR arguments are present, the list of filter names is set to +empty. Note that the actual list of filters also depends on the filters set +upon any classes that the object is an instance of. +.TP +\fBforward\fI name cmdName \fR?\fIarg ...\fR? +. +This creates or updates a forwarded object method called \fIname\fR. The +method is defined be forwarded to the command called \fIcmdName\fR, with +additional arguments, \fIarg\fR etc., added before those arguments specified +by the caller of the method. Forwarded methods should be deleted using the +\fBmethod\fR subcommand. The method will be exported if \fIname\fR starts with +a lower-case letter, and non-exported otherwise. +.TP +\fBmethod\fI name argList bodyScript\fR +. +This creates, updates or deletes an object method. The name of the method is +\fIname\fR, the formal arguments to the method (defined using the same format +as for the Tcl \fBproc\fR command) will be \fIargList\fR, and the body of the +method will be \fIbodyScript\fR. When the body of the method is evaluated, the +current namespace of the method will be a namespace that is unique to the +object. The method will be exported if \fIname\fR starts with a lower-case +letter, and non-exported otherwise. +.TP +\fBmixin\fR ?\fIclassName ...\fR? +. +This sets or updates a per-object list of additional classes that are to be +mixed into the object. Each argument, \fIclassName\fR, names a single class +that is to be mixed in; if no classes are present, the list of mixed-in +classes is set to be empty. +.TP +\fBrenamemethod\fI fromName toName\fR +. +This renames the method called \fIfromName\fR in an object to \fItoName\fR. +The method must have previously existed in the object, and \fItoName\fR must +not previously refer to a method in that object. Does not affect the classes +that the object is an instance of. Does not change the export status of the +method; if it was exported before, it will be afterwards. +.TP +\fBunexport\fI name \fR?\fIname ...\fR? +. +This arranges for each of the named methods, \fIname\fR, to be not exported +(i.e. not usable outside the object through the object's command, but instead +just through the \fBmy\fR command visible in the object's context) by the +object being defined. Note that the methods themselves may be actually defined +by a class; instance unexports override class visibility. +.SH EXAMPLES +This example demonstrates how to use both forms of the \fBoo::define\fR and +\fBoo::objdefine\fR commands (they work in the same way), as well as +illustrating four of the subcommands of them. +.PP +.CS +oo::class create c +c create o +\fBoo::define\fR c \fBmethod\fR foo {} { + puts "world" +} +\fBoo::objdefine\fR o { + \fBmethod\fR bar {} { + my Foo "hello " + my foo + } + \fBforward\fR Foo ::puts -nonewline + \fBunexport\fR foo +} +o bar \fI\(-> prints "hello world"\fR +o foo \fI\(-> error "unknown method foo"\fR +o Foo Bar \fI\(-> error "unknown method Foo"\fR +\fBoo::objdefine\fR o \fBrenamemethod\fR bar lollipop +o lollipop \fI\(-> prints "hello world"\fR +.CE +.SH "SEE ALSO" +next(n), oo::class(n), oo::object(n) +.SH KEYWORDS +class, definition, method, object + +.\" Local variables: +.\" mode: nroff +.\" fill-column: 78 +.\" End: @@ -3,11 +3,12 @@ '\" Copyright (c) 1994-1997 Sun Microsystems, Inc. '\" Copyright (c) 1993-1997 Bell Labs Innovations for Lucent Technologies '\" Copyright (c) 1998-2000 Ajuba Solutions +'\" Copyright (c) 2007-2008 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: info.n,v 1.25 2008/03/12 20:16:13 andreas_kupries Exp $ +'\" RCS: @(#) $Id: info.n,v 1.26 2008/05/31 11:42:12 dkf Exp $ '\" .so man.macros .TH info n 8.4 Tcl "Tcl Built-In Commands" @@ -34,6 +35,11 @@ Tcl command procedure. Returns the body of procedure \fIprocname\fR. \fIProcname\fR must be the name of a Tcl command procedure. .TP +\fBinfo class\fI subcommand class\fR ?\fIarg ...\fR +. +Returns information about the class, \fIclass\fR. The \fIsubcommand\fRs are +described in \fBCLASS INTROSPECTION\fR below. +.TP \fBinfo cmdcount\fR Returns a count of the total number of commands that have been invoked in this interpreter. @@ -263,6 +269,11 @@ Returns the full path name of the binary file from which the application was invoked. If Tcl was unable to identify the file, then an empty string is returned. .TP +\fBinfo object\fI subcommand object\fR ?\fIarg ...\fR +. +Returns information about the object, \fIobject\fR. The \fIsubcommand\fRs are +described in \fBOBJECT INTROSPECTION\fR below. +.TP \fBinfo patchlevel\fR Returns the value of the global variable \fBtcl_patchLevel\fR; see the \fBtclvars\fR manual entry for more information. @@ -321,7 +332,174 @@ Note that a currently-visible variable may not yet .QW exist if it has not been set (e.g. a variable declared but not set by \fBvariable\fR). -.SH EXAMPLE +.SS "CLASS INTROSPECTION" +.PP +The following \fIsubcommand\fR values are supported by \fBinfo class\fR: +.TP +\fBinfo class constructor\fI class\fR +. +This subcommand returns a description of the definition of the constructor of +class \fIclass\fR. The defintion is described as a two element list; the first +element is the list of arguments to the constructor in a form suitable for +passing to another call to \fBproc\fR or a method defintion, and the second +element is the body of the constructor. If no constructor is present, this +returns the empty list. +.TP +\fBinfo class definition\fI class method\fR +. +This subcommand returns a description of the definition of the method named +\fImethod\fR of class \fIclass\fR. The defintion is described as a two element +list; the first element is the list of arguments to the method in a form +suitable for passing to another call to \fBproc\fR or a method defintion, and +the second element is the body of the method. +.TP +\fBinfo class destructor\fI class\fR +. +This subcommand returns the body of the destructor of class \fIclass\fR. If no +destructor is present, this returns the empty string. +.TP +\fBinfo class filters\fI class\fR +. +This subcommand returns the list of filter methods set on the class. +.TP +\fBinfo class forward\fI class method\fR +. +This subcommand returns the argument list for the method forwarding called +\fImethod\fR that is set on the class called \fIclass\fR. +.TP +\fBinfo class instances\fI class\fR ?\fIpattern\fR? +. +This subcommand returns a list of instances of class \fIclass\fR. If the +optional \fIpattern\fR argument is present, it constrains the list of returned +instances to those that match it according to the rules of \fBstring match\fR. +.TP +\fBinfo class methods\fI class\fR ?\fIoptions...\fR? +. +This subcommand returns a list of all public (i.e. exported) methods of the +class called \fIclass\fR. Any of the following \fIoption\fRs may be +specified, controlling exactly which method names are returned: +.RS +.TP +\fB\-all\fR +. +If the \fB\-all\fR flag is given, the list of methods will include those +methods defined not just by the class, but also by the class's superclasses +and mixins. +.TP +\fB\-private\fR +. +If the \fB\-private\fR flag is given, the list of methods will also include +the private (i.e. non-exported) methods of the class (and superclasses and +mixins, if \fB\-all\fR is also given). +.RE +.TP +\fBinfo class mixins\fI class\fR +. +This subcommand returns a list of all classes that have been mixed into the +class named \fIclass\fR. +.TP +\fBinfo class subclasses\fI class\fR ?\fIpattern\fR? +. +This subcommand returns a list of direct subclasses of class \fIclass\fR. If +the optional \fIpattern\fR argument is present, it constrains the list of +returned classes to those that match it according to the rules of \fBstring +match\fR. +.TP +\fBinfo class superclasses\fI class\fR +. +This subcommand returns a list of direct superclasses of class \fIclass\fR in +inheritance precedence order. +.SS "OBJECT INTROSPECTION" +.PP +The following \fIsubcommand\fR values are supported by \fBinfo object\fR: +.TP +\fBinfo object class\fI object\fR ?\fIclassName\fR? +. +If \fIclassName\fR is unspecified, this subcommand returns class of the +\fIobject\fR object. If \fIclassName\fR is present, this subcommand returns a +boolean value indicating whether the \fIobject\fR is of that class. +.TP +\fBinfo object definition\fI object method\fR +. +This subcommand returns a description of the definition of the method named +\fImethod\fR of object \fIobject\fR. The defintion is described as a two +element list; the first element is the list of arguments to the method in a +form suitable for passing to another call to \fBproc\fR or a method defintion, +and the second element is the body of the method. +.TP +\fBinfo object filters\fI object\fR +. +This subcommand returns the list of filter methods set on the object. +.TP +\fBinfo object forward\fI object method\fR +. +This subcommand returns the argument list for the method forwarding called +\fImethod\fR that is set on the object called \fIobject\fR. +.TP +\fBinfo object isa\fI category object\fR ?\fIarg\fR? +. +This subcommand tests whether an object belongs to a particular category, +returning a boolean value that indicates whether the \fIobject\fR argument +meets the criteria for the category. The supported categories are: +.RS +.TP +\fBinfo object isa class\fI object\fR +. +This returns whether \fIobject\fR is a class (i.e. an instance of +\fBoo::class\fR or one of its subclasses). +.TP +\fBinfo object isa metaclass\fI object\fR +. +This returns whether \fIobject\fR is a class that can manufacture classes +(i.e. is \fBoo::class\fR or a subclass of it). +.TP +\fBinfo object isa mixin\fI object class\fR +. +This returns whether \fIclass\fR is directly mixed into \fIobject\fR. +.TP +\fBinfo object isa object\fI object\fR +. +This returns whether \fIobject\fR really is an object. +.TP +\fBinfo object isa typeof\fI object class\fR +. +This returns whether \fIclass\fR is the type of \fIobject\fR (i.e. whether +\fIobject\fR is an instance of \fIclass\fR or one of its subclasses, whether +direct or indirect). +.RE +.TP +\fBinfo object methods\fI object\fR ?\fIoption...\fR? +. +This subcommand returns a list of all public (i.e. exported) methods of the +object called \fIobject\fR. Any of the following \fIoption\fRs may be +specified, controlling exactly which method names are returned: +.RS +.TP +\fB\-all\fR +. +If the \fB\-all\fR flag is given, the list of methods will include those +methods defined not just by the object, but also by the object's class and +mixins, plus the superclasses of those classes. +.TP +\fB\-private\fR +. +If the \fB\-private\fR flag is given, the list of methods will also include +the private (i.e. non-exported) methods of the object (and classes, if +\fB\-all\fR is also given). +.RE +.TP +\fBinfo object mixins\fI object\fR +. +This subcommand returns a list of all classes that have been mixed into the +object named \fIobject\fR. +.TP +\fBinfo object vars\fI object\fR ?\fIpattern\fR? +. +This subcommand returns a list of all variables in the private namespace of +the object named \fIobject\fR. If the optional \fIpattern\fR argument is +given, it is a filter (in the syntax of a \fBstring match\fR glob pattern) +that constrains the list of variables returned. +.SH EXAMPLES This command prints out a procedure suitable for saving in a Tcl script: .PP @@ -341,10 +519,44 @@ proc printProc {procName} { puts [lappend result $formals [\fBinfo body\fR $procName]] } .CE +.SS "EXAMPLES WITH OBJECTS" +.PP +Every object necessarily knows what its class is; this information is +trivially extractable through introspection: +.CS +oo::class create c +c create o +puts [\fBinfo object class\fR o] + \fI\(-> prints "::c"\fR +puts [\fBinfo object class\fR c] + \fI\(-> prints "::oo::class"\fR +.CE +.PP +The introspection capabilities can be used to discover what class implements a +method and get how it is defined. This procedure illustrates how: +.CS +proc getDef {obj method} { + if {$method in [\fBinfo object methods\fR $obj]} { + # Assume no forwards + return [\fBinfo object definition\fR $obj $method] + } + set cls [\fBinfo object class\fR $obj] + while {$method ni [\fBinfo class methods\fR $cls]} { + # Assume the simple case + set cls [lindex [\fBinfo class superclass\fR $cls] 0] + if {$cls eq {}} { + error "no definition for $method" + } + } + # Assume no forwards + return [\fBinfo class definition\fR $cls $method] +} +.CE .SH "SEE ALSO" -global(n), proc(n) +global(n), oo::class(n), oo::object(n), proc(n), self(n) .SH KEYWORDS -command, information, interpreter, level, namespace, procedure, variable +command, information, interpreter, introspection, level, namespace, object, +procedure, variable .\" Local Variables: .\" mode: nroff .\" End: diff --git a/doc/my.n b/doc/my.n new file mode 100644 index 0000000..75d7bac --- /dev/null +++ b/doc/my.n @@ -0,0 +1,56 @@ +'\" +'\" Copyright (c) 2007 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: my.n,v 1.1 2008/05/31 11:42:13 dkf Exp $ +'\" +.so man.macros +.TH my n 0.1 TclOO "TclOO Commands" +.BS +'\" Note: do not modify the .SH NAME line immediately below! +.SH NAME +my \- invoke any method of current object +.SH SYNOPSIS +.nf +package require TclOO + +\fBmy\fI methodName\fR ?\fIarg ...\fR? +.fi +.BE + +.SH DESCRIPTION +The \fBmy\fR command is used to allow methods of objects to invoke any method +of the object (or its class). In particular, the set of valid values for +\fImethodName\fR is the set of all methods supported by an object and its +superclasses, including those that are not exported. The object upon which the +method is invoked is always the one that is the current context of the method +(i.e. the object that is returned by \fBself object\fR) from which the +\fBmy\fR command is invoked. +.PP +Each object has its own \fBmy\fR command, contained in its unique namespace. +.SH EXAMPLES +This example shows basic use of \fBmy\fR to use the \fBvariables\fR method of +the \fBoo::object\fR class, which is not publically visible by default: +.CS +oo::class create c { + method count {} { + \fBmy\fR variable counter + print [incr counter] + } +} +c create o +o count \fI\(-> prints "1"\fR +o count \fI\(-> prints "2"\fR +o count \fI\(-> prints "3"\fR +.CE +.SH "SEE ALSO" +next(n), oo::object(n), self(n) +.SH KEYWORDS +method, method visibility, object, private method, public method + +.\" Local variables: +.\" mode: nroff +.\" fill-column: 78 +.\" End: diff --git a/doc/next.n b/doc/next.n new file mode 100644 index 0000000..a312764 --- /dev/null +++ b/doc/next.n @@ -0,0 +1,195 @@ +'\" +'\" Copyright (c) 2007 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: next.n,v 1.1 2008/05/31 11:42:13 dkf Exp $ +'\" +.so man.macros +.TH next n 0.1 TclOO "TclOO Commands" +.BS +'\" Note: do not modify the .SH NAME line immediately below! +.SH NAME +next \- invoke superclass method implementations +.SH SYNOPSIS +.nf +package require TclOO + +\fBnext\fR ?\fIarg ...\fR? +.fi +.BE + +.SH DESCRIPTION +.PP +The \fBnext\fR command is used to call implementations of a method by a class, +superclass or mixin that are overridden by the current method. It can only be +used from within a method. It is also used within filters to indicate the +point where a filter calls the actual implementation (the filter may decide to +not go along the chain, and may process the results of going along the chain +of methods as it chooses). The result of the \fBnext\fR command is the result +of the next method in the method chain; if there are no further methods in the +method chain, the result of \fBnext\fR is the empty string. The arguments, +\fIarg\fR, to \fBnext\fR are the arguments to pass to the next method in the +chain. +.SH "THE METHOD CHAIN" +.PP +When a method of an object is invoked, things happen in several stages: +.IP [1] +The structure of the object, its class, superclasses, filters, and mixins, are +examined to build a \fImethod chain\fR, which contains a list of method +implementations to invoke. +.IP [2] +The first method implementation on the chain is invoked. +.IP [3] +If that method implementation invokes the \fBnext\fR command, the next method +implementation is invoked (with its arguments being those that were passed to +\fBnext\fR). +.IP [4] +The result from the overall method call is the result from the outermost +method implementation; inner method implementations return their results +through \fBnext\fR. +.IP [5] +The method chain is cached for future use. +.SS "METHOD SEARCH ORDER" +.PP +When constructing the method chain, method implementations are searched for in +the following order: +.IP [1] +In the object. +.IP [2] +In the classes mixed into the object, in class traversal order. The list of +mixins is checked in natural order. +.IP [3] +In the classes mixed into the classes of the object, with sources of mixing in +being searched in class traversal order. Within each class, the list of mixins +is processed in natural order. +.IP [4] +In the object's class. +.IP [5] +In the superclasses of the class, following each superclass in a depth-first +fashion in the natural order of the superclass list. +.PP +Any particular method implementation always comes as \fIlate\fR in the +resulting list of implementations as possible. +.SS FILTERS +.PP +When an object has a list of filter names set upon it, or is an instance of a +class (or has mixed in a class) that has a list of filter names set upon it, +before every invokation of any method the filters are processed. Filter +implementations are found in class traversal order, as are the lists of filter +names (each of which is traversed in natural list order). Explicitly invoking +a method used as a filter will cause that method to be invoked twice, once as +a filter and once as a normal method. +.PP +Each filter should decide for itself whether to permit the execution to go +forward to the proper implementation of the method (which it does by invoking +the \fBnext\fR command as filters are inserted into the front of the method +call chain) and is responsible for returning the result of \fBnext\fR. +.PP +Filters are not invoked when processing an invokation of the \fBunknown\fR +method because of a failure to locate a method implementation, or when +invoking either constructors or destructors. +.SH EXAMPLES +.PP +This example demonstrates how to use the \fBnext\fR command to call the +(super)class's implementation of a method. The script: +.CS +oo::class create theSuperclass { + method example {args} { + puts "in the superclass, args = $args" + } +} +oo::class create theSubclass { + superclass theSuperclass + method example {args} { + puts "before chaining from subclass, args = $args" + \fBnext\fR a {*}$args b + \fBnext\fR pureSynthesis + puts "after chaining from subclass" + } +} +theSubclass create obj +oo::define obj method example args { + puts "per-object method, args = $args" + \fBnext\fR x {*}$args y + \fBnext\fR +} +obj example 1 2 3 +.CE +prints the following: +.CS +per-object method, args = 1 2 3 +before chaining from subclass, args = x 1 2 3 y +in the superclass, args = a x 1 2 3 y b +in the superclass, args = pureSynthesis +after chaining from subclass +before chaining from subclass, args = +in the superclass, args = a b +in the superclassm args = pureSynthesis +after chaining from subclass +.CE +.PP +This example demonstrates how to build a simple cache class that applies +memoization to all the method calls of the objects it is mixed into, and shows +how it can make a difference to computation times: +.PP +.CS +oo::class create cache { + filter Memoize + method Memoize args { + \fI# Do not filter the core method implementations\fR + if {[lindex [self target] 0] eq "::oo::object"} { + return [\fBnext\fR {*}$args] + } + + \fI# Check if the value is already in the cache\fR + my variable ValueCache + set key [self target],$args + if {[info exist ValueCache($key)]} { + return $ValueCache($key) + } + + \fI# Compute value, insert into cache, and return it\fR + return [set ValueCache($key) [\fBnext\fR {*}$args]] + } + method flushCache {} { + my variable ValueCache + unset ValueCache + \fI# Skip the cacheing\fR + return -level 2 "" + } +} + +oo::object create demo +oo::define demo { + mixin cache + method compute {a b c} { + after 3000 \fI;# Simulate deep thought\fR + return [expr {$a + $b * $c}] + } + method compute2 {a b c} { + after 3000 \fI;# Simulate deep thought\fR + return [expr {$a * $b + $c}] + } +} + +puts [demo compute 1 2 3] \fI\(-> prints "7" after delay\fR +puts [demo compute2 4 5 6] \fI\(-> prints "26" after delay\fR +puts [demo compute 1 2 3] \fI\(-> prints "7" instantly\fR +puts [demo compute2 4 5 6] \fI\(-> prints "26" instantly\fR +puts [demo compute 4 5 6] \fI\(-> prints "34" after delay\fR +puts [demo compute 4 5 6] \fI\(-> prints "34" instantly\fR +puts [demo compute 1 2 3] \fI\(-> prints "7" instantly\fR +demo flushCache +puts [demo compute 1 2 3] \fI\(-> prints "7" after delay\fR +.CE +.SH "SEE ALSO" +oo::class(n), oo::define(n), oo::object(n), self(n) +.SH KEYWORDS +call, method, method chain + +.\" Local variables: +.\" mode: nroff +.\" fill-column: 78 +.\" End: diff --git a/doc/object.n b/doc/object.n new file mode 100644 index 0000000..79038db --- /dev/null +++ b/doc/object.n @@ -0,0 +1,101 @@ +'\" +'\" Copyright (c) 2007 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: object.n,v 1.1 2008/05/31 11:42:13 dkf Exp $ +'\" +.so man.macros +.TH object n 0.1 TclOO "TclOO Commands" +.BS +'\" Note: do not modify the .SH NAME line immediately below! +.SH NAME +oo::object \- root class of the class hierarchy +.SH SYNOPSIS +.nf +package require TclOO + +\fBoo::object\fI method \fR?\fIarg ...\fR? +.fi +.SH "CLASS HIERARCHY" +.nf +\fBoo::object\fR +.fi +.BE + +.SH DESCRIPTION +The \fBoo::object\fR class is the root class of the object hierarchy; every +object (and hence every class) is an instance of this class. Objects are +always referred to by their name, and may be \fBrename\fRd while maintaining +their identity. Each object has a unique namespace associated with it. +Instances of objects may be made with either the \fBcreate\fR or \fBnew\fR +methods of the \fBoo::object\fR object itself, or by invoking those methods on +any of the subclass objects; see \fBoo::class\fR for more details. +.SS CONSTRUCTOR +The \fBoo::object\fR class does not define an explicit constructor. +.SS DESTRUCTOR +The \fBoo::object\fR class does not define an explicit destructor. +.SS "EXPORTED METHODS" +The \fBoo::object\fR class supports the following exported methods: +.TP +\fIobj \fBdestroy\fR +. +This method destroys the object, \fIobj\fR, that it is invoked upon, invoking +any destructors on the object's class in the process. It is equivalent to +using \fBrename\fR to delete the object command. The result of this method is +always the empty string. +.SS "NON-EXPORTED METHODS" +The \fBoo::object\fR class supports the following non-exported methods: +.TP +\fIobj \fBeval\fR ?\fIarg ...\fR? +. +This method concatenates the arguments, \fIarg\fR, as if with \fBconcat\fR, +and then evaluates the resulting script in the namespace that is uniquely +associated with \fIobj\fR, returning the result of the evaluation. +.TP +\fIobj \fBunknown \fImethodName\fR ?\fIarg ...\fR? +. +This method is called when an attempt to invoke the method \fImethodName\fR on +object \fIobj\fR fails. The arguments that the user supplied to the method are +given as \fIarg\fR argments. The default implementation (i.e. the one defined +by the \fBoo::object\fR class) generates a suitable error, detailing what +methods the object supports given whether the object was invoked by its public +name or through the \fBmy\fR command. +.TP +\fIobj \fBvariable \fIvarName \fR?\fIvarName ...\fR? +. +This method arranges for each variable called \fIvarName\fR to be linked from +the object \fIobj\fR's unique namespace into the caller's context. Thus, if it +is invoked from inside a procedure then the namespace variable in the object +is linked to the local variable in the procedure. Each \fIvarName\fR argument +must not have any namespace separators in it. The result is the empty string. +.TP +\fIobj \fBvarname \fIvarName\fR +. +This method returns the globally qualified name of the variable \fIvarName\fR +in the unique namespace for the object \fIobj\fR. +.SH EXAMPLES +This example demonstrates basic use of an object. +.CS +set obj [\fBoo::object\fR new] +$obj foo \fI\(-> error "unknown method foo"\fR +oo::define $obj method foo {} { + my \fBvariable\fR count + puts "bar[incr count]" +} +$obj foo \fI\(-> prints "bar1"\fR +$obj foo \fI\(-> prints "bar2"\fR +$obj variable count \fI\(-> error "unknown method variable"\fR +$obj \fBdestroy\fR +$obj foo \fI\(-> error "unknown command obj"\fR +.CE +.SH "SEE ALSO" +my(n), oo::class(n) +.SH KEYWORDS +base class, class, object, root class + +.\" Local variables: +.\" mode: nroff +.\" fill-column: 78 +.\" End: diff --git a/doc/self.n b/doc/self.n new file mode 100644 index 0000000..2c66edb --- /dev/null +++ b/doc/self.n @@ -0,0 +1,111 @@ +'\" +'\" Copyright (c) 2007 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: self.n,v 1.1 2008/05/31 11:42:13 dkf Exp $ +'\" +.so man.macros +.TH self n 0.1 TclOO "TclOO Commands" +.BS +'\" Note: do not modify the .SH NAME line immediately below! +.SH NAME +self \- method call internal introspection +.SH SYNOPSIS +.nf +package require TclOO + +\fBself\fR ?\fIsubcommand\fR? +.fi +.BE + +.SH DESCRIPTION +The \fBself\fR command, which should only be used from within the context of a +call to a method (i.e. inside a method, constructor or destructor body) is +used to allow the method to discover information about how it was called. It +takes an argument, \fIsubcommand\fR, that tells it what sort of information is +actually desired; if omitted the result will be the same as if \fBself +object\fR was invoked. The supported subcommands are: +.TP +\fBself caller\fR +. +When the method was invoked from inside another object method, this subcommand +returns a three element list describing the containing object and method. The +first element describes the declaring object or class of the method, the +second element is the name of the object on which the containing method was +invoked, and the third element is the name of the method (with the strings +\fB<constructor>\fR and \fB<destructor>\fR indicating constructors and +destructors respectively). +.TP +\fBself class\fR +. +This returns the name of the class or object that the current method was +defined within. Note that this will change as the chain of method +implementations is traversed with \fBnext\fR. +.TP +\fBself filter\fR +. +When invoked inside a filter, this subcommand returns a three element list +describing the filter. The first element gives the name of the object or class +that declared the filter (note that this may be different from the object or +class that provided the implementation of the filter), the second element is +either \fBobject\fR or \fBclass\fR depending on whether the declaring entity +was an object or class, and the third element is the name of the filter. +.TP +\fBself method\fR +. +This returns the name of the current method (with the strings +\fB<constructor>\fR and \fB<destructor>\fR indicating constructors and +destructors respectively). +.TP +\fBself namespace\fR +. +This returns the name of the unique namespace of the object that the method +was invoked upon. +.TP +\fBself next\fR +. +When invoked from a method that is not at the end of a call chain (i.e. where +the \fBnext\fR command will invoke an actual method implementation), this +subcommand returns a two element list describing the next element in the +method call chain; the first element is the name of the class or object that +declares the next part of the call chain, and the second element is the name +of the method (with the strings \fB<constructor>\fR and \fB<destructor>\fR +indicating constructors and destructors respectively). If invoked from a +method that is at the end of a call chain, this subcommand returns the emtpy +string. +.TP +\fBself object\fR +. +This returns the name of the object that the method was invoked upon. +.TP +\fBself target\fR +. +When invoked inside a filter implementation, this subcommand returns a two +element list describing the method being filtered. The first element will be +the name of the declarer of the method, and the second element will be the +actual name of the method. +.SH EXAMPLES +This example shows basic use of \fBself\fR to provide information about the +current object: +.CS +oo::class create c { + method foo {} { + puts "this is the [\fBself\fR] object" + } +} +c create a +c create b +a foo \fI\(-> prints "this is the ::a object"\fR +b foo \fI\(-> prints "this is the ::b object"\fR +.CE +.SH "SEE ALSO" +info(n), next(n) +.SH KEYWORDS +call, introspection, object + +.\" Local variables: +.\" mode: nroff +.\" fill-column: 78 +.\" End: diff --git a/generic/tclBasic.c b/generic/tclBasic.c index 4b7593a..0a45567 100644 --- a/generic/tclBasic.c +++ b/generic/tclBasic.c @@ -14,7 +14,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.298 2008/05/02 20:08:51 patthoyts Exp $ + * RCS: @(#) $Id: tclBasic.c,v 1.299 2008/05/31 11:42:13 dkf Exp $ */ #include "tclInt.h" @@ -815,6 +815,10 @@ Tcl_CreateInterp(void) Tcl_Panic(Tcl_GetString(Tcl_GetObjResult(interp))); } + if (TclOOInit(interp) != TCL_OK) { + Tcl_Panic(Tcl_GetString(Tcl_GetObjResult(interp))); + } + return interp; } diff --git a/generic/tclInt.h b/generic/tclInt.h index eab070c..3ec57b4 100644 --- a/generic/tclInt.h +++ b/generic/tclInt.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: tclInt.h,v 1.368 2008/05/09 04:58:54 georgeps Exp $ + * RCS: @(#) $Id: tclInt.h,v 1.369 2008/05/31 11:42:14 dkf Exp $ */ #ifndef _TCLINT @@ -1058,6 +1058,14 @@ typedef struct CallFrame { #define FRAME_IS_PROC 0x1 #define FRAME_IS_LAMBDA 0x2 +#define FRAME_IS_METHOD 0x4 /* The frame is a method body, and the frame's + * clientData field contains a CallContext + * reference. Part of TIP#257. */ +#define FRAME_IS_OO_DEFINE 0x8 /* The frame is part of the inside workings of + * the [oo::define] command; the clientData + * field contains an Object reference that has + * been confirmed to refer to a class. Part of + * TIP#257. */ /* * TIP #280 @@ -1878,6 +1886,15 @@ typedef struct Interp { * TclpCheckStackSpace in the platform's * directory. */ + /* + * The pointer to the object system root ekeko. c.f. TIP #257. + */ + + void *objectFoundation; /* Pointer to the Foundation structure of the + * object system, which contains things like + * references to key namespaces. See + * tclOOInt.h and tclOO.c for real definition + * and setup. */ #ifdef TCL_COMPILE_STATS /* diff --git a/generic/tclOO.c b/generic/tclOO.c new file mode 100644 index 0000000..de0b36b --- /dev/null +++ b/generic/tclOO.c @@ -0,0 +1,2179 @@ +/* + * tclOO.c -- + * + * This file contains the object-system core (NB: not Tcl_Obj, but ::oo) + * + * Copyright (c) 2005-2008 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.4 2008/05/31 11:42:16 dkf Exp $ + */ + +#ifdef HAVE_CONFIG_H +#include "config.h" +#endif +#include "tclInt.h" +#include "tclOOInt.h" + +/* + * Commands in oo::define. + */ + +static const struct { + const char *name; + Tcl_ObjCmdProc *objProc; + int flag; +} defineCmds[] = { + {"constructor", TclOODefineConstructorObjCmd, 0}, + {"deletemethod", TclOODefineDeleteMethodObjCmd, 0}, + {"destructor", TclOODefineDestructorObjCmd, 0}, + {"export", TclOODefineExportObjCmd, 0}, + {"filter", TclOODefineFilterObjCmd, 0}, + {"forward", TclOODefineForwardObjCmd, 0}, + {"method", TclOODefineMethodObjCmd, 0}, + {"mixin", TclOODefineMixinObjCmd, 0}, + {"renamemethod", TclOODefineRenameMethodObjCmd, 0}, + {"self", TclOODefineSelfObjCmd, 0}, + {"superclass", TclOODefineSuperclassObjCmd, 0}, + {"unexport", TclOODefineUnexportObjCmd, 0}, + {NULL, NULL, 0} +}, objdefCmds[] = { + {"class", TclOODefineClassObjCmd, 1}, + {"deletemethod", TclOODefineDeleteMethodObjCmd, 1}, + {"export", TclOODefineExportObjCmd, 1}, + {"filter", TclOODefineFilterObjCmd, 1}, + {"forward", TclOODefineForwardObjCmd, 1}, + {"method", TclOODefineMethodObjCmd, 1}, + {"mixin", TclOODefineMixinObjCmd, 1}, + {"renamemethod", TclOODefineRenameMethodObjCmd, 1}, + {"unexport", TclOODefineUnexportObjCmd, 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, + const char *nsNameStr); +static int CloneClassMethod(Tcl_Interp *interp, Class *clsPtr, + Method *mPtr, Tcl_Obj *namePtr, + Method **newMPtrPtr); +static int CloneObjectMethod(Tcl_Interp *interp, Object *oPtr, + Method *mPtr, Tcl_Obj *namePtr); +static void InitFoundation(Tcl_Interp *interp); +static void KillFoundation(ClientData clientData, + Tcl_Interp *interp); +static void ObjectNamespaceDeleted(ClientData clientData); +static void ObjectRenamedTrace(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); + +/* + * Methods in the oo::object and oo::class classes. First, we define a helper + * macro that makes building the method type declaration structure a lot + * easier. No point in making life harder than it has to be! + * + * Note that the core methods don't need clone or free proc callbacks. + */ + +#define DCM(name,visibility,proc) \ + {name,visibility,\ + {TCL_OO_METHOD_VERSION_CURRENT,"core method: "#name,proc,NULL,NULL}} + +static const DeclaredClassMethod objMethods[] = { + DCM("destroy", 1, TclOO_Object_Destroy), + DCM("eval", 0, TclOO_Object_Eval), + DCM("unknown", 0, TclOO_Object_Unknown), + DCM("variable", 0, TclOO_Object_LinkVar), + DCM("varname", 0, TclOO_Object_VarName), + {NULL} +}, clsMethods[] = { + DCM("create", 1, TclOO_Class_Create), + DCM("new", 1, TclOO_Class_New), + DCM("createWithNamespace", 0, TclOO_Class_CreateNs), + {NULL} +}; + +static char initScript[] = + "namespace eval ::oo { variable version " TCLOO_VERSION " };" + "namespace eval ::oo { variable patchlevel " TCLOO_PATCHLEVEL " };"; +/* "tcl_findLibrary tcloo $oo::version $oo::version" */ +/* " tcloo.tcl OO_LIBRARY oo::library;"; */ + +extern struct TclOOStubAPI tclOOStubAPI; + +/* + * Convenience macro for getting the foundation from an interpreter. + */ + +#define GetFoundation(interp) \ + ((Foundation *)((Interp *)(interp))->objectFoundation) + +/* + * ---------------------------------------------------------------------- + * + * 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. */ +{ + /* + * Build the core of the OO system. + */ + + InitFoundation(interp); + + /* + * Run our initialization script and, if that works, declare the package + * to be fully provided. + */ + + if (Tcl_Eval(interp, initScript) != TCL_OK) { + return TCL_ERROR; + } + + return Tcl_PkgProvideEx(interp, "TclOO", TCLOO_VERSION, &tclOOStubAPI); +} + +/* + * ---------------------------------------------------------------------- + * + * TclOOGetFoundation -- + * + * Get a reference to the OO core class system. + * + * ---------------------------------------------------------------------- + */ + +Foundation * +TclOOGetFoundation( + Tcl_Interp *interp) +{ + return GetFoundation(interp); +} + +/* + * ---------------------------------------------------------------------- + * + * InitFoundation -- + * + * Set up the core of the OO core class system. This is a structure + * holding references to the magical bits that need to be known about in + * other places, plus the oo::object and oo::class classes. + * + * ---------------------------------------------------------------------- + */ + +static void +InitFoundation( + Tcl_Interp *interp) +{ + static Tcl_ThreadDataKey tsdKey; + ThreadLocalData *tsdPtr = + Tcl_GetThreadData(&tsdKey, sizeof(ThreadLocalData)); + Foundation *fPtr = (Foundation *) ckalloc(sizeof(Foundation)); + Tcl_Obj *namePtr, *argsPtr, *bodyPtr; + Tcl_DString buffer; + int i; + + /* + * Initialize the structure that holds the OO system core. This is + * attached to the interpreter via an assocData entry; not very efficient, + * but the best we can do without hacking the core more. + */ + + memset(fPtr, 0, sizeof(Foundation)); + ((Interp *) interp)->objectFoundation = fPtr; + fPtr->interp = interp; + 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->objdefNs = Tcl_CreateNamespace(interp, "::oo::objdefine", NULL, + NULL); + fPtr->helpersNs = Tcl_CreateNamespace(interp, "::oo::Helpers", NULL, + NULL); + fPtr->epoch = 0; + fPtr->tsdPtr = tsdPtr; + fPtr->unknownMethodNameObj = Tcl_NewStringObj("unknown", -1); + fPtr->constructorName = Tcl_NewStringObj("<constructor>", -1); + fPtr->destructorName = Tcl_NewStringObj("<destructor>", -1); + Tcl_IncrRefCount(fPtr->unknownMethodNameObj); + Tcl_IncrRefCount(fPtr->constructorName); + Tcl_IncrRefCount(fPtr->destructorName); + Tcl_CreateObjCommand(interp, "::oo::UnknownDefinition", + TclOOUnknownDefinition, NULL, NULL); + namePtr = Tcl_NewStringObj("::oo::UnknownDefinition", -1); + Tcl_SetNamespaceUnknownHandler(interp, fPtr->defineNs, namePtr); + Tcl_SetNamespaceUnknownHandler(interp, fPtr->objdefNs, namePtr); + + /* + * Create the subcommands in the oo::define and oo::objdefine spaces. + */ + + 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); + } + for (i=0 ; objdefCmds[i].name ; i++) { + Tcl_DStringAppend(&buffer, "::oo::objdefine::", 17); + Tcl_DStringAppend(&buffer, objdefCmds[i].name, -1); + Tcl_CreateObjCommand(interp, Tcl_DStringValue(&buffer), + objdefCmds[i].objProc, (void *) objdefCmds[i].flag, NULL); + Tcl_DStringFree(&buffer); + } + + Tcl_CallWhenDeleted(interp, KillFoundation, NULL); + + /* + * Create the objects at the core of the object system. These need to be + * spliced manually. + */ + + fPtr->objectCls = AllocClass(interp, + AllocObject(interp, "::oo::object", NULL)); + fPtr->classCls = AllocClass(interp, + AllocObject(interp, "::oo::class", NULL)); + 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. + */ + + for (i=0 ; objMethods[i].name ; i++) { + TclOONewBasicMethod(interp, fPtr->objectCls, &objMethods[i]); + } + for (i=0 ; clsMethods[i].name ; i++) { + TclOONewBasicMethod(interp, fPtr->classCls, &clsMethods[i]); + } + + /* + * Finish setting up the class of classes by marking the 'new' method as + * private; classes, unlike general objects, must have explicit names. We + * also need to create the constructor for classes. + */ + + namePtr = Tcl_NewStringObj("new", -1); + Tcl_NewInstanceMethod(interp, (Tcl_Object) fPtr->classCls->thisPtr, + namePtr /* keeps ref */, 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 = TclOONewProcMethod(interp, + fPtr->classCls, 0, NULL, argsPtr, bodyPtr, NULL); + + /* + * Create non-object commands and plug ourselves into the Tcl [info] + * ensemble. + */ + + Tcl_CreateObjCommand(interp, "::oo::Helpers::next", TclOONextObjCmd, NULL, + NULL); + Tcl_CreateObjCommand(interp, "::oo::Helpers::self", TclOOSelfObjCmd, NULL, + NULL); + Tcl_CreateObjCommand(interp, "::oo::define", TclOODefineObjCmd, NULL, + NULL); + Tcl_CreateObjCommand(interp, "::oo::objdefine", TclOOObjDefObjCmd, NULL, + NULL); + Tcl_CreateObjCommand(interp, "::oo::copy", TclOOCopyObjectCmd, NULL,NULL); + TclOOInitInfo(interp); +} + +/* + * ---------------------------------------------------------------------- + * + * 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 = GetFoundation(interp); + + Tcl_DecrRefCount(fPtr->unknownMethodNameObj); + Tcl_DecrRefCount(fPtr->constructorName); + Tcl_DecrRefCount(fPtr->destructorName); + 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 (equal to the namespace + * name). */ + const char *nsNameStr) /* The name of the namespace to create, or + * NULL if the OO system should pick a unique + * name itself. If this is non-NULL but names + * a namespace that already exists, the effect + * will be the same as if this was NULL. */ +{ + Foundation *fPtr = GetFoundation(interp); + Tcl_DString buffer; + Object *oPtr; + int creationEpoch; + + oPtr = (Object *) ckalloc(sizeof(Object)); + memset(oPtr, 0, sizeof(Object)); + + /* + * Every object has a namespace; make one. Note that this also normally + * computes the creation epoch value for the object, a sequence number + * that is unique to the object (and which allows us to manage method + * caching without comparing pointers). + * + * When creating a namespace, we first check to see if the caller + * specified the name for the namespace. If not, we generate namespace + * names using the epoch until such time as a new namespace is actually + * created. + */ + + if (nsNameStr != NULL) { + oPtr->namespacePtr = Tcl_CreateNamespace(interp, nsNameStr, oPtr, + ObjectNamespaceDeleted); + if (oPtr->namespacePtr != NULL) { + creationEpoch = ++fPtr->tsdPtr->nsCount; + goto configNamespace; + } + Tcl_ResetResult(interp); + } + + while (1) { + char objName[10 + TCL_INTEGER_SPACE]; + + sprintf(objName, "::oo::Obj%d", ++fPtr->tsdPtr->nsCount); + oPtr->namespacePtr = Tcl_CreateNamespace(interp, objName, oPtr, + ObjectNamespaceDeleted); + if (oPtr->namespacePtr != NULL) { + creationEpoch = fPtr->tsdPtr->nsCount; + 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); + } + + /* + * Make the namespace know about the helper commands. This grants access + * to the [self] and [next] commands. + */ + + configNamespace: + TclSetNsPath((Namespace *) oPtr->namespacePtr, 1, &fPtr->helpersNs); + + /* + * Fill in the rest of the non-zero/NULL parts of the structure. + */ + + oPtr->fPtr = fPtr; + oPtr->selfCls = fPtr->objectCls; + oPtr->creationEpoch = creationEpoch; + oPtr->refCount = 1; + oPtr->flags = USE_CLASS_CACHE; + + /* + * Finally, create the object commands and initialize the trace on the + * public command (so that the object structures are deleted when the + * command is deleted). + */ + + if (nameStr) { + if (nameStr[0] != ':' || nameStr[1] != ':') { + Tcl_DStringInit(&buffer); + Tcl_DStringAppend(&buffer, + Tcl_GetCurrentNamespace(interp)->fullName, -1); + Tcl_DStringAppend(&buffer, "::", 2); + Tcl_DStringAppend(&buffer, nameStr, -1); + oPtr->command = Tcl_CreateObjCommand(interp, + Tcl_DStringValue(&buffer), PublicObjectCmd, oPtr, NULL); + Tcl_DStringFree(&buffer); + } else { + oPtr->command = Tcl_CreateObjCommand(interp, nameStr, + PublicObjectCmd, oPtr, NULL); + } + } else { + oPtr->command = Tcl_CreateObjCommand(interp, + oPtr->namespacePtr->fullName, PublicObjectCmd, oPtr, NULL); + } + + /* + * Access the namespace command table directly when creating "my" to avoid + * a bottleneck in string manipulation. + */ + + { + register Command *cmdPtr = (Command *) ckalloc(sizeof(Command)); + + memset(cmdPtr, 0, sizeof(Command)); + cmdPtr->nsPtr = (Namespace *) oPtr->namespacePtr; + cmdPtr->hPtr = Tcl_CreateHashEntry(&cmdPtr->nsPtr->cmdTable, "my", + &creationEpoch /*ignored*/ ); + cmdPtr->refCount = 1; + cmdPtr->objProc = PrivateObjectCmd; + cmdPtr->objClientData = oPtr; + cmdPtr->proc = TclInvokeObjectCommand; + cmdPtr->clientData = cmdPtr; + Tcl_SetHashValue(cmdPtr->hPtr, cmdPtr); + } + + Tcl_TraceCommand(interp, TclGetString(TclOOObjectName(interp, oPtr)), + TCL_TRACE_RENAME|TCL_TRACE_DELETE, ObjectRenamedTrace, oPtr); + + return oPtr; +} + +/* + * ---------------------------------------------------------------------- + * + * ObjectRenamedTrace -- + * + * 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 +ObjectRenamedTrace( + 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? */ +{ + Object *oPtr = clientData; + Class *clsPtr; + + /* + * If this is a rename and not a delete of the object, we just flush the + * cache of the object name. + */ + + if (flags & TCL_TRACE_RENAME) { + if (oPtr->cachedNameObj) { + Tcl_DecrRefCount(oPtr->cachedNameObj); + oPtr->cachedNameObj = NULL; + } + return; + } + + /* + * Oh dear, the object really is being deleted. Handle this by running the + * destructors and deleting the object's namespace, which in turn causes + * the real object structures to be deleted. + */ + + AddRef(oPtr); + oPtr->flags |= OBJECT_DELETED; + if (!Tcl_InterpDeleted(interp)) { + CallContext *contextPtr = TclOOGetCallContext(oPtr, NULL, DESTRUCTOR); + + if (contextPtr != NULL) { + int result; + Tcl_InterpState state; + + contextPtr->callPtr->flags |= DESTRUCTOR; + contextPtr->skip = 0; + state = Tcl_SaveInterpState(interp, TCL_OK); + result = TclOOInvokeContext(interp, contextPtr, 0, NULL); + if (result != TCL_OK) { + Tcl_BackgroundError(interp); + } + Tcl_RestoreInterpState(interp, state); + TclOODeleteContext(contextPtr); + } + } + + /* + * OK, the destructor's been run. Time to splat the class data (if any) + * and nuke the namespace (which triggers the final crushing of the object + * structure itself). + */ + + clsPtr = oPtr->classPtr; + if (clsPtr != NULL) { + AddRef(clsPtr); + ReleaseClassContents(interp, oPtr); + } + Tcl_DeleteNamespace(oPtr->namespacePtr); + if (clsPtr) { + DelRef(clsPtr); + } + DelRef(oPtr); +} + +/* + * ---------------------------------------------------------------------- + * + * 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 = oPtr->classPtr, **list; + Object **insts; + + /* + * 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++) { + AddRef(list[i]); + } + for (i=0 ; i<n ; i++) { + if (!(list[i]->flags & OBJECT_DELETED) && interp != NULL) { + Tcl_DeleteCommandFromToken(interp, list[i]->thisPtr->command); + } + DelRef(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++) { + AddRef(list[i]); + } + for (i=0 ; i<n ; i++) { + if (!(list[i]->flags & OBJECT_DELETED) && interp != NULL) { + Tcl_DeleteCommandFromToken(interp, list[i]->thisPtr->command); + } + DelRef(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++) { + AddRef(insts[i]); + } + for (i=0 ; i<n ; i++) { + if (!(insts[i]->flags & OBJECT_DELETED) && interp != NULL) { + Tcl_DeleteCommandFromToken(interp, insts[i]->command); + } + DelRef(insts[i]); + } + if (insts != NULL) { + ckfree((char *) insts); + } + + if (clsPtr->constructorChainPtr) { + TclOODeleteChain(clsPtr->constructorChainPtr); + } + if (clsPtr->destructorChainPtr) { + TclOODeleteChain(clsPtr->destructorChainPtr); + } + if (clsPtr->classChainCache) { + FOREACH_HASH_DECLS; + CallChain *callPtr; + + FOREACH_HASH_VALUE(callPtr, clsPtr->classChainCache) { + TclOODeleteChain(callPtr); + } + Tcl_DeleteHashTable(clsPtr->classChainCache); + ckfree((char *) clsPtr->classChainCache); + } + + if (clsPtr->filters.num) { + Tcl_Obj *filterObj; + + FOREACH(filterObj, clsPtr->filters) { + Tcl_DecrRefCount(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 = oPtr->classPtr, *mixinPtr; + Method *mPtr; + Tcl_Obj *filterObj; + int i, preserved = !(oPtr->flags & OBJECT_DELETED); + + /* + * Instruct everyone to no longer use any allocated fields of the object. + */ + + if (preserved) { + AddRef(oPtr); + if (clsPtr != NULL) { + AddRef(clsPtr); + 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) { + Tcl_DecrRefCount(filterObj); + } + if (i) { + ckfree((char *) oPtr->filters.list); + } + + if (oPtr->methodsPtr) { + FOREACH_HASH_VALUE(mPtr, oPtr->methodsPtr) { + TclOODelMethodRef(mPtr); + } + Tcl_DeleteHashTable(oPtr->methodsPtr); + ckfree((char *) oPtr->methodsPtr); + } + + if (oPtr->chainCache) { + TclOODeleteChainCache(oPtr->chainCache); + } + + if (oPtr->cachedNameObj) { + Tcl_DecrRefCount(oPtr->cachedNameObj); + oPtr->cachedNameObj = NULL; + } + + if (oPtr->metadataPtr != NULL) { + 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; + } + + if (clsPtr != NULL && !(oPtr->flags & ROOT_OBJECT)) { + Class *superPtr, *mixinPtr; + + 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; + } + + clsPtr->flags |= OBJECT_DELETED; + FOREACH(filterObj, clsPtr->filters) { + Tcl_DecrRefCount(filterObj); + } + if (i) { + ckfree((char *) clsPtr->filters.list); + clsPtr->filters.num = 0; + } + FOREACH(mixinPtr, clsPtr->mixins) { + if (!(mixinPtr->flags & OBJECT_DELETED)) { + TclOORemoveFromMixinSubs(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; + } + + FOREACH_HASH_VALUE(mPtr, &clsPtr->classMethods) { + TclOODelMethodRef(mPtr); + } + Tcl_DeleteHashTable(&clsPtr->classMethods); + TclOODelMethodRef(clsPtr->constructorPtr); + TclOODelMethodRef(clsPtr->destructorPtr); + DelRef(clsPtr); + } + + /* + * Delete the object structure itself. + */ + + DelRef(oPtr); + if (preserved) { + if (clsPtr) { + DelRef(clsPtr); + } + DelRef(oPtr); + } +} + +/* + * ---------------------------------------------------------------------- + * + * 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. */ +{ + Foundation *fPtr = GetFoundation(interp); + Class *clsPtr = (Class *) ckalloc(sizeof(Class)); + Tcl_Namespace *path[2]; + + /* + * Make an object if we haven't been given one. + */ + + memset(clsPtr, 0, sizeof(Class)); + if (useThisObj == NULL) { + clsPtr->thisPtr = AllocObject(interp, NULL, NULL); + } else { + clsPtr->thisPtr = useThisObj; + } + + /* + * Configure the namespace path for the class's object. + */ + + path[0] = fPtr->helpersNs; + path[1] = fPtr->ooNs; + TclSetNsPath((Namespace *) clsPtr->thisPtr->namespacePtr, 2, path); + + /* + * Class objects inherit from the class of classes unless they inherit + * from some subclass of it. Enforce this right now. + */ + + clsPtr->thisPtr->selfCls = fPtr->classCls; + + /* + * Classes are subclasses of oo::object, i.e. the objects they create are + * objects. + */ + + clsPtr->superclasses.num = 1; + clsPtr->superclasses.list = (Class **) ckalloc(sizeof(Class *)); + clsPtr->superclasses.list[0] = fPtr->objectCls; + + /* + * Finish connecting the class structure to the object structure. + */ + + clsPtr->thisPtr->classPtr = clsPtr; + + /* + * That's the complicated bit. Now fill in the rest of the non-zero/NULL + * fields. + */ + + clsPtr->refCount = 1; + Tcl_InitObjHashTable(&clsPtr->classMethods); + 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 *nameStr, /* Name of object to create, or NULL to ask + * the code to pick its own unique name. */ + const char *nsNameStr, /* Name of namespace to create inside object, + * 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. */ +{ + register Class *classPtr = (Class *) cls; + Foundation *fPtr = GetFoundation(interp); + Object *oPtr; + + /* + * Check if we're going to create an object over an existing command; + * that's not allowed. + */ + + if (nameStr && Tcl_FindCommand(interp, nameStr, NULL, 0)) { + Tcl_AppendResult(interp, "can't create object \"", nameStr, + "\": command already exists with that name", NULL); + return NULL; + } + + /* + * Create the object. + */ + + oPtr = AllocObject(interp, nameStr, nsNameStr); + oPtr->selfCls = classPtr; + TclOOAddToInstances(oPtr, classPtr); + + /* + * Check to see if we're really creating a class. If so, allocate the + * class structure as well. + */ + + if (TclOOIsReachable(fPtr->classCls, classPtr)) { + /* + * 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. Once that's done, we need to repatch the object to have the + * right class since AllocClass interferes with that. + */ + + AllocClass(interp, oPtr); + oPtr->selfCls = classPtr; + TclOOAddToSubclasses(oPtr->classPtr, fPtr->objectCls); + } + + /* + * Run constructors, except when objc < 0 (a special flag case used for + * object cloning only). + */ + + if (objc >= 0) { + CallContext *contextPtr = TclOOGetCallContext(oPtr,NULL,CONSTRUCTOR); + + if (contextPtr != NULL) { + int result; + Tcl_InterpState state; + + AddRef(oPtr); + state = Tcl_SaveInterpState(interp, TCL_OK); + contextPtr->callPtr->flags |= CONSTRUCTOR; + contextPtr->skip = skip; + result = TclOOInvokeContext(interp, contextPtr, objc, objv); + TclOODeleteContext(contextPtr); + DelRef(oPtr); + if (result != TCL_OK) { + Tcl_DiscardInterpState(state); + Tcl_DeleteCommandFromToken(interp, oPtr->command); + return NULL; + } + 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, + const char *targetNamespaceName) +{ + Object *oPtr = (Object *) sourceObject, *o2Ptr; + 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 == GetFoundation(interp)->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, targetNamespaceName, -1, + NULL, -1); + if (o2Ptr == NULL) { + return NULL; + } + + /* + * Copy the object-local methods to the new object. + */ + + if (oPtr->methodsPtr) { + FOREACH_HASH(keyPtr, mPtr, oPtr->methodsPtr) { + if (CloneObjectMethod(interp, o2Ptr, mPtr, keyPtr) != TCL_OK) { + Tcl_DeleteCommandFromToken(interp, o2Ptr->command); + return NULL; + } + } + } + + /* + * 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) { + duplicate = value; + } else { + if (metadataTypePtr->cloneProc(interp, value, + &duplicate) != TCL_OK) { + Tcl_DeleteCommandFromToken(interp, o2Ptr->command); + return NULL; + } + } + 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) { + if (CloneClassMethod(interp, cls2Ptr, mPtr, keyPtr, + NULL) != TCL_OK) { + Tcl_DeleteCommandFromToken(interp, o2Ptr->command); + return NULL; + } + } + if (clsPtr->constructorPtr) { + if (CloneClassMethod(interp, cls2Ptr, clsPtr->constructorPtr, + NULL, &cls2Ptr->constructorPtr) != TCL_OK) { + Tcl_DeleteCommandFromToken(interp, o2Ptr->command); + return NULL; + } + } + if (clsPtr->destructorPtr) { + if (CloneClassMethod(interp, cls2Ptr, clsPtr->destructorPtr, NULL, + &cls2Ptr->destructorPtr) != TCL_OK) { + Tcl_DeleteCommandFromToken(interp, o2Ptr->command); + return 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) { + duplicate = value; + } else { + if (metadataTypePtr->cloneProc(interp, value, + &duplicate) != TCL_OK) { + Tcl_DeleteCommandFromToken(interp, o2Ptr->command); + return NULL; + } + } + 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 int +CloneObjectMethod( + Tcl_Interp *interp, + Object *oPtr, + Method *mPtr, + Tcl_Obj *namePtr) +{ + if (mPtr->typePtr == NULL) { + Tcl_NewInstanceMethod(interp, (Tcl_Object) oPtr, namePtr, + mPtr->flags & PUBLIC_METHOD, NULL, NULL); + } else if (mPtr->typePtr->cloneProc) { + ClientData newClientData; + + if (mPtr->typePtr->cloneProc(interp, mPtr->clientData, + &newClientData) != TCL_OK) { + return TCL_ERROR; + } + Tcl_NewInstanceMethod(interp, (Tcl_Object) oPtr, namePtr, + mPtr->flags & PUBLIC_METHOD, mPtr->typePtr, newClientData); + } else { + Tcl_NewInstanceMethod(interp, (Tcl_Object) oPtr, namePtr, + mPtr->flags & PUBLIC_METHOD, mPtr->typePtr, mPtr->clientData); + } + return TCL_OK; +} + +static int +CloneClassMethod( + Tcl_Interp *interp, + Class *clsPtr, + Method *mPtr, + Tcl_Obj *namePtr, + Method **m2PtrPtr) +{ + Method *m2Ptr; + + if (mPtr->typePtr == NULL) { + m2Ptr = (Method *) Tcl_NewMethod(interp, (Tcl_Class) clsPtr, + namePtr, mPtr->flags & PUBLIC_METHOD, NULL, NULL); + } else if (mPtr->typePtr->cloneProc) { + ClientData newClientData; + + if (mPtr->typePtr->cloneProc(interp, mPtr->clientData, + &newClientData) != TCL_OK) { + return TCL_ERROR; + } + m2Ptr = (Method *) Tcl_NewMethod(interp, (Tcl_Class) clsPtr, + namePtr, mPtr->flags & PUBLIC_METHOD, mPtr->typePtr, + newClientData); + } else { + m2Ptr = (Method *) Tcl_NewMethod(interp, (Tcl_Class) clsPtr, + namePtr, mPtr->flags & PUBLIC_METHOD, mPtr->typePtr, + mPtr->clientData); + } + if (m2PtrPtr != NULL) { + *m2PtrPtr = m2Ptr; + } + 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; + } + 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) { + typePtr->deleteProc(Tcl_GetHashValue(hPtr)); + 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; + } + 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) { + typePtr->deleteProc(Tcl_GetHashValue(hPtr)); + 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, TclOOInvokeObject, TclOOObjectCmdCore -- + * + * Main entry point for object invokations. The Public* and Private* + * wrapper functions are just thin wrappers round the main + * TclOOObjectCmdCore function that does call chain creation, management + * and invokation. + * + * ---------------------------------------------------------------------- + */ + +static int +PublicObjectCmd( + ClientData clientData, + Tcl_Interp *interp, + int objc, + Tcl_Obj *const *objv) +{ + return TclOOObjectCmdCore(clientData, interp, objc, objv, PUBLIC_METHOD, + NULL); +} + +static int +PrivateObjectCmd( + ClientData clientData, + Tcl_Interp *interp, + int objc, + Tcl_Obj *const *objv) +{ + return TclOOObjectCmdCore(clientData, interp, objc, objv, 0, NULL); +} + +int +TclOOInvokeObject( + Tcl_Interp *interp, /* Interpreter for commands, variables, + * results, error reporting, etc. */ + Tcl_Object object, /* The object to invoke. */ + Tcl_Class startCls, /* Where in the class chain to start the + * invoke from, or NULL to traverse the whole + * chain including filters. */ + int publicPrivate, /* Whether this is an invoke from a public + * context (PUBLIC_METHOD), a private context + * (PRIVATE_METHOD), or a *really* private + * context (any other value; conventionally + * 0). */ + int objc, /* Number of arguments. */ + Tcl_Obj *const *objv) /* Array of argument objects. It is assumed + * that the name of the method to invoke will + * be at index 1. */ +{ + switch (publicPrivate) { + case PUBLIC_METHOD: + return TclOOObjectCmdCore((Object *) object, interp, objc, objv, + PUBLIC_METHOD, (Class *) startCls); + case PRIVATE_METHOD: + return TclOOObjectCmdCore((Object *) object, interp, objc, objv, + PRIVATE_METHOD, (Class *) startCls); + default: + return TclOOObjectCmdCore((Object *) object, interp, objc, objv, 0, + (Class *) startCls); + } +} + +int +TclOOObjectCmdCore( + 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 flags, /* Whether this is an invokation through the + * public or the private command interface. */ + Class *startCls) /* Where to start in the call chain, or NULL + * if we are to start at the front with + * filters and the object's methods (which is + * the normal case). */ +{ + CallContext *contextPtr; + Tcl_Obj *methodNamePtr; + int result; + + if (objc < 2) { + Tcl_WrongNumArgs(interp, 1, objv, "method ?arg ...?"); + return TCL_ERROR; + } + + /* + * Give plugged in code a chance to remap the method name. + */ + + methodNamePtr = objv[1]; + if (oPtr->mapMethodNameProc != NULL) { + register Class **startClsPtr = &startCls; + + methodNamePtr = Tcl_DuplicateObj(methodNamePtr); + result = oPtr->mapMethodNameProc(interp, (Tcl_Object) oPtr, + (Tcl_Class *) startClsPtr, methodNamePtr); + if (result != TCL_OK) { + if (result == TCL_ERROR) { + Tcl_AddErrorInfo(interp, "\n (while mapping method name)"); + } + Tcl_DecrRefCount(methodNamePtr); + return result; + } + } + Tcl_IncrRefCount(methodNamePtr); + + /* + * Get the call chain. + */ + + contextPtr = TclOOGetCallContext(oPtr, methodNamePtr, + flags | (oPtr->flags & FILTER_HANDLING)); + if (contextPtr == NULL) { + Tcl_AppendResult(interp, "impossible to invoke method \"", + TclGetString(methodNamePtr), + "\": no defined method or unknown method", NULL); + Tcl_DecrRefCount(methodNamePtr); + return TCL_ERROR; + } + Tcl_DecrRefCount(methodNamePtr); + + /* + * Check to see if we need to apply magical tricks to start part way + * through the call chain. + */ + + if (startCls != NULL) { + while (contextPtr->index < contextPtr->callPtr->numChain) { + register struct MInvoke *miPtr = + &contextPtr->callPtr->chain[contextPtr->index]; + + if (miPtr->isFilter || miPtr->mPtr->declaringClassPtr!=startCls) { + contextPtr->index++; + } else { + break; + } + } + if (contextPtr->index >= contextPtr->callPtr->numChain) { + result = TCL_ERROR; + Tcl_SetResult(interp, "no valid method implementation", + TCL_STATIC); + AddRef(oPtr); /* Just to balance. */ + goto disposeChain; + } + } + + /* + * Invoke the call chain, locking the object structure against deletion + * for the duration. + */ + + AddRef(oPtr); + result = TclOOInvokeContext(interp, contextPtr, objc, objv); + + /* + * Dispose of the call chain and drop the lock on the object's structure. + */ + + disposeChain: + TclOODeleteContext(contextPtr); + DelRef(oPtr); + return result; +} + +/* + * ---------------------------------------------------------------------- + * + * Tcl_ObjectContextInvokeNext -- + * + * Invokes the next stage of the call chain described in an object + * context. This is the core of the implementation of the [next] command. + * Does not do management of the call-frame stack. + * + * ---------------------------------------------------------------------- + */ + +int +Tcl_ObjectContextInvokeNext( + Tcl_Interp *interp, + Tcl_ObjectContext context, + int objc, + Tcl_Obj *const *objv, + int skip) +{ + CallContext *contextPtr = (CallContext *) context; + int savedIndex = contextPtr->index; + int savedSkip = contextPtr->skip; + int result; + + if (contextPtr->index+1 >= contextPtr->callPtr->numChain) { + /* + * We're at the end of the chain; return the empty string (the most + * useful thing we can do, since it turns out that it's not always + * trivial to detect in source code whether there is a parent + * implementation, what with multiple-inheritance...) + */ + + return TCL_OK; + } + + /* + * 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. + */ + + contextPtr->index++; + contextPtr->skip = skip; + + /* + * Invoke the (advanced) method call context in the caller context. + */ + + result = TclOOInvokeContext(interp, contextPtr, objc, objv); + + /* + * Restore the call chain context index as we've finished the inner invoke + * and want to operate in the outer context again. + */ + + contextPtr->index = savedIndex; + contextPtr->skip = savedSkip; + + return result; +} + +/* + * ---------------------------------------------------------------------- + * + * Tcl_GetObjectFromObj -- + * + * Utility function to get an object from a Tcl_Obj containing its name. + * + * ---------------------------------------------------------------------- + */ + +Tcl_Object +Tcl_GetObjectFromObj( + Tcl_Interp *interp, /* Interpreter in which to locate the object. + * Will have an error message placed in it if + * the name does not refer to an object. */ + Tcl_Obj *objPtr) /* The name of the object to look up, which is + * exactly the name of its public command. */ +{ + Command *cmdPtr = (Command *) Tcl_GetCommandFromObj(interp, objPtr); + + if (cmdPtr == NULL) { + goto notAnObject; + } + if (cmdPtr->objProc != PublicObjectCmd) { + cmdPtr = (Command *) TclGetOriginalCommand((Tcl_Command) cmdPtr); + if (cmdPtr == NULL || cmdPtr->objProc != PublicObjectCmd) { + goto notAnObject; + } + } + return cmdPtr->objClientData; + + notAnObject: + Tcl_AppendResult(interp, TclGetString(objPtr), + " does not refer to an object", NULL); + return NULL; +} + +/* + * ---------------------------------------------------------------------- + * + * 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->mixins.num == 0) { + startPtr = startPtr->superclasses.list[0]; + goto tailRecurse; + } + FOREACH(superPtr, startPtr->superclasses) { + if (TclOOIsReachable(targetPtr, superPtr)) { + return 1; + } + } + FOREACH(superPtr, startPtr->mixins) { + if (TclOOIsReachable(targetPtr, superPtr)) { + return 1; + } + } + return 0; +} + +/* + * ---------------------------------------------------------------------- + * + * TclOOObjectName -- + * + * Utility function that returns the name of the object. Note that this + * simplifies cache management by keeping the code to do it in one place + * and not sprayed all over. The value returned always has a reference + * count of at least one. + * + * ---------------------------------------------------------------------- + */ + +Tcl_Obj * +TclOOObjectName( + Tcl_Interp *interp, + Object *oPtr) +{ + Tcl_Obj *namePtr; + + if (oPtr->cachedNameObj) { + return oPtr->cachedNameObj; + } + namePtr = Tcl_NewObj(); + Tcl_GetCommandFullName(interp, oPtr->command, namePtr); + Tcl_IncrRefCount(namePtr); + oPtr->cachedNameObj = namePtr; + return namePtr; +} + +/* + * ---------------------------------------------------------------------- + * + * assorted trivial 'getter' functions + * + * ---------------------------------------------------------------------- + */ + +Tcl_Method +Tcl_ObjectContextMethod( + Tcl_ObjectContext context) +{ + CallContext *contextPtr = (CallContext *) context; + return (Tcl_Method) contextPtr->callPtr->chain[contextPtr->index].mPtr; +} + +int +Tcl_ObjectContextIsFiltering( + Tcl_ObjectContext context) +{ + CallContext *contextPtr = (CallContext *) context; + return contextPtr->callPtr->chain[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_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; +} + +Tcl_ObjectMapMethodNameProc +Tcl_ObjectGetMethodNameMapper( + Tcl_Object object) +{ + return ((Object *) object)->mapMethodNameProc; +} + +void +Tcl_ObjectSetMethodNameMapper( + Tcl_Object object, + Tcl_ObjectMapMethodNameProc mapMethodNameProc) +{ + ((Object *) object)->mapMethodNameProc = mapMethodNameProc; +} + +/* + * Local Variables: + * mode: c + * c-basic-offset: 4 + * fill-column: 78 + * End: + */ diff --git a/generic/tclOO.decls b/generic/tclOO.decls new file mode 100644 index 0000000..0fdbe47 --- /dev/null +++ b/generic/tclOO.decls @@ -0,0 +1,190 @@ +# -*- tcl -*- +# $Id: tclOO.decls,v 1.1 2008/05/31 11:42:17 dkf Exp $ + +# public API +library tclOO +interface tclOO +epoch 0 +scspec TCLOOAPI + +declare 0 current { + Tcl_Object Tcl_CopyObjectInstance(Tcl_Interp *interp, + Tcl_Object sourceObject, const char *targetName, + const char *targetNamespaceName) +} +declare 1 current { + Tcl_Object Tcl_GetClassAsObject(Tcl_Class clazz) +} +declare 2 current { + Tcl_Class Tcl_GetObjectAsClass(Tcl_Object object) +} +declare 3 current { + Tcl_Command Tcl_GetObjectCommand(Tcl_Object object) +} +declare 4 current { + Tcl_Object Tcl_GetObjectFromObj(Tcl_Interp *interp, Tcl_Obj *objPtr) +} +declare 5 current { + Tcl_Namespace *Tcl_GetObjectNamespace(Tcl_Object object) +} +declare 6 current { + Tcl_Class Tcl_MethodDeclarerClass(Tcl_Method method) +} +declare 7 current { + Tcl_Object Tcl_MethodDeclarerObject(Tcl_Method method) +} +declare 8 current { + int Tcl_MethodIsPublic(Tcl_Method method) +} +declare 9 current { + int Tcl_MethodIsType(Tcl_Method method, const Tcl_MethodType *typePtr, + ClientData *clientDataPtr) +} +declare 10 current { + Tcl_Obj *Tcl_MethodName(Tcl_Method method) +} +declare 11 current { + Tcl_Method Tcl_NewInstanceMethod(Tcl_Interp *interp, Tcl_Object object, + Tcl_Obj *nameObj, int isPublic, const Tcl_MethodType *typePtr, + ClientData clientData) +} +declare 12 current { + Tcl_Method Tcl_NewMethod(Tcl_Interp *interp, Tcl_Class cls, + Tcl_Obj *nameObj, int isPublic, const Tcl_MethodType *typePtr, + ClientData clientData) +} +declare 13 current { + Tcl_Object Tcl_NewObjectInstance(Tcl_Interp *interp, Tcl_Class cls, + const char *nameStr, const char *nsNameStr, int objc, + Tcl_Obj *const *objv, int skip) +} +declare 14 current { + int Tcl_ObjectDeleted(Tcl_Object object) +} +declare 15 current { + int Tcl_ObjectContextIsFiltering(Tcl_ObjectContext context) +} +declare 16 current { + Tcl_Method Tcl_ObjectContextMethod(Tcl_ObjectContext context) +} +declare 17 current { + Tcl_Object Tcl_ObjectContextObject(Tcl_ObjectContext context) +} +declare 18 current { + int Tcl_ObjectContextSkippedArgs(Tcl_ObjectContext context) +} +declare 19 current { + ClientData Tcl_ClassGetMetadata(Tcl_Class clazz, + const Tcl_ObjectMetadataType *typePtr) +} +declare 20 current { + void Tcl_ClassSetMetadata(Tcl_Class clazz, + const Tcl_ObjectMetadataType *typePtr, ClientData metadata) +} +declare 21 current { + ClientData Tcl_ObjectGetMetadata(Tcl_Object object, + const Tcl_ObjectMetadataType *typePtr) +} +declare 22 current { + void Tcl_ObjectSetMetadata(Tcl_Object object, + const Tcl_ObjectMetadataType *typePtr, ClientData metadata) +} +declare 23 current { + int Tcl_ObjectContextInvokeNext(Tcl_Interp *interp, + Tcl_ObjectContext context, int objc, Tcl_Obj *const *objv, + int skip) +} +declare 24 current { + Tcl_ObjectMapMethodNameProc Tcl_ObjectGetMethodNameMapper( + Tcl_Object object) +} +declare 25 current { + void Tcl_ObjectSetMethodNameMapper(Tcl_Object object, + Tcl_ObjectMapMethodNameProc mapMethodNameProc) +} +declare 26 current { + void Tcl_ClassSetConstructor(Tcl_Interp *interp, Tcl_Class clazz, + Tcl_Method method) +} +declare 27 current { + void Tcl_ClassSetDestructor(Tcl_Interp *interp, Tcl_Class clazz, + Tcl_Method method) +} + +# private API, exposed to support advanced OO systems that plug in on top +interface tclOOInt +declare 0 current { + Tcl_Object TclOOGetDefineCmdContext(Tcl_Interp *interp) +} +declare 1 current { + Tcl_Method TclOOMakeProcInstanceMethod(Tcl_Interp *interp, Object *oPtr, + int flags, Tcl_Obj *nameObj, Tcl_Obj *argsObj, Tcl_Obj *bodyObj, + const Tcl_MethodType *typePtr, ClientData clientData, + Proc **procPtrPtr) +} +declare 2 current { + Tcl_Method TclOOMakeProcMethod(Tcl_Interp *interp, Class *clsPtr, + int flags, Tcl_Obj *nameObj, const char *namePtr, + Tcl_Obj *argsObj, Tcl_Obj *bodyObj, const Tcl_MethodType *typePtr, + ClientData clientData, Proc **procPtrPtr) +} +declare 3 current { + Method *TclOONewProcInstanceMethod(Tcl_Interp *interp, Object *oPtr, + int flags, Tcl_Obj *nameObj, Tcl_Obj *argsObj, Tcl_Obj *bodyObj, + ProcedureMethod **pmPtrPtr) +} +declare 4 current { + Method *TclOONewProcMethod(Tcl_Interp *interp, Class *clsPtr, + int flags, Tcl_Obj *nameObj, Tcl_Obj *argsObj, Tcl_Obj *bodyObj, + ProcedureMethod **pmPtrPtr) +} +declare 5 current { + int TclOOObjectCmdCore(Object *oPtr, Tcl_Interp *interp, int objc, + Tcl_Obj *const *objv, int publicOnly, Class *startCls) +} +declare 6 current { + int TclOOIsReachable(Class *targetPtr, Class *startPtr) +} +declare 7 current { + Method *TclOONewForwardMethod(Tcl_Interp *interp, Class *clsPtr, + int isPublic, Tcl_Obj *nameObj, Tcl_Obj *prefixObj) +} +declare 8 current { + Method *TclOONewForwardInstanceMethod(Tcl_Interp *interp, Object *oPtr, + int isPublic, Tcl_Obj *nameObj, Tcl_Obj *prefixObj) +} +declare 9 current { + Tcl_Method TclOONewProcInstanceMethodEx(Tcl_Interp *interp, + Tcl_Object oPtr, TclOO_PreCallProc preCallPtr, + TclOO_PostCallProc postCallPtr, ProcErrorProc errProc, + ClientData clientData, Tcl_Obj *nameObj, Tcl_Obj *argsObj, + Tcl_Obj *bodyObj, int flags, void **internalTokenPtr) +} +declare 10 current { + Tcl_Method TclOONewProcMethodEx(Tcl_Interp *interp, Tcl_Class clsPtr, + TclOO_PreCallProc preCallPtr, TclOO_PostCallProc postCallPtr, + ProcErrorProc errProc, ClientData clientData, Tcl_Obj *nameObj, + Tcl_Obj *argsObj, Tcl_Obj *bodyObj, int flags, + void **internalTokenPtr) +} +declare 11 current { + int TclOOInvokeObject(Tcl_Interp *interp, Tcl_Object object, + Tcl_Class startCls, int publicPrivate, int objc, + Tcl_Obj *const *objv) +} +declare 12 current { + void TclOOObjectSetFilters(Object *oPtr, int numFilters, + Tcl_Obj *const *filters) +} +declare 13 current { + void TclOOClassSetFilters(Tcl_Interp *interp, Class *classPtr, + int numFilters, Tcl_Obj *const *filters) +} +declare 14 current { + void TclOOObjectSetMixins(Object *oPtr, int numMixins, + Class *const *mixins) +} +declare 15 current { + void TclOOClassSetMixins(Tcl_Interp *interp, Class *classPtr, + int numMixins, Class *const *mixins) +} diff --git a/generic/tclOO.h b/generic/tclOO.h new file mode 100644 index 0000000..f3fd73c --- /dev/null +++ b/generic/tclOO.h @@ -0,0 +1,128 @@ +/* + * tclOO.h -- + * + * This file contains the public API definitions and some of the function + * declarations for the object-system (NB: not Tcl_Obj, but ::oo). + * + * Copyright (c) 2006-2008 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.4 2008/05/31 11:42:17 dkf Exp $ + */ + +#ifndef TCLOO_H_INCLUDED +#define TCLOO_H_INCLUDED +#include "tcl.h" + +#if defined(BUILD_tcloo) +# define TCLOOAPI DLLEXPORT +# undef USE_TCLOO_STUBS +#else +# define TCLOOAPI DLLIMPORT +#endif + +/* + * Must match version at top of ../configure.in + */ + +#define TCLOO_VERSION "0.4" +#define TCLOO_PATCHLEVEL TCLOO_VERSION + +/* + * These are opaque types. + */ + +typedef struct Tcl_Class_ *Tcl_Class; +typedef struct Tcl_Method_ *Tcl_Method; +typedef struct Tcl_Object_ *Tcl_Object; +typedef struct Tcl_ObjectContext_ *Tcl_ObjectContext; + +/* + * 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)(ClientData clientData, Tcl_Interp *interp, + Tcl_ObjectContext objectContext, int objc, Tcl_Obj *const *objv); +typedef void (*Tcl_MethodDeleteProc)(ClientData clientData); +typedef int (*Tcl_CloneProc)(Tcl_Interp *interp, ClientData oldClientData, + ClientData *newClientData); +typedef void (*Tcl_ObjectMetadataDeleteProc)(ClientData clientData); +typedef int (*Tcl_ObjectMapMethodNameProc)(Tcl_Interp *interp, + Tcl_Object object, Tcl_Class *startClsPtr, Tcl_Obj *methodNameObj); + +/* + * 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_CloneProc 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_CloneProc cloneProc; /* How to copy the metadata, or NULL if the + * type-specific data can be copied + * directly. */ +} 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_METADATA_VERSION_CURRENT 1 + +/* + * Include all the public API, generated from tclOO.decls. + */ + +#include "tclOODecls.h" + +#endif + +/* + * Local Variables: + * mode: c + * c-basic-offset: 4 + * fill-column: 78 + * End: + */ diff --git a/generic/tclOOBasic.c b/generic/tclOOBasic.c new file mode 100644 index 0000000..1cd07df --- /dev/null +++ b/generic/tclOOBasic.c @@ -0,0 +1,925 @@ +/* + * tclOOBasic.c -- + * + * This file contains implementations of the "simple" commands and + * methods from the object-system core. + * + * Copyright (c) 2005-2008 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: tclOOBasic.c,v 1.1 2008/05/31 11:42:17 dkf Exp $ + */ + +#ifdef HAVE_CONFIG_H +#include "config.h" +#endif +#include "tclInt.h" +#include "tclOOInt.h" + +/* + * ---------------------------------------------------------------------- + * + * TclOO_Class_Create -- + * + * Implementation for oo::class->create method. + * + * ---------------------------------------------------------------------- + */ + +int +TclOO_Class_Create( + 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 = TclOOObjectName(interp, oPtr); + + Tcl_AppendResult(interp, "object \"", TclGetString(cmdnameObj), + "\" is not a class", NULL); + 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, NULL, objc, objv, + Tcl_ObjectContextSkippedArgs(context)+1); + if (newObject == NULL) { + return TCL_ERROR; + } + Tcl_SetObjResult(interp, TclOOObjectName(interp, (Object *) newObject)); + return TCL_OK; +} + +/* + * ---------------------------------------------------------------------- + * + * TclOO_Class_CreateNs -- + * + * Implementation for oo::class->createWithNamespace method. + * + * ---------------------------------------------------------------------- + */ + +int +TclOO_Class_CreateNs( + 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, *nsName; + int len; + + /* + * Sanity check; should not be possible to invoke this method on a + * non-class. + */ + + if (oPtr->classPtr == NULL) { + Tcl_Obj *cmdnameObj = TclOOObjectName(interp, oPtr); + + Tcl_AppendResult(interp, "object \"", TclGetString(cmdnameObj), + "\" is not a class", NULL); + return TCL_ERROR; + } + + /* + * Check we have the right number of (sensible) arguments. + */ + + if (objc - Tcl_ObjectContextSkippedArgs(context) < 2) { + Tcl_WrongNumArgs(interp, Tcl_ObjectContextSkippedArgs(context), objv, + "objectName namespaceName ?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; + } + nsName = Tcl_GetStringFromObj( + objv[Tcl_ObjectContextSkippedArgs(context)+1], &len); + if (len == 0) { + Tcl_AppendResult(interp, "namespace 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, nsName, objc, objv, + Tcl_ObjectContextSkippedArgs(context)+2); + if (newObject == NULL) { + return TCL_ERROR; + } + Tcl_SetObjResult(interp, TclOOObjectName(interp, (Object *) newObject)); + return TCL_OK; +} + +/* + * ---------------------------------------------------------------------- + * + * TclOO_Class_New -- + * + * Implementation for oo::class->new method. + * + * ---------------------------------------------------------------------- + */ + +int +TclOO_Class_New( + 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 = TclOOObjectName(interp, oPtr); + + Tcl_AppendResult(interp, "object \"", TclGetString(cmdnameObj), + "\" is not a class", NULL); + return TCL_ERROR; + } + + /* + * Make the object and return its name. + */ + + newObject = Tcl_NewObjectInstance(interp, (Tcl_Class) oPtr->classPtr, + NULL, NULL, objc, objv, Tcl_ObjectContextSkippedArgs(context)); + if (newObject == NULL) { + return TCL_ERROR; + } + Tcl_SetObjResult(interp, TclOOObjectName(interp, (Object *) newObject)); + return TCL_OK; +} + +/* + * ---------------------------------------------------------------------- + * + * TclOO_Object_Destroy -- + * + * Implementation for oo::object->destroy method. + * + * ---------------------------------------------------------------------- + */ + +int +TclOO_Object_Destroy( + 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; +} + +/* + * ---------------------------------------------------------------------- + * + * TclOO_Object_Eval -- + * + * Implementation for oo::object->eval method. + * + * ---------------------------------------------------------------------- + */ + +int +TclOO_Object_Eval( + 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->callPtr->flags & PUBLIC_METHOD) { + objnameObj = TclOOObjectName(interp, (Object *) object); + } else { + objnameObj = Tcl_NewStringObj("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) { + Tcl_AppendObjToErrorInfo(interp, Tcl_ObjPrintf( + "\n (in \"%s eval\" script line %d)", + TclGetString(objnameObj), interp->errorLine)); + } + + /* + * Restore the previous "current" namespace. + */ + + TclPopStackFrame(interp); + Tcl_DecrRefCount(objnameObj); + return result; +} + +/* + * ---------------------------------------------------------------------- + * + * TclOO_Object_Unknown -- + * + * Default unknown method handler method (defined in oo::object). This + * just creates a suitable error message. + * + * ---------------------------------------------------------------------- + */ + +int +TclOO_Object_Unknown( + 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, skip = Tcl_ObjectContextSkippedArgs(context); + + if (objc < skip+1) { + Tcl_WrongNumArgs(interp, skip, objv, "methodName ?arg ...?"); + return TCL_ERROR; + } + + /* + * Get the list of methods that we want to know about. + */ + + numMethodNames = TclOOGetSortedMethodList(oPtr, + contextPtr->callPtr->flags & PUBLIC_METHOD, &methodNames); + + /* + * Special message when there are no visible methods at all. + */ + + if (numMethodNames == 0) { + Tcl_Obj *tmpBuf = TclOOObjectName(interp, oPtr); + + Tcl_AppendResult(interp, "object \"", TclGetString(tmpBuf), NULL); + if (contextPtr->callPtr->flags & PUBLIC_METHOD) { + Tcl_AppendResult(interp, "\" has no visible methods", NULL); + } else { + Tcl_AppendResult(interp, "\" has no methods", NULL); + } + return TCL_ERROR; + } + + Tcl_AppendResult(interp, "unknown method \"", TclGetString(objv[skip]), + "\": 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; +} + +/* + * ---------------------------------------------------------------------- + * + * TclOO_Object_LinkVar -- + * + * Implementation of oo::object->variable method. + * + * ---------------------------------------------------------------------- + */ + +int +TclOO_Object_LinkVar( + 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; + const char *varName = TclGetString(objv[i]); + + /* + * The variable name must not contain a '::' since that's illegal in + * local names. + */ + + if (strstr(varName, "::") != NULL) { + 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, objv[i], 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, varName, 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); + } + + if (TclPtrMakeUpvar(interp, varPtr, varName, 0, -1) != TCL_OK) { + return TCL_ERROR; + } + } + return TCL_OK; +} + +/* + * ---------------------------------------------------------------------- + * + * TclOO_Object_VarName -- + * + * Implementation of the oo::object->varname method. + * + * ---------------------------------------------------------------------- + */ + +int +TclOO_Object_VarName( + 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; + } + + varNamePtr = Tcl_NewObj(); + Tcl_GetVariableFullName(interp, (Tcl_Var) varPtr, varNamePtr); + Tcl_SetObjResult(interp, varNamePtr); + return TCL_OK; +} + +/* + * ---------------------------------------------------------------------- + * + * TclOONextObjCmd -- + * + * Implementation of the [next] command. Note that this command is only + * ever to be used inside the body of a procedure-like method. + * + * ---------------------------------------------------------------------- + */ + +int +TclOONextObjCmd( + ClientData clientData, + Tcl_Interp *interp, + int objc, + Tcl_Obj *const *objv) +{ + Interp *iPtr = (Interp *) interp; + CallFrame *framePtr = iPtr->varFramePtr; + Tcl_ObjectContext context; + int result; + + /* + * Start with sanity checks on the calling context to make sure that we + * are invoked from a suitable method context. If so, we can safely + * retrieve the handle to the object call 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; + } + context = framePtr->clientData; + + /* + * Invoke the (advanced) method call context in the caller context. Note + * that this is like [uplevel 1] and not [eval]. + */ + + iPtr->varFramePtr = framePtr->callerVarPtr; + result = Tcl_ObjectContextInvokeNext(interp, context, objc, objv, 1); + iPtr->varFramePtr = framePtr; + return result; +} + +/* + * ---------------------------------------------------------------------- + * + * TclOOSelfObjCmd -- + * + * Implementation of the [self] command, which provides introspection of + * the call context. + * + * ---------------------------------------------------------------------- + */ + +int +TclOOSelfObjCmd( + 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; + +#define CurrentlyInvoked(contextPtr) \ + ((contextPtr)->callPtr->chain[(contextPtr)->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->clientData; + + /* + * 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; + } else 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_SetObjResult(interp, TclOOObjectName(interp, contextPtr->oPtr)); + return TCL_OK; + case SELF_NS: + Tcl_SetObjResult(interp, Tcl_NewStringObj( + contextPtr->oPtr->namespacePtr->fullName,-1)); + return TCL_OK; + case SELF_CLASS: { + Method *mPtr = CurrentlyInvoked(contextPtr).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_SetObjResult(interp, TclOOObjectName(interp, declarerPtr)); + return TCL_OK; + } + case SELF_METHOD: + if (contextPtr->callPtr->flags & CONSTRUCTOR) { + Tcl_AppendResult(interp, "<constructor>", NULL); + } else if (contextPtr->callPtr->flags & DESTRUCTOR) { + Tcl_AppendResult(interp, "<destructor>", NULL); + } else { + Tcl_SetObjResult(interp, + CurrentlyInvoked(contextPtr).mPtr->namePtr); + } + return TCL_OK; + case SELF_FILTER: + if (!CurrentlyInvoked(contextPtr).isFilter) { + Tcl_AppendResult(interp, "not inside a filtering context", NULL); + return TCL_ERROR; + } else { + register struct MInvoke *miPtr = &CurrentlyInvoked(contextPtr); + Tcl_Obj *result[3]; + Object *oPtr; + const char *type; + + if (miPtr->filterDeclarer != NULL) { + oPtr = miPtr->filterDeclarer->thisPtr; + type = "class"; + } else { + oPtr = contextPtr->oPtr; + type = "object"; + } + + result[0] = TclOOObjectName(interp, oPtr); + result[1] = Tcl_NewStringObj(type, -1); + result[2] = miPtr->mPtr->namePtr; + Tcl_SetObjResult(interp, Tcl_NewListObj(3, result)); + return TCL_OK; + } + case SELF_CALLER: + if ((framePtr->callerVarPtr != NULL) && + (framePtr->callerVarPtr->isProcCallFrame & FRAME_IS_METHOD)) { + CallContext *callerPtr = framePtr->callerVarPtr->clientData; + Method *mPtr = callerPtr->callPtr->chain[callerPtr->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_ListObjAppendElement(NULL, Tcl_GetObjResult(interp), + TclOOObjectName(interp, declarerPtr)); + Tcl_ListObjAppendElement(NULL, Tcl_GetObjResult(interp), + TclOOObjectName(interp, callerPtr->oPtr)); + if (callerPtr->callPtr->flags & CONSTRUCTOR) { + Tcl_ListObjAppendElement(NULL, Tcl_GetObjResult(interp), + Tcl_NewStringObj("<constructor>", -1)); + } else if (callerPtr->callPtr->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->callPtr->numChain-1) { + Method *mPtr = + contextPtr->callPtr->chain[contextPtr->index+1].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_ListObjAppendElement(NULL, Tcl_GetObjResult(interp), + TclOOObjectName(interp, declarerPtr)); + if (contextPtr->callPtr->flags & CONSTRUCTOR) { + Tcl_ListObjAppendElement(NULL, Tcl_GetObjResult(interp), + Tcl_NewStringObj("<constructor>", -1)); + } else if (contextPtr->callPtr->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 (!CurrentlyInvoked(contextPtr).isFilter) { + Tcl_AppendResult(interp, "not inside a filtering context", NULL); + return TCL_ERROR; + } else { + Method *mPtr; + Object *declarerPtr; + int i; + + for (i=contextPtr->index ; i<contextPtr->callPtr->numChain ; i++){ + if (!contextPtr->callPtr->chain[i].isFilter) { + break; + } + } + if (i == contextPtr->callPtr->numChain) { + Tcl_Panic("filtering call chain without terminal non-filter"); + } + mPtr = contextPtr->callPtr->chain[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; + } + Tcl_ListObjAppendElement(NULL, Tcl_GetObjResult(interp), + TclOOObjectName(interp, declarerPtr)); + Tcl_ListObjAppendElement(NULL, Tcl_GetObjResult(interp), + mPtr->namePtr); + return TCL_OK; + } + } + return TCL_ERROR; +} + +/* + * ---------------------------------------------------------------------- + * + * CopyObjectCmd -- + * + * Implementation of the [oo::copy] command, which clones an object (but + * not its namespace). Note that no constructors are called during this + * process. + * + * ---------------------------------------------------------------------- + */ + +int +TclOOCopyObjectCmd( + ClientData clientData, + Tcl_Interp *interp, + int objc, + Tcl_Obj *const *objv) +{ + Tcl_Object oPtr, o2Ptr; + + if (objc < 2 || objc > 3) { + Tcl_WrongNumArgs(interp, 1, objv, "sourceName ?targetName?"); + return TCL_ERROR; + } + + oPtr = Tcl_GetObjectFromObj(interp, objv[1]); + 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 == 2) { + o2Ptr = Tcl_CopyObjectInstance(interp, oPtr, NULL, NULL); + } else { + char *name; + Tcl_DString buffer; + + name = TclGetString(objv[2]); + Tcl_DStringInit(&buffer); + if (name[0]!=':' || name[1]!=':') { + Interp *iPtr = (Interp *) interp; + + if (iPtr->varFramePtr != NULL) { + Tcl_DStringAppend(&buffer, + iPtr->varFramePtr->nsPtr->fullName, -1); + } + Tcl_DStringAppend(&buffer, "::", 2); + Tcl_DStringAppend(&buffer, name, -1); + name = Tcl_DStringValue(&buffer); + } + o2Ptr = Tcl_CopyObjectInstance(interp, oPtr, name, NULL); + Tcl_DStringFree(&buffer); + } + + if (o2Ptr == NULL) { + return TCL_ERROR; + } + + /* + * Return the name of the cloned object. + */ + + Tcl_SetObjResult(interp, TclOOObjectName(interp, (Object *) o2Ptr)); + return TCL_OK; +} + +/* + * 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..551a3fd --- /dev/null +++ b/generic/tclOOCall.c @@ -0,0 +1,1211 @@ +/* + * tclOOCall.c -- + * + * This file contains the method call chain management code for the + * object-system core. + * + * Copyright (c) 2005-2008 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.4 2008/05/31 11:42:17 dkf Exp $ + */ + +#ifdef HAVE_CONFIG_H +#include "config.h" +#endif +#include "tclInt.h" +#include "tclOOInt.h" + +/* + * Structure containing a CallContext and any other values needed only during + * the construction of the CallContext. + */ + +struct ChainBuilder { + CallChain *callChainPtr; /* The call chain being built. */ + int filterLength; /* Number of entries in the call chain that + * are due to processing filters and not the + * main call chain. */ + Object *oPtr; /* The object that we are building the chain + * for. */ +}; + +/* + * Extra flags used for call chain management. + */ + +#define DEFINITE_PROTECTED 0x100000 +#define DEFINITE_PUBLIC 0x200000 +#define KNOWN_STATE (DEFINITE_PROTECTED | DEFINITE_PUBLIC) +#define SPECIAL (CONSTRUCTOR | DESTRUCTOR) + +/* + * Function declarations for things defined in this file. + */ + +static void AddClassFiltersToCallContext(Object *const oPtr, + Class *clsPtr, struct ChainBuilder *const cbPtr, + Tcl_HashTable *const doneFilters); +static void AddClassMethodNames(Class *clsPtr, const int flags, + Tcl_HashTable *const namesPtr); +static inline void AddMethodToCallChain(Method *const mPtr, + struct ChainBuilder *const cbPtr, + Tcl_HashTable *const doneFilters, + Class *const filterDecl); +static inline void AddSimpleChainToCallContext(Object *const oPtr, + Tcl_Obj *const methodNameObj, + struct ChainBuilder *const cbPtr, + Tcl_HashTable *const doneFilters, int flags, + Class *const filterDecl); +static void AddSimpleClassChainToCallContext(Class *classPtr, + Tcl_Obj *const methodNameObj, + struct ChainBuilder *const cbPtr, + Tcl_HashTable *const doneFilters, int flags, + Class *const filterDecl); +static int CmpStr(const void *ptr1, const void *ptr2); +static void DupMethodNameRep(Tcl_Obj *srcPtr, Tcl_Obj *dstPtr); +static void FreeMethodNameRep(Tcl_Obj *objPtr); +static inline int IsStillValid(CallChain *callPtr, Object *oPtr, + int flags, int reuseMask); +static inline void StashCallChain(Tcl_Obj *objPtr, CallChain *callPtr); + +/* + * Object type used to manage type caches attached to method names. + */ + +static Tcl_ObjType methodNameType = { + "TclOO method name", + FreeMethodNameRep, + DupMethodNameRep, + NULL, + NULL +}; + +/* + * ---------------------------------------------------------------------- + * + * TclOODeleteContext -- + * + * Destroys a method call-chain context, which should not be in use. + * + * ---------------------------------------------------------------------- + */ + +void +TclOODeleteContext( + CallContext *contextPtr) +{ + TclOODeleteChain(contextPtr->callPtr); + TclStackFree(contextPtr->oPtr->fPtr->interp, contextPtr); +} + +/* + * ---------------------------------------------------------------------- + * + * TclOODeleteChainCache -- + * + * Destroy the cache of method call-chains. + * + * ---------------------------------------------------------------------- + */ + +void +TclOODeleteChainCache( + Tcl_HashTable *tablePtr) +{ + FOREACH_HASH_DECLS; + CallChain *callPtr; + + FOREACH_HASH_VALUE(callPtr, tablePtr) { + if (callPtr) { + TclOODeleteChain(callPtr); + } + } + Tcl_DeleteHashTable(tablePtr); + ckfree((char *) tablePtr); +} + +/* + * ---------------------------------------------------------------------- + * + * TclOODeleteChain -- + * + * Destroys a method call-chain. + * + * ---------------------------------------------------------------------- + */ + +void +TclOODeleteChain( + CallChain *callPtr) +{ + if (--callPtr->refCount >= 1) { + return; + } + if (callPtr->chain != callPtr->staticChain) { + ckfree((char *) callPtr->chain); + } + ckfree((char *) callPtr); +} + +/* + * ---------------------------------------------------------------------- + * + * TclOOStashContext -- + * + * Saves a reference to a method call context in a Tcl_Obj's internal + * representation. + * + * ---------------------------------------------------------------------- + */ + +static inline void +StashCallChain( + Tcl_Obj *objPtr, + CallChain *callPtr) +{ + callPtr->refCount++; + if (objPtr->typePtr && objPtr->typePtr->freeIntRepProc) { + objPtr->typePtr->freeIntRepProc(objPtr); + } + objPtr->typePtr = &methodNameType; + objPtr->internalRep.otherValuePtr = callPtr; +} + +void +TclOOStashContext( + Tcl_Obj *objPtr, + CallContext *contextPtr) +{ + StashCallChain(objPtr, contextPtr->callPtr); +} + +/* + * ---------------------------------------------------------------------- + * + * DupMethodNameRep, FreeMethodNameRep -- + * + * Functions to implement the required parts of the Tcl_Obj guts needed + * for caching of method contexts in Tcl_Objs. + * + * ---------------------------------------------------------------------- + */ + +static void +DupMethodNameRep( + Tcl_Obj *srcPtr, + Tcl_Obj *dstPtr) +{ + register CallChain *callPtr = srcPtr->internalRep.otherValuePtr; + + dstPtr->typePtr = &methodNameType; + dstPtr->internalRep.otherValuePtr = callPtr; + callPtr->refCount++; +} + +static void +FreeMethodNameRep( + Tcl_Obj *objPtr) +{ + register CallChain *callPtr = objPtr->internalRep.otherValuePtr; + + TclOODeleteChain(callPtr); + objPtr->internalRep.otherValuePtr = NULL; + objPtr->typePtr = NULL; +} + +/* + * ---------------------------------------------------------------------- + * + * 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 *const interp, /* Interpreter for error reporting, and many + * other sorts of context handling (e.g., + * commands, variables) depending on method + * implementation. */ + CallContext *const contextPtr, + /* The method call context. */ + const int objc, /* The number of arguments. */ + Tcl_Obj *const *const objv) /* The arguments as actually seen. */ +{ + Method *const mPtr = contextPtr->callPtr->chain[contextPtr->index].mPtr; + const int isFirst = (contextPtr->index == 0); + const int isFilter = + contextPtr->callPtr->chain[contextPtr->index].isFilter; + int result, 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->callPtr->numChain ; i++) { + AddRef(contextPtr->callPtr->chain[i].mPtr); + } + + /* + * Ensure that the method name itself is part of the arguments when + * we're doing unknown processing. + */ + + if (contextPtr->callPtr->flags & OO_UNKNOWN_METHOD) { + contextPtr->skip--; + } + } + + /* + * Save whether we were in a filter and set up whether we are now. + */ + + wasFilter = contextPtr->oPtr->flags & FILTER_HANDLING; + if (isFilter || contextPtr->callPtr->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->callPtr->numChain ; i++) { + TclOODelMethodRef(contextPtr->callPtr->chain[i].mPtr); + } + } + return result; +} + +/* + * ---------------------------------------------------------------------- + * + * TclOOGetSortedMethodList, TclOOGetSortedClassMethodList -- + * + * Discovers the list of method names supported by an object or class. + * + * ---------------------------------------------------------------------- + */ + +int +TclOOGetSortedMethodList( + Object *oPtr, /* The object to get the method names for. */ + int flags, /* 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; /* Tcl_Obj* method name to "wanted in list" + * mapping. */ + FOREACH_HASH_DECLS; + int i; + Class *mixinPtr; + Tcl_Obj *namePtr; + Method *mPtr; + int isWantedIn; + void *isWanted; + + Tcl_InitObjHashTable(&names); + + /* + * Name the bits used in the names table values. + */ +#define IN_LIST 1 +#define NO_IMPLEMENTATION 2 + + /* + * Process method names due to the object. + */ + + if (oPtr->methodsPtr) { + FOREACH_HASH(namePtr, mPtr, oPtr->methodsPtr) { + int isNew; + + if ((mPtr->flags & PRIVATE_METHOD) && !(flags & PRIVATE_METHOD)) { + continue; + } + hPtr = Tcl_CreateHashEntry(&names, (char *) namePtr, &isNew); + if (isNew) { + isWantedIn = ((!(flags & PUBLIC_METHOD) + || mPtr->flags & PUBLIC_METHOD) ? IN_LIST : 0); + isWantedIn |= (mPtr->typePtr == NULL ? NO_IMPLEMENTATION : 0); + Tcl_SetHashValue(hPtr, (void *) isWantedIn); + } + } + } + + /* + * Process method names due to private methods on the object's class. + */ + + if (flags & PRIVATE_METHOD) { + FOREACH_HASH(namePtr, mPtr, &oPtr->selfCls->classMethods) { + if (mPtr->flags & PRIVATE_METHOD) { + int isNew; + + hPtr = Tcl_CreateHashEntry(&names, (char *) namePtr, &isNew); + if (isNew) { + isWantedIn = IN_LIST; + if (mPtr->typePtr == NULL) { + isWantedIn |= NO_IMPLEMENTATION; + } + Tcl_SetHashValue(hPtr, (void *) isWantedIn); + } else if (mPtr->typePtr != NULL) { + isWantedIn = (int) Tcl_GetHashValue(hPtr); + if (isWantedIn & NO_IMPLEMENTATION) { + isWantedIn &= ~NO_IMPLEMENTATION; + Tcl_SetHashValue(hPtr, (void *) isWantedIn); + } + } + } + } + } + + /* + * Process (normal) method names from the class hierarchy and the mixin + * hierarchy. + */ + + AddClassMethodNames(oPtr->selfCls, flags, &names); + FOREACH(mixinPtr, oPtr->mixins) { + AddClassMethodNames(mixinPtr, flags, &names); + } + + /* + * See how many (visible) method names there are. If none, we do not (and + * should not) try to sort the list of them. + */ + + i = 0; + if (names.numEntries != 0) { + const char **strings; + + /* + * We need to build the list of methods to sort. We will be using + * qsort() for this, because it is very unlikely that the list will be + * heavily sorted when it is long enough to matter. + */ + + strings = (const char **) ckalloc(sizeof(char *) * names.numEntries); + FOREACH_HASH(namePtr, isWanted, &names) { + if (!(flags & PUBLIC_METHOD) || (((int)isWanted) & IN_LIST)) { + if (((int)isWanted) & NO_IMPLEMENTATION) { + continue; + } + strings[i++] = TclGetString(namePtr); + } + } + + /* + * Note that 'i' may well be less than names.numEntries when we are + * dealing with public method names. + */ + + qsort((void *) strings, (unsigned) i, sizeof(char *), CmpStr); + *stringsPtr = strings; + } + + Tcl_DeleteHashTable(&names); + return i; +} + +int +TclOOGetSortedClassMethodList( + Class *clsPtr, /* The class to get the method names for. */ + int flags, /* 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; /* Tcl_Obj* method name to "wanted in list" + * mapping. */ + FOREACH_HASH_DECLS; + int i; + Tcl_Obj *namePtr; + void *isWanted; + + Tcl_InitObjHashTable(&names); + + /* + * Process method names from the class hierarchy and the mixin hierarchy. + */ + + AddClassMethodNames(clsPtr, flags, &names); + + /* + * See how many (visible) method names there are. If none, we do not (and + * should not) try to sort the list of them. + */ + + i = 0; + if (names.numEntries != 0) { + const char **strings; + + /* + * We need to build the list of methods to sort. We will be using + * qsort() for this, because it is very unlikely that the list will be + * heavily sorted when it is long enough to matter. + */ + + strings = (const char **) ckalloc(sizeof(char *) * names.numEntries); + FOREACH_HASH(namePtr, isWanted, &names) { + if (!(flags & PUBLIC_METHOD) || (((int)isWanted) & IN_LIST)) { + if (((int)isWanted) & NO_IMPLEMENTATION) { + continue; + } + strings[i++] = TclGetString(namePtr); + } + } + + /* + * Note that 'i' may well be less than names.numEntries when we are + * dealing with public method names. + */ + + qsort((void *) strings, (unsigned) i, sizeof(char *), CmpStr); + *stringsPtr = strings; + } + + Tcl_DeleteHashTable(&names); + 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 flags, /* 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, flags, 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 = (!(flags & PUBLIC_METHOD) + || (mPtr->flags & PUBLIC_METHOD)) ? IN_LIST : 0; + + Tcl_SetHashValue(hPtr, (void *) isWanted); + } else if ((((int)Tcl_GetHashValue(hPtr)) & NO_IMPLEMENTATION) + && mPtr->typePtr != NULL) { + int isWanted = (int) Tcl_GetHashValue(hPtr); + + isWanted &= ~NO_IMPLEMENTATION; + 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, flags, namesPtr); + } + } +} + +/* + * ---------------------------------------------------------------------- + * + * 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 inline void +AddSimpleChainToCallContext( + Object *const oPtr, /* Object to add call chain entries for. */ + Tcl_Obj *const methodNameObj, + /* Name of method to add the call chain + * entries for. */ + struct ChainBuilder *const cbPtr, + /* 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. */ + Class *const filterDecl) /* The class that declared the filter. If + * NULL, either the filter was declared by the + * object or this isn't a filter. */ +{ + int i; + + if (!(flags & (KNOWN_STATE | SPECIAL)) && oPtr->methodsPtr) { + Tcl_HashEntry *hPtr = Tcl_FindHashEntry(oPtr->methodsPtr, + (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_PROTECTED; + } + } + } + if (!(flags & SPECIAL)) { + Tcl_HashEntry *hPtr; + Class *mixinPtr; + + FOREACH(mixinPtr, oPtr->mixins) { + AddSimpleClassChainToCallContext(mixinPtr, methodNameObj, cbPtr, + doneFilters, flags, filterDecl); + } + if (oPtr->methodsPtr) { + hPtr = Tcl_FindHashEntry(oPtr->methodsPtr, (char*) methodNameObj); + if (hPtr != NULL) { + AddMethodToCallChain(Tcl_GetHashValue(hPtr), cbPtr, + doneFilters, filterDecl); + } + } + } + AddSimpleClassChainToCallContext(oPtr->selfCls, methodNameObj, cbPtr, + doneFilters, flags, filterDecl); +} + +/* + * ---------------------------------------------------------------------- + * + * AddMethodToCallChain -- + * + * Utility method that manages the adding of a particular method + * implementation to a call-chain. + * + * ---------------------------------------------------------------------- + */ + +static inline void +AddMethodToCallChain( + Method *const mPtr, /* Actual method implementation to add to call + * chain (or NULL, a no-op). */ + struct ChainBuilder *const cbPtr, + /* The call chain to add the method + * implementation to. */ + Tcl_HashTable *const doneFilters, + /* Where to record what filters have been + * processed. If NULL, not processing filters. + * Note that this function does not update + * this hashtable. */ + Class *const filterDecl) /* The class that declared the filter. If + * NULL, either the filter was declared by the + * object or this isn't a filter. */ +{ + register CallChain *callPtr = cbPtr->callChainPtr; + 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; + } + + /* + * Enforce real private method handling here. We will skip adding this + * method IF + * 1) we are not allowing private methods, AND + * 2) this is a private method, AND + * 3) this is a class method, AND + * 4) this method was not declared by the class of the current object. + * + * This does mean that only classes really handle private methods. This + * should be sufficient for [incr Tcl] support though. + */ + + if (!(callPtr->flags & PRIVATE_METHOD) + && (mPtr->flags & PRIVATE_METHOD) + && (mPtr->declaringClassPtr != NULL) + && (mPtr->declaringClassPtr != cbPtr->oPtr->selfCls)) { + return; + } + + /* + * First test whether the method is already in the call chain. Skip over + * any leading filters. + */ + + for (i=cbPtr->filterLength ; i<callPtr->numChain ; i++) { + if (callPtr->chain[i].mPtr == mPtr && + callPtr->chain[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. + */ + + Class *declCls = callPtr->chain[i].filterDeclarer; + + for (; i+1<callPtr->numChain ; i++) { + callPtr->chain[i] = callPtr->chain[i+1]; + } + callPtr->chain[i].mPtr = mPtr; + callPtr->chain[i].isFilter = (doneFilters != NULL); + callPtr->chain[i].filterDeclarer = declCls; + 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 (callPtr->numChain == CALL_CHAIN_STATIC_SIZE) { + callPtr->chain = (struct MInvoke *) + ckalloc(sizeof(struct MInvoke)*(callPtr->numChain+1)); + memcpy(callPtr->chain, callPtr->staticChain, + sizeof(struct MInvoke) * callPtr->numChain); + } else if (callPtr->numChain > CALL_CHAIN_STATIC_SIZE) { + callPtr->chain = (struct MInvoke *) ckrealloc((char *) callPtr->chain, + sizeof(struct MInvoke) * (callPtr->numChain + 1)); + } + callPtr->chain[i].mPtr = mPtr; + callPtr->chain[i].isFilter = (doneFilters != NULL); + callPtr->chain[i].filterDeclarer = filterDecl; + callPtr->numChain++; +} + +/* + * ---------------------------------------------------------------------- + * + * InitCallChain -- + * Encoding of the policy of how to set up a call chain. Doesn't populate + * the chain with the method implementation data. + * + * ---------------------------------------------------------------------- + */ + +static inline void +InitCallChain( + CallChain *callPtr, + Object *oPtr, + int flags) +{ + if (oPtr->flags & USE_CLASS_CACHE) { + oPtr = oPtr->selfCls->thisPtr; + } + callPtr->epoch = oPtr->fPtr->epoch; + callPtr->objectCreationEpoch = oPtr->creationEpoch; + callPtr->objectEpoch = oPtr->epoch; + callPtr->flags = flags & + (PUBLIC_METHOD | PRIVATE_METHOD | SPECIAL | FILTER_HANDLING); + callPtr->refCount = 1; + callPtr->numChain = 0; + callPtr->chain = callPtr->staticChain; +} + +/* + * ---------------------------------------------------------------------- + * + * IsStillValid -- + * Calculates whether the given call chain can be used for executing a + * method for the given object. The condition on a chain from a cached + * location being reusable is: + * - Refers to the same object (same creation epoch), and + * - Still across the same class structure (same global epoch), and + * - Still across the same object strucutre (same local epoch), and + * - No public/private/filter magic leakage (same flags, modulo the fact + * that a public chain will satisfy a non-public call). + * + * ---------------------------------------------------------------------- + */ + +static inline int +IsStillValid( + CallChain *callPtr, + Object *oPtr, + int flags, + int mask) +{ + if ((oPtr->flags & USE_CLASS_CACHE)) { + register Object *coPtr = oPtr->selfCls->thisPtr; + + return ((callPtr->objectCreationEpoch == coPtr->creationEpoch) + && (callPtr->epoch == coPtr->fPtr->epoch) + && (callPtr->objectEpoch == coPtr->epoch) + && ((callPtr->flags & mask) == (flags & mask))); + } + return ((callPtr->objectCreationEpoch == oPtr->creationEpoch) + && (callPtr->epoch == oPtr->fPtr->epoch) + && (callPtr->objectEpoch == oPtr->epoch) + && ((callPtr->flags & mask) == (flags & mask))); +} + +/* + * ---------------------------------------------------------------------- + * + * 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( + 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 PUBLIC_METHOD, CONSTRUCTOR, + * PRIVATE_METHOD, DESTRUCTOR and + * FILTER_HANDLING are useful. */ +{ + CallContext *contextPtr; + CallChain *callPtr; + struct ChainBuilder cb; + int i, count, doFilters; + Tcl_HashEntry *hPtr; + Tcl_HashTable doneFilters; + + if (flags&(SPECIAL|FILTER_HANDLING) || (oPtr->flags&FILTER_HANDLING)) { + hPtr = NULL; + doFilters = 0; + + /* + * Check if we have a cached valid constructor or destructor. + */ + + if (flags & CONSTRUCTOR) { + callPtr = oPtr->selfCls->constructorChainPtr; + if ((callPtr != NULL) + && (callPtr->objectEpoch == oPtr->selfCls->thisPtr->epoch) + && (callPtr->epoch == oPtr->fPtr->epoch)) { + callPtr->refCount++; + goto returnContext; + } + } else if (flags & DESTRUCTOR) { + callPtr = oPtr->selfCls->destructorChainPtr; + if ((oPtr->mixins.num == 0) && (callPtr != NULL) + && (callPtr->objectEpoch == oPtr->selfCls->thisPtr->epoch) + && (callPtr->epoch == oPtr->fPtr->epoch)) { + callPtr->refCount++; + goto returnContext; + } + } + } else { + /* + * Check if we can get the chain out of the Tcl_Obj method name or out + * of the cache. This is made a bit more complex by the fact that + * there are multiple different layers of cache (in the Tcl_Obj, in + * the object, and in the class). + */ + + const int reuseMask = ((flags & PUBLIC_METHOD) ? ~0 : ~PUBLIC_METHOD); + + if (methodNameObj->typePtr == &methodNameType) { + callPtr = methodNameObj->internalRep.otherValuePtr; + if (IsStillValid(callPtr, oPtr, flags, reuseMask)) { + callPtr->refCount++; + goto returnContext; + } + methodNameObj->typePtr->freeIntRepProc(methodNameObj); + } + + if (oPtr->flags & USE_CLASS_CACHE) { + if (oPtr->selfCls->classChainCache != NULL) { + hPtr = Tcl_FindHashEntry(oPtr->selfCls->classChainCache, + (char *) methodNameObj); + } else { + hPtr = NULL; + } + } else { + if (oPtr->chainCache != NULL) { + hPtr = Tcl_FindHashEntry(oPtr->chainCache, + (char *) methodNameObj); + } else { + hPtr = NULL; + } + } + + if (hPtr != NULL && Tcl_GetHashValue(hPtr) != NULL) { + callPtr = Tcl_GetHashValue(hPtr); + if (IsStillValid(callPtr, oPtr, flags, reuseMask)) { + callPtr->refCount++; + goto returnContext; + } + Tcl_SetHashValue(hPtr, NULL); + TclOODeleteChain(callPtr); + } + + doFilters = 1; + } + + callPtr = (CallChain *) ckalloc(sizeof(CallChain)); + InitCallChain(callPtr, oPtr, flags); + + cb.callChainPtr = callPtr; + cb.filterLength = 0; + cb.oPtr = oPtr; + + /* + * 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, &cb, &doneFilters); + } + FOREACH(filterObj, oPtr->filters) { + AddSimpleChainToCallContext(oPtr, filterObj, &cb, &doneFilters, 0, + NULL); + } + AddClassFiltersToCallContext(oPtr, oPtr->selfCls, &cb, &doneFilters); + Tcl_DeleteHashTable(&doneFilters); + } + count = cb.filterLength = callPtr->numChain; + + /* + * Add the actual method implementations. + */ + + AddSimpleChainToCallContext(oPtr, methodNameObj, &cb, NULL, flags, NULL); + + /* + * 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 == callPtr->numChain) { + /* + * Method does not actually exist. If we're dealing with constructors + * or destructors, this isn't a problem. + */ + + if (flags & SPECIAL) { + TclOODeleteChain(callPtr); + return NULL; + } + AddSimpleChainToCallContext(oPtr, oPtr->fPtr->unknownMethodNameObj, + &cb, NULL, 0, NULL); + callPtr->flags |= OO_UNKNOWN_METHOD; + callPtr->epoch = -1; + if (count == callPtr->numChain) { + TclOODeleteChain(callPtr); + return NULL; + } + } else if (doFilters) { + if (hPtr == NULL) { + if (oPtr->flags & USE_CLASS_CACHE) { + if (oPtr->selfCls->classChainCache == NULL) { + oPtr->selfCls->classChainCache = (Tcl_HashTable *) + ckalloc(sizeof(Tcl_HashTable)); + + Tcl_InitObjHashTable(oPtr->selfCls->classChainCache); + } + hPtr = Tcl_CreateHashEntry(oPtr->selfCls->classChainCache, + (char *) methodNameObj, &i); + } else { + if (oPtr->chainCache == NULL) { + oPtr->chainCache = (Tcl_HashTable *) + ckalloc(sizeof(Tcl_HashTable)); + + Tcl_InitObjHashTable(oPtr->chainCache); + } + hPtr = Tcl_CreateHashEntry(oPtr->chainCache, + (char *) methodNameObj, &i); + } + } + callPtr->refCount++; + Tcl_SetHashValue(hPtr, callPtr); + StashCallChain(methodNameObj, callPtr); + } else if (flags & CONSTRUCTOR) { + if (oPtr->selfCls->constructorChainPtr) { + TclOODeleteChain(oPtr->selfCls->constructorChainPtr); + } + oPtr->selfCls->constructorChainPtr = callPtr; + callPtr->refCount++; + } else if ((flags & DESTRUCTOR) && oPtr->mixins.num == 0) { + if (oPtr->selfCls->destructorChainPtr) { + TclOODeleteChain(oPtr->selfCls->destructorChainPtr); + } + oPtr->selfCls->destructorChainPtr = callPtr; + callPtr->refCount++; + } + + returnContext: + contextPtr = TclStackAlloc(oPtr->fPtr->interp, sizeof(CallContext)); + contextPtr->oPtr = oPtr; + contextPtr->callPtr = callPtr; + contextPtr->skip = 2; + contextPtr->index = 0; + 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. */ + struct ChainBuilder *const cbPtr, + /* 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, *mixinPtr; + Tcl_Obj *filterObj; + + tailRecurse: + if (clsPtr == NULL) { + return; + } + + /* + * Add all the filters defined by classes mixed into the main class + * hierarchy. + */ + + FOREACH(mixinPtr, clsPtr->mixins) { + AddClassFiltersToCallContext(oPtr, mixinPtr, cbPtr, doneFilters); + } + + /* + * 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, cbPtr, doneFilters, + 0, clsPtr); + } + } + + /* + * 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, cbPtr, doneFilters); + } + case 0: + return; + } +} + +/* + * ---------------------------------------------------------------------- + * + * 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. */ + struct ChainBuilder *const cbPtr, + /* 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. */ + Class *const filterDecl) /* The class that declared the filter. If + * NULL, either the filter was declared by the + * object or this isn't a filter. */ +{ + int i; + Class *superPtr; + + /* + * 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, cbPtr, doneFilters, + filterDecl); + + } else if (flags & DESTRUCTOR) { + AddMethodToCallChain(classPtr->destructorPtr, cbPtr, doneFilters, + filterDecl); + } 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_PROTECTED; + } + } + AddMethodToCallChain(mPtr, cbPtr, doneFilters, filterDecl); + } + } + + FOREACH(superPtr, classPtr->mixins) { + AddSimpleClassChainToCallContext(superPtr, methodNameObj, cbPtr, + doneFilters, flags, filterDecl); + } + + switch (classPtr->superclasses.num) { + case 1: + classPtr = classPtr->superclasses.list[0]; + goto tailRecurse; + default: + FOREACH(superPtr, classPtr->superclasses) { + AddSimpleClassChainToCallContext(superPtr, methodNameObj, cbPtr, + doneFilters, flags, filterDecl); + } + case 0: + return; + } +} + +/* + * Local Variables: + * mode: c + * c-basic-offset: 4 + * fill-column: 78 + * End: + */ diff --git a/generic/tclOODecls.h b/generic/tclOODecls.h new file mode 100644 index 0000000..d67333b --- /dev/null +++ b/generic/tclOODecls.h @@ -0,0 +1,282 @@ +/* + * $Id: tclOODecls.h,v 1.1 2008/05/31 11:42:18 dkf Exp $ + * + * This file is (mostly) automatically generated from tclOO.decls. + */ + + +#if defined(USE_TCLOO_STUBS) +extern const char *TclOOInitializeStubs( + Tcl_Interp *, const char *version, int epoch, int revision); +#define Tcl_OOInitStubs(interp) TclOOInitializeStubs( \ + interp, TCLOO_VERSION, TCLOO_STUBS_EPOCH, TCLOO_STUBS_REVISION) +#else +#define Tcl_OOInitStubs(interp) Tcl_PkgRequire(interp, "TclOO", TCLOO_VERSION) +#endif + + +/* !BEGIN!: Do not edit below this line. */ + +#define TCLOO_STUBS_EPOCH 0 +#define TCLOO_STUBS_REVISION 44 + +#if !defined(USE_TCLOO_STUBS) + +/* + * Exported function declarations: + */ + +/* 0 */ +TCLOOAPI Tcl_Object Tcl_CopyObjectInstance (Tcl_Interp * interp, + Tcl_Object sourceObject, + const char * targetName, + const char * targetNamespaceName); +/* 1 */ +TCLOOAPI Tcl_Object Tcl_GetClassAsObject (Tcl_Class clazz); +/* 2 */ +TCLOOAPI Tcl_Class Tcl_GetObjectAsClass (Tcl_Object object); +/* 3 */ +TCLOOAPI Tcl_Command Tcl_GetObjectCommand (Tcl_Object object); +/* 4 */ +TCLOOAPI Tcl_Object Tcl_GetObjectFromObj (Tcl_Interp * interp, + Tcl_Obj * objPtr); +/* 5 */ +TCLOOAPI Tcl_Namespace * Tcl_GetObjectNamespace (Tcl_Object object); +/* 6 */ +TCLOOAPI Tcl_Class Tcl_MethodDeclarerClass (Tcl_Method method); +/* 7 */ +TCLOOAPI Tcl_Object Tcl_MethodDeclarerObject (Tcl_Method method); +/* 8 */ +TCLOOAPI int Tcl_MethodIsPublic (Tcl_Method method); +/* 9 */ +TCLOOAPI int Tcl_MethodIsType (Tcl_Method method, + const Tcl_MethodType * typePtr, + ClientData * clientDataPtr); +/* 10 */ +TCLOOAPI Tcl_Obj * Tcl_MethodName (Tcl_Method method); +/* 11 */ +TCLOOAPI Tcl_Method Tcl_NewInstanceMethod (Tcl_Interp * interp, + Tcl_Object object, Tcl_Obj * nameObj, + int isPublic, const Tcl_MethodType * typePtr, + ClientData clientData); +/* 12 */ +TCLOOAPI Tcl_Method Tcl_NewMethod (Tcl_Interp * interp, Tcl_Class cls, + Tcl_Obj * nameObj, int isPublic, + const Tcl_MethodType * typePtr, + ClientData clientData); +/* 13 */ +TCLOOAPI Tcl_Object Tcl_NewObjectInstance (Tcl_Interp * interp, + Tcl_Class cls, const char * nameStr, + const char * nsNameStr, int objc, + Tcl_Obj *const * objv, int skip); +/* 14 */ +TCLOOAPI int Tcl_ObjectDeleted (Tcl_Object object); +/* 15 */ +TCLOOAPI int Tcl_ObjectContextIsFiltering ( + Tcl_ObjectContext context); +/* 16 */ +TCLOOAPI Tcl_Method Tcl_ObjectContextMethod (Tcl_ObjectContext context); +/* 17 */ +TCLOOAPI Tcl_Object Tcl_ObjectContextObject (Tcl_ObjectContext context); +/* 18 */ +TCLOOAPI int Tcl_ObjectContextSkippedArgs ( + Tcl_ObjectContext context); +/* 19 */ +TCLOOAPI ClientData Tcl_ClassGetMetadata (Tcl_Class clazz, + const Tcl_ObjectMetadataType * typePtr); +/* 20 */ +TCLOOAPI void Tcl_ClassSetMetadata (Tcl_Class clazz, + const Tcl_ObjectMetadataType * typePtr, + ClientData metadata); +/* 21 */ +TCLOOAPI ClientData Tcl_ObjectGetMetadata (Tcl_Object object, + const Tcl_ObjectMetadataType * typePtr); +/* 22 */ +TCLOOAPI void Tcl_ObjectSetMetadata (Tcl_Object object, + const Tcl_ObjectMetadataType * typePtr, + ClientData metadata); +/* 23 */ +TCLOOAPI int Tcl_ObjectContextInvokeNext (Tcl_Interp * interp, + Tcl_ObjectContext context, int objc, + Tcl_Obj *const * objv, int skip); +/* 24 */ +TCLOOAPI Tcl_ObjectMapMethodNameProc Tcl_ObjectGetMethodNameMapper ( + Tcl_Object object); +/* 25 */ +TCLOOAPI void Tcl_ObjectSetMethodNameMapper (Tcl_Object object, + Tcl_ObjectMapMethodNameProc mapMethodNameProc); +/* 26 */ +TCLOOAPI void Tcl_ClassSetConstructor (Tcl_Interp * interp, + Tcl_Class clazz, Tcl_Method method); +/* 27 */ +TCLOOAPI void Tcl_ClassSetDestructor (Tcl_Interp * interp, + Tcl_Class clazz, Tcl_Method method); + +#endif /* !defined(USE_TCLOO_STUBS) */ + +typedef struct TclOOStubs { + int magic; + int epoch; + int revision; + struct TclOOStubHooks *hooks; + + Tcl_Object (*tcl_CopyObjectInstance) (Tcl_Interp * interp, Tcl_Object sourceObject, const char * targetName, const char * targetNamespaceName); /* 0 */ + Tcl_Object (*tcl_GetClassAsObject) (Tcl_Class clazz); /* 1 */ + Tcl_Class (*tcl_GetObjectAsClass) (Tcl_Object object); /* 2 */ + Tcl_Command (*tcl_GetObjectCommand) (Tcl_Object object); /* 3 */ + Tcl_Object (*tcl_GetObjectFromObj) (Tcl_Interp * interp, Tcl_Obj * objPtr); /* 4 */ + Tcl_Namespace * (*tcl_GetObjectNamespace) (Tcl_Object object); /* 5 */ + Tcl_Class (*tcl_MethodDeclarerClass) (Tcl_Method method); /* 6 */ + Tcl_Object (*tcl_MethodDeclarerObject) (Tcl_Method method); /* 7 */ + int (*tcl_MethodIsPublic) (Tcl_Method method); /* 8 */ + int (*tcl_MethodIsType) (Tcl_Method method, const Tcl_MethodType * typePtr, ClientData * clientDataPtr); /* 9 */ + Tcl_Obj * (*tcl_MethodName) (Tcl_Method method); /* 10 */ + Tcl_Method (*tcl_NewInstanceMethod) (Tcl_Interp * interp, Tcl_Object object, Tcl_Obj * nameObj, int isPublic, const Tcl_MethodType * typePtr, ClientData clientData); /* 11 */ + Tcl_Method (*tcl_NewMethod) (Tcl_Interp * interp, Tcl_Class cls, Tcl_Obj * nameObj, int isPublic, const Tcl_MethodType * typePtr, ClientData clientData); /* 12 */ + Tcl_Object (*tcl_NewObjectInstance) (Tcl_Interp * interp, Tcl_Class cls, const char * nameStr, const char * nsNameStr, int objc, Tcl_Obj *const * objv, int skip); /* 13 */ + int (*tcl_ObjectDeleted) (Tcl_Object object); /* 14 */ + int (*tcl_ObjectContextIsFiltering) (Tcl_ObjectContext context); /* 15 */ + Tcl_Method (*tcl_ObjectContextMethod) (Tcl_ObjectContext context); /* 16 */ + Tcl_Object (*tcl_ObjectContextObject) (Tcl_ObjectContext context); /* 17 */ + int (*tcl_ObjectContextSkippedArgs) (Tcl_ObjectContext context); /* 18 */ + ClientData (*tcl_ClassGetMetadata) (Tcl_Class clazz, const Tcl_ObjectMetadataType * typePtr); /* 19 */ + void (*tcl_ClassSetMetadata) (Tcl_Class clazz, const Tcl_ObjectMetadataType * typePtr, ClientData metadata); /* 20 */ + ClientData (*tcl_ObjectGetMetadata) (Tcl_Object object, const Tcl_ObjectMetadataType * typePtr); /* 21 */ + void (*tcl_ObjectSetMetadata) (Tcl_Object object, const Tcl_ObjectMetadataType * typePtr, ClientData metadata); /* 22 */ + int (*tcl_ObjectContextInvokeNext) (Tcl_Interp * interp, Tcl_ObjectContext context, int objc, Tcl_Obj *const * objv, int skip); /* 23 */ + Tcl_ObjectMapMethodNameProc (*tcl_ObjectGetMethodNameMapper) (Tcl_Object object); /* 24 */ + void (*tcl_ObjectSetMethodNameMapper) (Tcl_Object object, Tcl_ObjectMapMethodNameProc mapMethodNameProc); /* 25 */ + void (*tcl_ClassSetConstructor) (Tcl_Interp * interp, Tcl_Class clazz, Tcl_Method method); /* 26 */ + void (*tcl_ClassSetDestructor) (Tcl_Interp * interp, Tcl_Class clazz, Tcl_Method method); /* 27 */ +} TclOOStubs; + +#ifdef __cplusplus +extern "C" { +#endif +extern const TclOOStubs *tclOOStubsPtr; +#ifdef __cplusplus +} +#endif + +#if defined(USE_TCLOO_STUBS) + +/* + * Inline function declarations: + */ + +#ifndef Tcl_CopyObjectInstance +#define Tcl_CopyObjectInstance \ + (tclOOStubsPtr->tcl_CopyObjectInstance) /* 0 */ +#endif +#ifndef Tcl_GetClassAsObject +#define Tcl_GetClassAsObject \ + (tclOOStubsPtr->tcl_GetClassAsObject) /* 1 */ +#endif +#ifndef Tcl_GetObjectAsClass +#define Tcl_GetObjectAsClass \ + (tclOOStubsPtr->tcl_GetObjectAsClass) /* 2 */ +#endif +#ifndef Tcl_GetObjectCommand +#define Tcl_GetObjectCommand \ + (tclOOStubsPtr->tcl_GetObjectCommand) /* 3 */ +#endif +#ifndef Tcl_GetObjectFromObj +#define Tcl_GetObjectFromObj \ + (tclOOStubsPtr->tcl_GetObjectFromObj) /* 4 */ +#endif +#ifndef Tcl_GetObjectNamespace +#define Tcl_GetObjectNamespace \ + (tclOOStubsPtr->tcl_GetObjectNamespace) /* 5 */ +#endif +#ifndef Tcl_MethodDeclarerClass +#define Tcl_MethodDeclarerClass \ + (tclOOStubsPtr->tcl_MethodDeclarerClass) /* 6 */ +#endif +#ifndef Tcl_MethodDeclarerObject +#define Tcl_MethodDeclarerObject \ + (tclOOStubsPtr->tcl_MethodDeclarerObject) /* 7 */ +#endif +#ifndef Tcl_MethodIsPublic +#define Tcl_MethodIsPublic \ + (tclOOStubsPtr->tcl_MethodIsPublic) /* 8 */ +#endif +#ifndef Tcl_MethodIsType +#define Tcl_MethodIsType \ + (tclOOStubsPtr->tcl_MethodIsType) /* 9 */ +#endif +#ifndef Tcl_MethodName +#define Tcl_MethodName \ + (tclOOStubsPtr->tcl_MethodName) /* 10 */ +#endif +#ifndef Tcl_NewInstanceMethod +#define Tcl_NewInstanceMethod \ + (tclOOStubsPtr->tcl_NewInstanceMethod) /* 11 */ +#endif +#ifndef Tcl_NewMethod +#define Tcl_NewMethod \ + (tclOOStubsPtr->tcl_NewMethod) /* 12 */ +#endif +#ifndef Tcl_NewObjectInstance +#define Tcl_NewObjectInstance \ + (tclOOStubsPtr->tcl_NewObjectInstance) /* 13 */ +#endif +#ifndef Tcl_ObjectDeleted +#define Tcl_ObjectDeleted \ + (tclOOStubsPtr->tcl_ObjectDeleted) /* 14 */ +#endif +#ifndef Tcl_ObjectContextIsFiltering +#define Tcl_ObjectContextIsFiltering \ + (tclOOStubsPtr->tcl_ObjectContextIsFiltering) /* 15 */ +#endif +#ifndef Tcl_ObjectContextMethod +#define Tcl_ObjectContextMethod \ + (tclOOStubsPtr->tcl_ObjectContextMethod) /* 16 */ +#endif +#ifndef Tcl_ObjectContextObject +#define Tcl_ObjectContextObject \ + (tclOOStubsPtr->tcl_ObjectContextObject) /* 17 */ +#endif +#ifndef Tcl_ObjectContextSkippedArgs +#define Tcl_ObjectContextSkippedArgs \ + (tclOOStubsPtr->tcl_ObjectContextSkippedArgs) /* 18 */ +#endif +#ifndef Tcl_ClassGetMetadata +#define Tcl_ClassGetMetadata \ + (tclOOStubsPtr->tcl_ClassGetMetadata) /* 19 */ +#endif +#ifndef Tcl_ClassSetMetadata +#define Tcl_ClassSetMetadata \ + (tclOOStubsPtr->tcl_ClassSetMetadata) /* 20 */ +#endif +#ifndef Tcl_ObjectGetMetadata +#define Tcl_ObjectGetMetadata \ + (tclOOStubsPtr->tcl_ObjectGetMetadata) /* 21 */ +#endif +#ifndef Tcl_ObjectSetMetadata +#define Tcl_ObjectSetMetadata \ + (tclOOStubsPtr->tcl_ObjectSetMetadata) /* 22 */ +#endif +#ifndef Tcl_ObjectContextInvokeNext +#define Tcl_ObjectContextInvokeNext \ + (tclOOStubsPtr->tcl_ObjectContextInvokeNext) /* 23 */ +#endif +#ifndef Tcl_ObjectGetMethodNameMapper +#define Tcl_ObjectGetMethodNameMapper \ + (tclOOStubsPtr->tcl_ObjectGetMethodNameMapper) /* 24 */ +#endif +#ifndef Tcl_ObjectSetMethodNameMapper +#define Tcl_ObjectSetMethodNameMapper \ + (tclOOStubsPtr->tcl_ObjectSetMethodNameMapper) /* 25 */ +#endif +#ifndef Tcl_ClassSetConstructor +#define Tcl_ClassSetConstructor \ + (tclOOStubsPtr->tcl_ClassSetConstructor) /* 26 */ +#endif +#ifndef Tcl_ClassSetDestructor +#define Tcl_ClassSetDestructor \ + (tclOOStubsPtr->tcl_ClassSetDestructor) /* 27 */ +#endif + +#endif /* defined(USE_TCLOO_STUBS) */ + +/* !END!: Do not edit above this line. */ diff --git a/generic/tclOODefineCmds.c b/generic/tclOODefineCmds.c new file mode 100644 index 0000000..77f9970 --- /dev/null +++ b/generic/tclOODefineCmds.c @@ -0,0 +1,1831 @@ +/* + * 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-2008 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.4 2008/05/31 11:42:18 dkf Exp $ + */ + +#ifdef HAVE_CONFIG_H +#include "config.h" +#endif +#include "tclInt.h" +#include "tclOOInt.h" + +/* + * Forward declarations. + */ + +static inline void BumpGlobalEpoch(Tcl_Interp *interp, Class *classPtr); +static Tcl_Command FindCommand(Tcl_Interp *interp, Tcl_Obj *stringObj, + Tcl_Namespace *const namespacePtr); +static inline int InitDefineContext(Tcl_Interp *interp, + Tcl_Namespace *namespacePtr, Object *oPtr, + int objc, Tcl_Obj *const objv[]); +static inline void RecomputeClassCacheFlag(Object *oPtr); +static int RenameDeleteMethod(Tcl_Interp *interp, Object *oPtr, + int useClass, Tcl_Obj *const fromPtr, + Tcl_Obj *const toPtr); + +/* + * ---------------------------------------------------------------------- + * + * BumpGlobalEpoch -- + * Utility that ensures that call chains that are invalid will get thrown + * away at an appropriate time. Note that exactly which epoch gets + * advanced will depend on exactly what the class is tangled up in; in + * the worst case, the simplest option is to advance the global epoch, + * causing *everything* to be thrown away on next usage. + * + * ---------------------------------------------------------------------- + */ + +static inline void +BumpGlobalEpoch( + Tcl_Interp *interp, + Class *classPtr) +{ + if (classPtr != NULL + && classPtr->subclasses.num == 0 + && classPtr->instances.num == 0 + && classPtr->mixinSubs.num == 0) { + /* + * If a class has no subclasses or instances, and is not mixed into + * anything, a change to its structure does not require us to + * invalidate any call chains. Note that we still bump our object's + * epoch if it has any mixins; the relation between a class and its + * representative object is special. But it won't hurt. + */ + + if (classPtr->thisPtr->mixins.num > 0) { + classPtr->thisPtr->epoch++; + } + return; + } + + /* + * Either there's no class (?!) or we're reconfiguring something that is + * in use. Force regeneration of call chains. + */ + + TclOOGetFoundation(interp)->epoch++; +} + +/* + * ---------------------------------------------------------------------- + * + * RecomputeClassCacheFlag -- + * Determine whether the object is prototypical of its class, and hence + * able to use the class's method chain cache. + * + * ---------------------------------------------------------------------- + */ + +static inline void +RecomputeClassCacheFlag( + Object *oPtr) +{ + if ((oPtr->methodsPtr == NULL || oPtr->methodsPtr->numEntries == 0) + && (oPtr->mixins.num == 0) && (oPtr->filters.num == 0)) { + oPtr->flags |= USE_CLASS_CACHE; + } else { + oPtr->flags &= ~USE_CLASS_CACHE; + } +} + +/* + * ---------------------------------------------------------------------- + * + * TclOOObjectSetFilters -- + * Install a list of filter method names into an object. + * + * ---------------------------------------------------------------------- + */ + +void +TclOOObjectSetFilters( + Object *oPtr, + int numFilters, + Tcl_Obj *const *filters) +{ + int i; + + if (oPtr->filters.num) { + Tcl_Obj *filterObj; + + FOREACH(filterObj, oPtr->filters) { + Tcl_DecrRefCount(filterObj); + } + } + + if (numFilters == 0) { + /* + * No list of filters was supplied, so we're deleting filters. + */ + + ckfree((char *) oPtr->filters.list); + oPtr->filters.list = NULL; + oPtr->filters.num = 0; + RecomputeClassCacheFlag(oPtr); + } else { + /* + * We've got a list of filters, so we're creating filters. + */ + + Tcl_Obj **filtersList; + int size = sizeof(Tcl_Obj *) * numFilters; /* should be size_t */ + + if (oPtr->filters.num == 0) { + filtersList = (Tcl_Obj **) ckalloc(size); + } else { + filtersList = (Tcl_Obj **) + ckrealloc((char *) oPtr->filters.list, size); + } + for (i=0 ; i<numFilters ; i++) { + filtersList[i] = filters[i]; + Tcl_IncrRefCount(filters[i]); + } + oPtr->filters.list = filtersList; + oPtr->filters.num = numFilters; + oPtr->flags &= ~USE_CLASS_CACHE; + } + oPtr->epoch++; /* Only this object can be affected. */ +} + +/* + * ---------------------------------------------------------------------- + * + * TclOOClassSetFilters -- + * Install a list of filter method names into a class. + * + * ---------------------------------------------------------------------- + */ + +void +TclOOClassSetFilters( + Tcl_Interp *interp, + Class *classPtr, + int numFilters, + Tcl_Obj *const *filters) +{ + int i; + + if (classPtr->filters.num) { + Tcl_Obj *filterObj; + + FOREACH(filterObj, classPtr->filters) { + Tcl_DecrRefCount(filterObj); + } + } + + if (numFilters == 0) { + /* + * No list of filters was supplied, so we're deleting filters. + */ + + ckfree((char *) classPtr->filters.list); + classPtr->filters.list = NULL; + classPtr->filters.num = 0; + } else { + /* + * We've got a list of filters, so we're creating filters. + */ + + Tcl_Obj **filtersList; + int size = sizeof(Tcl_Obj *) * numFilters; /* should be size_t */ + + if (classPtr->filters.num == 0) { + filtersList = (Tcl_Obj **) ckalloc(size); + } else { + filtersList = (Tcl_Obj **) + ckrealloc((char *) classPtr->filters.list, size); + } + for (i=0 ; i<numFilters ; i++) { + filtersList[i] = filters[i]; + Tcl_IncrRefCount(filters[i]); + } + classPtr->filters.list = filtersList; + classPtr->filters.num = numFilters; + } + + /* + * There may be many objects affected, so bump the global epoch. + */ + + BumpGlobalEpoch(interp, classPtr); +} + +/* + * ---------------------------------------------------------------------- + * + * TclOOObjectSetMixins -- + * Install a list of mixin classes into an object. + * + * ---------------------------------------------------------------------- + */ + +void +TclOOObjectSetMixins( + Object *oPtr, + int numMixins, + Class *const *mixins) +{ + Class *mixinPtr; + int i; + + if (numMixins == 0) { + if (oPtr->mixins.num != 0) { + FOREACH(mixinPtr, oPtr->mixins) { + TclOORemoveFromInstances(oPtr, mixinPtr); + } + ckfree((char *) oPtr->mixins.list); + oPtr->mixins.num = 0; + } + RecomputeClassCacheFlag(oPtr); + } else { + if (oPtr->mixins.num != 0) { + FOREACH(mixinPtr, oPtr->mixins) { + if (mixinPtr != oPtr->selfCls) { + TclOORemoveFromInstances(oPtr, mixinPtr); + } + } + oPtr->mixins.list = (Class **) + ckrealloc((char *) oPtr->mixins.list, + sizeof(Class *) * numMixins); + } else { + oPtr->mixins.list = (Class **) + ckalloc(sizeof(Class *) * numMixins); + oPtr->flags &= ~USE_CLASS_CACHE; + } + oPtr->mixins.num = numMixins; + memcpy(oPtr->mixins.list, mixins, sizeof(Class *) * numMixins); + FOREACH(mixinPtr, oPtr->mixins) { + if (mixinPtr != oPtr->selfCls) { + TclOOAddToInstances(oPtr, mixinPtr); + } + } + } + oPtr->epoch++; +} + +/* + * ---------------------------------------------------------------------- + * + * TclOOClassSetMixins -- + * Install a list of mixin classes into a class. + * + * ---------------------------------------------------------------------- + */ + +void +TclOOClassSetMixins( + Tcl_Interp *interp, + Class *classPtr, + int numMixins, + Class *const *mixins) +{ + Class *mixinPtr; + int i; + + if (numMixins == 0) { + if (classPtr->mixins.num != 0) { + FOREACH(mixinPtr, classPtr->mixins) { + TclOORemoveFromMixinSubs(classPtr, mixinPtr); + } + ckfree((char *) classPtr->mixins.list); + classPtr->mixins.num = 0; + } + } else { + if (classPtr->mixins.num != 0) { + FOREACH(mixinPtr, classPtr->mixins) { + TclOORemoveFromMixinSubs(classPtr, mixinPtr); + } + classPtr->mixins.list = (Class **) + ckrealloc((char *) classPtr->mixins.list, + sizeof(Class *) * numMixins); + } else { + classPtr->mixins.list = (Class **) + ckalloc(sizeof(Class *) * numMixins); + } + classPtr->mixins.num = numMixins; + memcpy(classPtr->mixins.list, mixins, sizeof(Class *) * numMixins); + FOREACH(mixinPtr, classPtr->mixins) { + TclOOAddToMixinSubs(classPtr, mixinPtr); + } + } + BumpGlobalEpoch(interp, classPtr); +} + +/* + * ---------------------------------------------------------------------- + * + * RenameDeleteMethod -- + * Core of the code to rename and delete methods. + * + * ---------------------------------------------------------------------- + */ + +static int +RenameDeleteMethod( + Tcl_Interp *interp, + Object *oPtr, + int useClass, + Tcl_Obj *const fromPtr, + Tcl_Obj *const toPtr) +{ + Tcl_HashEntry *hPtr, *newHPtr = NULL; + Method *mPtr; + int isNew; + + if (!useClass) { + if (!oPtr->methodsPtr) { + noSuchMethod: + Tcl_AppendResult(interp, "method ", TclGetString(fromPtr), + " does not exist", NULL); + return TCL_ERROR; + } + hPtr = Tcl_FindHashEntry(oPtr->methodsPtr, (char *) fromPtr); + if (hPtr == NULL) { + goto noSuchMethod; + } + if (toPtr) { + newHPtr = Tcl_CreateHashEntry(oPtr->methodsPtr, (char *) toPtr, + &isNew); + if (hPtr == newHPtr) { + renameToSelf: + Tcl_AppendResult(interp, "cannot rename method to itself", + NULL); + return TCL_ERROR; + } else if (!isNew) { + renameToExisting: + Tcl_AppendResult(interp, "method called ", + TclGetString(toPtr), " already exists", NULL); + return TCL_ERROR; + } + } + } else { + hPtr = Tcl_FindHashEntry(&oPtr->classPtr->classMethods, + (char *) fromPtr); + if (hPtr == NULL) { + goto noSuchMethod; + } + if (toPtr) { + newHPtr = Tcl_CreateHashEntry(&oPtr->classPtr->classMethods, + (char *) toPtr, &isNew); + if (hPtr == newHPtr) { + goto renameToSelf; + } else if (!isNew) { + goto renameToExisting; + } + } + } + + /* + * Complete the splicing by changing the method's name. + */ + + mPtr = Tcl_GetHashValue(hPtr); + if (toPtr) { + Tcl_IncrRefCount(toPtr); + Tcl_DecrRefCount(mPtr->namePtr); + mPtr->namePtr = toPtr; + Tcl_SetHashValue(newHPtr, mPtr); + } else { + if (!useClass) { + RecomputeClassCacheFlag(oPtr); + } + TclOODelMethodRef(mPtr); + } + Tcl_DeleteHashEntry(hPtr); + return TCL_OK; +} + +/* + * ---------------------------------------------------------------------- + * + * TclOOUnknownDefinition -- + * Handles what happens when an unknown command is encountered during the + * processing of a definition script. Works by finding a command in the + * operating definition namespace that the requested command is a unique + * prefix of. + * + * ---------------------------------------------------------------------- + */ + +int +TclOOUnknownDefinition( + ClientData clientData, + Tcl_Interp *interp, + int objc, + Tcl_Obj *const *objv) +{ + Namespace *nsPtr = (Namespace *) Tcl_GetCurrentNamespace(interp); + Tcl_HashSearch search; + Tcl_HashEntry *hPtr; + int soughtLen; + const char *soughtStr, *matchedStr = NULL; + + if (objc < 2) { + Tcl_AppendResult(interp, "bad call of unknown handler", NULL); + return TCL_ERROR; + } + if (TclOOGetDefineCmdContext(interp) == NULL) { + return TCL_ERROR; + } + + soughtStr = Tcl_GetStringFromObj(objv[1], &soughtLen); + if (soughtLen == 0) { + goto noMatch; + } + hPtr = Tcl_FirstHashEntry(&nsPtr->cmdTable, &search); + while (hPtr != NULL) { + const char *nameStr = Tcl_GetHashKey(&nsPtr->cmdTable, hPtr); + + if (strncmp(soughtStr, nameStr, soughtLen) == 0) { + if (matchedStr != NULL) { + goto noMatch; + } + matchedStr = nameStr; + } + hPtr = Tcl_NextHashEntry(&search); + } + + if (matchedStr != NULL) { + /* + * Got one match, and only one match! + */ + + Tcl_Obj **newObjv = TclStackAlloc(interp, sizeof(Tcl_Obj*)*(objc-1)); + int result; + + newObjv[0] = Tcl_NewStringObj(matchedStr, -1); + Tcl_IncrRefCount(newObjv[0]); + if (objc > 2) { + memcpy(newObjv+1, objv+2, sizeof(Tcl_Obj *) * (objc-2)); + } + result = Tcl_EvalObjv(interp, objc-1, newObjv, 0); + Tcl_DecrRefCount(newObjv[0]); + TclStackFree(interp, newObjv); + return result; + } + + noMatch: + Tcl_AppendResult(interp, "invalid command name \"",soughtStr,"\"", NULL); + return TCL_ERROR; +} + +/* + * ---------------------------------------------------------------------- + * + * FindCommand -- + * Specialized version of Tcl_FindCommand that handles command prefixes + * and disallows namespace magic. + * + * ---------------------------------------------------------------------- + */ + +static Tcl_Command +FindCommand( + Tcl_Interp *interp, + Tcl_Obj *stringObj, + Tcl_Namespace *const namespacePtr) +{ + int length; + const char *nameStr, *string = Tcl_GetStringFromObj(stringObj, &length); + register Namespace *const nsPtr = (Namespace *) namespacePtr; + FOREACH_HASH_DECLS; + Tcl_Command cmd, cmd2; + + /* + * If someone is playing games, we stop playing right now. + */ + + if (string[0] == '\0' || strstr(string, "::") != NULL) { + return NULL; + } + + /* + * Do the exact lookup first. + */ + + cmd = Tcl_FindCommand(interp, string, namespacePtr, TCL_NAMESPACE_ONLY); + if (cmd != NULL) { + return cmd; + } + + /* + * Bother, need to perform an approximate match. Iterate across the hash + * table of commands in the namespace. + */ + + FOREACH_HASH(nameStr, cmd2, &nsPtr->cmdTable) { + if (strncmp(string, nameStr, length) == 0) { + if (cmd != NULL) { + return NULL; + } + cmd = cmd2; + } + } + + /* + * Either we found one thing or we found nothing. Either way, return it. + */ + + return cmd; +} + +/* + * ---------------------------------------------------------------------- + * + * InitDefineContext -- + * Does the magic incantations necessary to push the special stack frame + * used when processing object definitions. It is up to the caller to + * dispose of the frame (with TclPopStackFrame) when finished. + * + * ---------------------------------------------------------------------- + */ + +static inline int +InitDefineContext( + Tcl_Interp *interp, + Tcl_Namespace *namespacePtr, + Object *oPtr, + int objc, + Tcl_Obj *const objv[]) +{ + CallFrame *framePtr, **framePtrPtr = &framePtr; + int result; + + /* framePtrPtr is needed to satisfy GCC 3.3's strict aliasing rules */ + + result = TclPushStackFrame(interp, (Tcl_CallFrame **) framePtrPtr, + namespacePtr, FRAME_IS_OO_DEFINE); + if (result != TCL_OK) { + return TCL_ERROR; + } + framePtr->clientData = oPtr; + framePtr->objc = objc; + framePtr->objv = objv; /* Reference counts do not need to be + * incremented here. */ + return TCL_OK; +} + +/* + * ---------------------------------------------------------------------- + * + * TclOOGetDefineCmdContext -- + * Extracts the magic token from the current stack frame, or returns NULL + * (and leaves an error message) otherwise. + * + * ---------------------------------------------------------------------- + */ + +Tcl_Object +TclOOGetDefineCmdContext( + 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 an ::oo::define or ::oo::objdefine command", + NULL); + return NULL; + } + return (Tcl_Object) iPtr->framePtr->clientData; +} + +/* + * ---------------------------------------------------------------------- + * + * TclOODefineObjCmd -- + * Implementation of the "oo::define" command. Works by effectively doing + * the same as 'namespace eval', but with extra magic applied so that the + * object to be modified is known to the commands in the target + * namespace. Also does ensemble-like tricks with dispatch so that error + * messages are clearer. + * + * ---------------------------------------------------------------------- + */ + +int +TclOODefineObjCmd( + ClientData clientData, + Tcl_Interp *interp, + int objc, + Tcl_Obj *const *objv) +{ + Foundation *fPtr = TclOOGetFoundation(interp); + int result; + Object *oPtr; + + if (objc < 3) { + Tcl_WrongNumArgs(interp, 1, objv, "className arg ?arg ...?"); + return TCL_ERROR; + } + + oPtr = (Object *) Tcl_GetObjectFromObj(interp, objv[1]); + if (oPtr == NULL) { + return TCL_ERROR; + } + if (oPtr->classPtr == NULL) { + Tcl_AppendResult(interp, TclGetString(objv[1]), + " does not refer to a class", NULL); + return TCL_ERROR; + } + + /* + * Make the oo::define namespace the current namespace and evaluate the + * command(s). + */ + + if (InitDefineContext(interp, fPtr->defineNs, oPtr, objc,objv) != TCL_OK){ + return TCL_ERROR; + } + + AddRef(oPtr); + if (objc == 3) { + result = TclEvalObjEx(interp, objv[2], 0, + ((Interp *)interp)->cmdFramePtr, 2); + + if (result == TCL_ERROR) { + int length; + const char *objName = Tcl_GetStringFromObj(objv[1], &length); + int limit = 60; + int overflow = (length > limit); + + Tcl_AppendObjToErrorInfo(interp, Tcl_ObjPrintf( + "\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. + */ + + objPtr = Tcl_NewObj(); + obj2Ptr = Tcl_NewObj(); + cmd = FindCommand(interp, objv[2], fPtr->defineNs); + 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); + Tcl_DecrRefCount(objPtr); + } + DelRef(oPtr); + + /* + * Restore the previous "current" namespace. + */ + + TclPopStackFrame(interp); + return result; +} + +/* + * ---------------------------------------------------------------------- + * + * TclOOObjDefObjCmd -- + * Implementation of the "oo::objdefine" command. Works by effectively + * doing the same as 'namespace eval', but with extra magic applied so + * that the object to be modified is known to the commands in the target + * namespace. Also does ensemble-like tricks with dispatch so that error + * messages are clearer. + * + * ---------------------------------------------------------------------- + */ + +int +TclOOObjDefObjCmd( + ClientData clientData, + Tcl_Interp *interp, + int objc, + Tcl_Obj *const *objv) +{ + Foundation *fPtr = TclOOGetFoundation(interp); + 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::objdefine namespace the current namespace and evaluate the + * command(s). + */ + + if (InitDefineContext(interp, fPtr->objdefNs, oPtr, objc,objv) != TCL_OK){ + return TCL_ERROR; + } + + AddRef(oPtr); + if (objc == 3) { + result = TclEvalObjEx(interp, objv[2], 0, + ((Interp *)interp)->cmdFramePtr, 2); + + if (result == TCL_ERROR) { + int length; + const char *objName = Tcl_GetStringFromObj(objv[1], &length); + int limit = 60; + int overflow = (length > limit); + + Tcl_AppendObjToErrorInfo(interp, Tcl_ObjPrintf( + "\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. + */ + + objPtr = Tcl_NewObj(); + obj2Ptr = Tcl_NewObj(); + cmd = FindCommand(interp, objv[2], fPtr->objdefNs); + 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); + Tcl_DecrRefCount(objPtr); + } + DelRef(oPtr); + + /* + * Restore the previous "current" namespace. + */ + + TclPopStackFrame(interp); + return result; +} + +/* + * ---------------------------------------------------------------------- + * + * TclOODefineSelfObjCmd -- + * Implementation of the "self" subcommand of the "oo::define" command. + * Works by effectively doing the same as 'namespace eval', but with + * extra magic applied so that the object to be modified is known to the + * commands in the target namespace. Also does ensemble-like tricks with + * dispatch so that error messages are clearer. + * + * ---------------------------------------------------------------------- + */ + +int +TclOODefineSelfObjCmd( + ClientData clientData, + Tcl_Interp *interp, + int objc, + Tcl_Obj *const *objv) +{ + Foundation *fPtr = TclOOGetFoundation(interp); + int result; + Object *oPtr; + + if (objc < 2) { + Tcl_WrongNumArgs(interp, 1, objv, "arg ?arg ...?"); + return TCL_ERROR; + } + + oPtr = (Object *) TclOOGetDefineCmdContext(interp); + if (oPtr == NULL) { + return TCL_ERROR; + } + + /* + * Make the oo::objdefine namespace the current namespace and evaluate the + * command(s). + */ + + if (InitDefineContext(interp, fPtr->objdefNs, oPtr, objc,objv) != TCL_OK){ + return TCL_ERROR; + } + + AddRef(oPtr); + if (objc == 2) { + result = TclEvalObjEx(interp, objv[1], 0, + ((Interp *)interp)->cmdFramePtr, 2); + + if (result == TCL_ERROR) { + int length; + const char *objName = Tcl_GetStringFromObj( + TclOOObjectName(interp, oPtr), &length); + int limit = 60; + int overflow = (length > limit); + + Tcl_AppendObjToErrorInfo(interp, Tcl_ObjPrintf( + "\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 = 2; + iPtr->ensembleRewrite.numInsertedObjs = 1; + } else { + int ni = iPtr->ensembleRewrite.numInsertedObjs; + if (ni < 2) { + iPtr->ensembleRewrite.numRemovedObjs += 2 - ni; + } else { + iPtr->ensembleRewrite.numInsertedObjs -= 1; + } + } + + /* + * Build the list of arguments using a Tcl_Obj as a workspace. See + * comments above for why these contortions are necessary. + */ + + objPtr = Tcl_NewObj(); + obj2Ptr = Tcl_NewObj(); + cmd = FindCommand(interp, objv[1], fPtr->objdefNs); + if (cmd == NULL) { + /* punt this case! */ + Tcl_AppendObjToObj(obj2Ptr, objv[1]); + } else { + Tcl_GetCommandFullName(interp, cmd, obj2Ptr); + } + Tcl_ListObjAppendElement(NULL, objPtr, obj2Ptr); + Tcl_ListObjReplace(NULL, objPtr, 1, 0, objc-2, objv+2); + Tcl_ListObjGetElements(NULL, objPtr, &dummy, &objs); + + result = Tcl_EvalObjv(interp, objc-1, objs, TCL_EVAL_INVOKE); + Tcl_DecrRefCount(objPtr); + } + DelRef(oPtr); + + /* + * Restore the previous "current" namespace. + */ + + TclPopStackFrame(interp); + return result; +} + +/* + * ---------------------------------------------------------------------- + * + * TclOODefineClassObjCmd -- + * Implementation of the "class" subcommand of the "oo::objdefine" + * command. + * + * ---------------------------------------------------------------------- + */ + +int +TclOODefineClassObjCmd( + ClientData clientData, + Tcl_Interp *interp, + int objc, + Tcl_Obj *const *objv) +{ + Object *oPtr, *o2Ptr; + Foundation *fPtr = TclOOGetFoundation(interp); + + /* + * Parse the context to get the object to operate on. + */ + + oPtr = (Object *) TclOOGetDefineCmdContext(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) { + BumpGlobalEpoch(interp, oPtr->classPtr); + } else { + oPtr->epoch++; + } + } + return TCL_OK; +} + +/* + * ---------------------------------------------------------------------- + * + * TclOODefineConstructorObjCmd -- + * Implementation of the "constructor" subcommand of the "oo::define" + * command. + * + * ---------------------------------------------------------------------- + */ + +int +TclOODefineConstructorObjCmd( + ClientData clientData, + Tcl_Interp *interp, + int objc, + Tcl_Obj *const *objv) +{ + Object *oPtr; + Class *clsPtr; + Tcl_Method method; + 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 = (Object *) TclOOGetDefineCmdContext(interp); + if (oPtr == NULL) { + return TCL_ERROR; + } + clsPtr = oPtr->classPtr; + + Tcl_GetStringFromObj(objv[2], &bodyLength); + if (bodyLength > 0) { + /* + * Create the method structure. + */ + + method = (Tcl_Method) TclOONewProcMethod(interp, clsPtr, + PUBLIC_METHOD, NULL, objv[1], objv[2], NULL); + if (method == NULL) { + return TCL_ERROR; + } + } else { + /* + * Delete the constructor method record and set the field in the + * class record to NULL. + */ + + method = NULL; + } + + /* + * 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. + */ + + Tcl_ClassSetConstructor(interp, (Tcl_Class) clsPtr, method); + return TCL_OK; +} + +/* + * ---------------------------------------------------------------------- + * + * TclOODefineDeleteMethodObjCmd -- + * Implementation of the "deletemethod" subcommand of the "oo::define" + * and "oo::objdefine" commands. + * + * ---------------------------------------------------------------------- + */ + +int +TclOODefineDeleteMethodObjCmd( + ClientData clientData, + Tcl_Interp *interp, + int objc, + Tcl_Obj *const *objv) +{ + int isInstanceDeleteMethod = (clientData != NULL); + Object *oPtr; + int i; + + if (objc < 2) { + Tcl_WrongNumArgs(interp, 1, objv, "name ?name ...?"); + return TCL_ERROR; + } + + oPtr = (Object *) TclOOGetDefineCmdContext(interp); + if (oPtr == NULL) { + return TCL_ERROR; + } + if (!isInstanceDeleteMethod && !oPtr->classPtr) { + Tcl_AppendResult(interp, "attempt to misuse API", NULL); + return TCL_ERROR; + } + + for (i=1 ; i<objc ; i++) { + /* + * Delete the method structure from the appropriate hash table. + */ + + if (RenameDeleteMethod(interp, oPtr, !isInstanceDeleteMethod, + objv[i], NULL) != TCL_OK) { + return TCL_ERROR; + } + } + + if (isInstanceDeleteMethod) { + oPtr->epoch++; + } else { + BumpGlobalEpoch(interp, oPtr->classPtr); + } + return TCL_OK; +} + +/* + * ---------------------------------------------------------------------- + * + * TclOODefineDestructorObjCmd -- + * Implementation of the "destructor" subcommand of the "oo::define" + * command. + * + * ---------------------------------------------------------------------- + */ + +int +TclOODefineDestructorObjCmd( + ClientData clientData, + Tcl_Interp *interp, + int objc, + Tcl_Obj *const *objv) +{ + Object *oPtr; + Class *clsPtr; + Tcl_Method method; + int bodyLength; + + if (objc != 2) { + Tcl_WrongNumArgs(interp, 1, objv, "body"); + return TCL_ERROR; + } + + oPtr = (Object *) TclOOGetDefineCmdContext(interp); + if (oPtr == NULL) { + return TCL_ERROR; + } + clsPtr = oPtr->classPtr; + + Tcl_GetStringFromObj(objv[1], &bodyLength); + if (bodyLength > 0) { + /* + * Create the method structure. + */ + + method = (Tcl_Method) TclOONewProcMethod(interp, clsPtr, + PUBLIC_METHOD, NULL, NULL, objv[1], NULL); + if (method == NULL) { + return TCL_ERROR; + } + } else { + /* + * Delete the destructor method record and set the field in the class + * record to NULL. + */ + + method = NULL; + } + + /* + * 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. Also note that setting a + * destructor during a destructor is fairly dumb anyway. + */ + + Tcl_ClassSetDestructor(interp, (Tcl_Class) clsPtr, method); + return TCL_OK; +} + +/* + * ---------------------------------------------------------------------- + * + * TclOODefineExportObjCmd -- + * Implementation of the "export" subcommand of the "oo::define" and + * "oo::objdefine" commands. + * + * ---------------------------------------------------------------------- + */ + +int +TclOODefineExportObjCmd( + ClientData clientData, + Tcl_Interp *interp, + int objc, + Tcl_Obj *const *objv) +{ + int isInstanceExport = (clientData != NULL); + Object *oPtr; + Method *mPtr; + Tcl_HashEntry *hPtr; + Class *clsPtr; + int i, isNew, changed = 0; + + if (objc < 2) { + Tcl_WrongNumArgs(interp, 1, objv, "name ?name ...?"); + return TCL_ERROR; + } + + oPtr = (Object *) TclOOGetDefineCmdContext(interp); + if (oPtr == NULL) { + return TCL_ERROR; + } + clsPtr = oPtr->classPtr; + if (!isInstanceExport && !clsPtr) { + Tcl_AppendResult(interp, "attempt to misuse API", NULL); + return TCL_ERROR; + } + + for (i=1 ; i<objc ; i++) { + /* + * Exporting is done by adding the PUBLIC_METHOD flag to the method + * record. If there is no such method in this object or class (i.e. + * the method comes from something inherited from or that we're an + * instance of) then we put in a blank record with that flag; such + * records are skipped over by the call chain engine *except* for + * their flags member. + */ + + if (isInstanceExport) { + if (!oPtr->methodsPtr) { + oPtr->methodsPtr = (Tcl_HashTable *) + ckalloc(sizeof(Tcl_HashTable)); + Tcl_InitObjHashTable(oPtr->methodsPtr); + oPtr->flags &= ~USE_CLASS_CACHE; + } + hPtr = Tcl_CreateHashEntry(oPtr->methodsPtr, (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); + } + if (isNew || !(mPtr->flags & PUBLIC_METHOD)) { + mPtr->flags |= PUBLIC_METHOD; + changed = 1; + } + } + + /* + * Bump the right epoch if we actually changed anything. + */ + + if (changed) { + if (isInstanceExport) { + oPtr->epoch++; + } else { + BumpGlobalEpoch(interp, clsPtr); + } + } + return TCL_OK; +} + +/* + * ---------------------------------------------------------------------- + * + * TclOODefineFilterObjCmd -- + * Implementation of the "filter" subcommand of the "oo::define" and + * "oo::objdefine" commands. + * + * ---------------------------------------------------------------------- + */ + +int +TclOODefineFilterObjCmd( + ClientData clientData, + Tcl_Interp *interp, + int objc, + Tcl_Obj *const *objv) +{ + int isInstanceFilter = (clientData != NULL); + Object *oPtr = (Object *) TclOOGetDefineCmdContext(interp); + + if (oPtr == NULL) { + return TCL_ERROR; + } + if (!isInstanceFilter && !oPtr->classPtr) { + Tcl_AppendResult(interp, "attempt to misuse API", NULL); + return TCL_ERROR; + } + + if (!isInstanceFilter) { + TclOOClassSetFilters(interp, oPtr->classPtr, objc-1, objv+1); + } else { + TclOOObjectSetFilters(oPtr, objc-1, objv+1); + } + return TCL_OK; +} + +/* + * ---------------------------------------------------------------------- + * + * TclOODefineForwardObjCmd -- + * Implementation of the "forward" subcommand of the "oo::define" and + * "oo::objdefine" commands. + * + * ---------------------------------------------------------------------- + */ + +int +TclOODefineForwardObjCmd( + ClientData clientData, + Tcl_Interp *interp, + int objc, + Tcl_Obj *const *objv) +{ + int isInstanceForward = (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 = (Object *) TclOOGetDefineCmdContext(interp); + if (oPtr == NULL) { + return TCL_ERROR; + } + if (!isInstanceForward && !oPtr->classPtr) { + Tcl_AppendResult(interp, "attempt to misuse API", NULL); + return TCL_ERROR; + } + isPublic = Tcl_StringMatch(TclGetString(objv[1]), "[a-z]*") + ? PUBLIC_METHOD : 0; + + /* + * Create the method structure. + */ + + prefixObj = Tcl_NewListObj(objc-2, objv+2); + if (isInstanceForward) { + mPtr = TclOONewForwardInstanceMethod(interp, oPtr, isPublic, objv[1], + prefixObj); + } else { + mPtr = TclOONewForwardMethod(interp, oPtr->classPtr, isPublic, + objv[1], prefixObj); + } + if (mPtr == NULL) { + Tcl_DecrRefCount(prefixObj); + return TCL_ERROR; + } + return TCL_OK; +} + +/* + * ---------------------------------------------------------------------- + * + * TclOODefineMethodObjCmd -- + * Implementation of the "method" subcommand of the "oo::define" and + * "oo::objdefine" commands. + * + * ---------------------------------------------------------------------- + */ + +int +TclOODefineMethodObjCmd( + ClientData clientData, + Tcl_Interp *interp, + int objc, + Tcl_Obj *const *objv) +{ + int isInstanceMethod = (clientData != NULL); + Object *oPtr; + int isPublic; + + if (objc != 4) { + Tcl_WrongNumArgs(interp, 1, objv, "name args body"); + return TCL_ERROR; + } + + oPtr = (Object *) TclOOGetDefineCmdContext(interp); + if (oPtr == NULL) { + return TCL_ERROR; + } + if (!isInstanceMethod && !oPtr->classPtr) { + Tcl_AppendResult(interp, "attempt to misuse API", NULL); + return TCL_ERROR; + } + isPublic = Tcl_StringMatch(TclGetString(objv[1]), "[a-z]*") + ? PUBLIC_METHOD : 0; + + /* + * Create the method by using the right back-end API. + */ + + if (isInstanceMethod) { + if (TclOONewProcInstanceMethod(interp, oPtr, isPublic, objv[1], + objv[2], objv[3], NULL) == NULL) { + return TCL_ERROR; + } + } else { + if (TclOONewProcMethod(interp, oPtr->classPtr, isPublic, objv[1], + objv[2], objv[3], NULL) == NULL) { + return TCL_ERROR; + } + } + return TCL_OK; +} + +/* + * ---------------------------------------------------------------------- + * + * TclOODefineMixinObjCmd -- + * Implementation of the "mixin" subcommand of the "oo::define" and + * "oo::objdefine" commands. + * + * ---------------------------------------------------------------------- + */ + +int +TclOODefineMixinObjCmd( + ClientData clientData, + Tcl_Interp *interp, + const int objc, + Tcl_Obj *const *objv) +{ + int isInstanceMixin = (clientData != NULL); + Object *oPtr = (Object *) TclOOGetDefineCmdContext(interp); + Class **mixins; + int i; + + if (oPtr == NULL) { + return TCL_ERROR; + } + if (!isInstanceMixin && !oPtr->classPtr) { + Tcl_AppendResult(interp, "attempt to misuse API", NULL); + return TCL_ERROR; + } + mixins = TclStackAlloc(interp, sizeof(Class *) * (objc-1)); + + for (i=1 ; i<objc ; i++) { + Object *o2Ptr; + + o2Ptr = (Object *) Tcl_GetObjectFromObj(interp, objv[i]); + if (o2Ptr == NULL) { + goto freeAndError; + } + if (o2Ptr->classPtr == NULL) { + Tcl_AppendResult(interp, "may only mix in classes; \"", + TclGetString(objv[i]), "\" is not a class", NULL); + goto freeAndError; + } + if (!isInstanceMixin && + TclOOIsReachable(oPtr->classPtr,o2Ptr->classPtr)){ + Tcl_AppendResult(interp, "may not mix a class into itself", NULL); + goto freeAndError; + } + mixins[i-1] = o2Ptr->classPtr; + } + + if (isInstanceMixin) { + TclOOObjectSetMixins(oPtr, objc-1, mixins); + } else { + TclOOClassSetMixins(interp, oPtr->classPtr, objc-1, mixins); + } + + TclStackFree(interp, mixins); + return TCL_OK; + + freeAndError: + TclStackFree(interp, mixins); + return TCL_ERROR; +} + +/* + * ---------------------------------------------------------------------- + * + * TclOODefineRenameMethodObjCmd -- + * Implementation of the "renamemethod" subcommand of the "oo::define" + * and "oo::objdefine" commands. + * + * ---------------------------------------------------------------------- + */ + +int +TclOODefineRenameMethodObjCmd( + ClientData clientData, + Tcl_Interp *interp, + int objc, + Tcl_Obj *const *objv) +{ + int isInstanceRenameMethod = (clientData != NULL); + Object *oPtr; + + if (objc != 3) { + Tcl_WrongNumArgs(interp, 1, objv, "oldName newName"); + return TCL_ERROR; + } + + oPtr = (Object *) TclOOGetDefineCmdContext(interp); + if (oPtr == NULL) { + return TCL_ERROR; + } + if (!isInstanceRenameMethod && !oPtr->classPtr) { + Tcl_AppendResult(interp, "attempt to misuse API", NULL); + return TCL_ERROR; + } + + /* + * Delete the method entry from the appropriate hash table, and transfer + * the thing it points to to its new entry. To do this, we first need to + * get the entries from the appropriate hash tables (this can generate a + * range of errors...) + */ + + if (RenameDeleteMethod(interp, oPtr, !isInstanceRenameMethod, + objv[1], objv[2]) != TCL_OK) { + return TCL_ERROR; + } + + if (isInstanceRenameMethod) { + oPtr->epoch++; + } else { + BumpGlobalEpoch(interp, oPtr->classPtr); + } + return TCL_OK; +} + +/* + * ---------------------------------------------------------------------- + * + * TclOODefineSuperclassObjCmd -- + * Implementation of the "superclass" subcommand of the "oo::define" + * command. + * + * ---------------------------------------------------------------------- + */ + +int +TclOODefineSuperclassObjCmd( + ClientData clientData, + Tcl_Interp *interp, + int objc, + Tcl_Obj *const *objv) +{ + Object *oPtr, *o2Ptr; + Foundation *fPtr = TclOOGetFoundation(interp); + 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 = (Object *) TclOOGetDefineCmdContext(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); + } + BumpGlobalEpoch(interp, oPtr->classPtr); + + return TCL_OK; +} + +/* + * ---------------------------------------------------------------------- + * + * TclOODefineUnexportObjCmd -- + * Implementation of the "unexport" subcommand of the "oo::define" and + * "oo::objdefine" commands. + * + * ---------------------------------------------------------------------- + */ + +int +TclOODefineUnexportObjCmd( + ClientData clientData, + Tcl_Interp *interp, + int objc, + Tcl_Obj *const *objv) +{ + int isInstanceUnexport = (clientData != NULL); + Object *oPtr; + Method *mPtr; + Tcl_HashEntry *hPtr; + Class *clsPtr; + int i, isNew, changed = 0; + + if (objc < 2) { + Tcl_WrongNumArgs(interp, 1, objv, "name ?name ...?"); + return TCL_ERROR; + } + + oPtr = (Object *) TclOOGetDefineCmdContext(interp); + if (oPtr == NULL) { + return TCL_ERROR; + } + clsPtr = oPtr->classPtr; + if (!isInstanceUnexport && !clsPtr) { + Tcl_AppendResult(interp, "attempt to misuse API", NULL); + return TCL_ERROR; + } + + for (i=1 ; i<objc ; i++) { + /* + * Unexporting is done by removing the PUBLIC_METHOD flag from the + * method record. If there is no such method in this object or class + * (i.e. the method comes from something inherited from or that we're + * an instance of) then we put in a blank record without that flag; + * such records are skipped over by the call chain engine *except* for + * their flags member. + */ + + if (isInstanceUnexport) { + if (!oPtr->methodsPtr) { + oPtr->methodsPtr = (Tcl_HashTable *) + ckalloc(sizeof(Tcl_HashTable)); + Tcl_InitObjHashTable(oPtr->methodsPtr); + oPtr->flags &= ~USE_CLASS_CACHE; + } + hPtr = Tcl_CreateHashEntry(oPtr->methodsPtr, (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); + } + if (isNew || mPtr->flags & PUBLIC_METHOD) { + mPtr->flags &= ~PUBLIC_METHOD; + changed = 1; + } + } + + /* + * Bump the right epoch if we actually changed anything. + */ + + if (changed) { + if (isInstanceUnexport) { + oPtr->epoch++; + } else { + BumpGlobalEpoch(interp, clsPtr); + } + } + return TCL_OK; +} + +void +Tcl_ClassSetConstructor( + Tcl_Interp *interp, + Tcl_Class clazz, + Tcl_Method method) +{ + Class *clsPtr = (Class *) clazz; + + if (method != (Tcl_Method) clsPtr->constructorPtr) { + TclOODelMethodRef(clsPtr->constructorPtr); + clsPtr->constructorPtr = (Method *) method; + BumpGlobalEpoch(interp, clsPtr); + } +} + +void +Tcl_ClassSetDestructor( + Tcl_Interp *interp, + Tcl_Class clazz, + Tcl_Method method) +{ + Class *clsPtr = (Class *) clazz; + + if (method != (Tcl_Method) clsPtr->destructorPtr) { + TclOODelMethodRef(clsPtr->destructorPtr); + clsPtr->destructorPtr = (Method *) method; + BumpGlobalEpoch(interp, clsPtr); + } +} + +/* + * 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..bded40c --- /dev/null +++ b/generic/tclOOInfo.c @@ -0,0 +1,1271 @@ +/* + * tclOODefineCmds.c -- + * + * This file contains the implementation of the ::oo-related [info] + * subcommands. + * + * Copyright (c) 2006-2008 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.4 2008/05/31 11:42:18 dkf Exp $ + */ + +#ifdef HAVE_CONFIG_H +#include "config.h" +#endif +#include "tclInt.h" +#include "tclOOInt.h" + +static Tcl_ObjCmdProc InfoObjectClassCmd; +static Tcl_ObjCmdProc InfoObjectDefnCmd; +static Tcl_ObjCmdProc InfoObjectFiltersCmd; +static Tcl_ObjCmdProc InfoObjectForwardCmd; +static Tcl_ObjCmdProc InfoObjectIsACmd; +static Tcl_ObjCmdProc InfoObjectMethodsCmd; +static Tcl_ObjCmdProc InfoObjectMixinsCmd; +static Tcl_ObjCmdProc InfoObjectVarsCmd; +static Tcl_ObjCmdProc InfoClassConstrCmd; +static Tcl_ObjCmdProc InfoClassDefnCmd; +static Tcl_ObjCmdProc InfoClassDestrCmd; +static Tcl_ObjCmdProc InfoClassFiltersCmd; +static Tcl_ObjCmdProc InfoClassForwardCmd; +static Tcl_ObjCmdProc InfoClassInstancesCmd; +static Tcl_ObjCmdProc InfoClassMethodsCmd; +static Tcl_ObjCmdProc InfoClassMixinsCmd; +static Tcl_ObjCmdProc InfoClassSubsCmd; +static Tcl_ObjCmdProc InfoClassSupersCmd; + +struct NameProcMap { const char *name; Tcl_ObjCmdProc *proc; }; + +/* + * List of commands that are used to implement the [info object] subcommands. + */ + +static const struct NameProcMap infoObjectCmds[] = { + {"::oo::InfoObject::class", InfoObjectClassCmd}, + {"::oo::InfoObject::definition", InfoObjectDefnCmd}, + {"::oo::InfoObject::filters", InfoObjectFiltersCmd}, + {"::oo::InfoObject::forward", InfoObjectForwardCmd}, + {"::oo::InfoObject::isa", InfoObjectIsACmd}, + {"::oo::InfoObject::methods", InfoObjectMethodsCmd}, + {"::oo::InfoObject::mixins", InfoObjectMixinsCmd}, + {"::oo::InfoObject::vars", InfoObjectVarsCmd}, + {NULL, NULL} +}; + +/* + * List of commands that are used to implement the [info class] subcommands. + */ + +static const struct NameProcMap infoClassCmds[] = { + {"::oo::InfoClass::constructor", InfoClassConstrCmd}, + {"::oo::InfoClass::definition", InfoClassDefnCmd}, + {"::oo::InfoClass::destructor", InfoClassDestrCmd}, + {"::oo::InfoClass::filters", InfoClassFiltersCmd}, + {"::oo::InfoClass::forward", InfoClassForwardCmd}, + {"::oo::InfoClass::instances", InfoClassInstancesCmd}, + {"::oo::InfoClass::methods", InfoClassMethodsCmd}, + {"::oo::InfoClass::mixins", InfoClassMixinsCmd}, + {"::oo::InfoClass::subclasses", InfoClassSubsCmd}, + {"::oo::InfoClass::superclasses", InfoClassSupersCmd}, + {NULL, NULL} +}; + +/* + * ---------------------------------------------------------------------- + * + * TclOOInitInfo -- + * + * Adjusts the Tcl core [info] command to contain subcommands ("object" + * and "class") for introspection of objects and classes. + * + * ---------------------------------------------------------------------- + */ + +void +TclOOInitInfo( + Tcl_Interp *interp) +{ + Tcl_Namespace *nsPtr; + Tcl_Command infoCmd; + int i; + + /* + * Build the ensemble used to implement [info object]. + */ + + nsPtr = Tcl_CreateNamespace(interp, "::oo::InfoObject", NULL, NULL); + Tcl_CreateEnsemble(interp, nsPtr->fullName, nsPtr, TCL_ENSEMBLE_PREFIX); + Tcl_Export(interp, nsPtr, "[a-z]*", 1); + for (i=0 ; infoObjectCmds[i].name!=NULL ; i++) { + Tcl_CreateObjCommand(interp, infoObjectCmds[i].name, + infoObjectCmds[i].proc, NULL, NULL); + } + + /* + * Build the ensemble used to implement [info class]. + */ + + nsPtr = Tcl_CreateNamespace(interp, "::oo::InfoClass", NULL, NULL); + Tcl_CreateEnsemble(interp, nsPtr->fullName, nsPtr, TCL_ENSEMBLE_PREFIX); + Tcl_Export(interp, nsPtr, "[a-z]*", 1); + for (i=0 ; infoClassCmds[i].name!=NULL ; i++) { + Tcl_CreateObjCommand(interp, infoClassCmds[i].name, + infoClassCmds[i].proc, NULL, NULL); + } + + /* + * Install into the master [info] ensemble. + */ + + infoCmd = Tcl_FindCommand(interp, "info", NULL, TCL_GLOBAL_ONLY); + if (infoCmd != NULL && Tcl_IsEnsemble(infoCmd)) { + Tcl_Obj *mapDict, *objectObj, *classObj; + + Tcl_GetEnsembleMappingDict(NULL, infoCmd, &mapDict); + if (mapDict != NULL) { + objectObj = Tcl_NewStringObj("object", -1); + classObj = Tcl_NewStringObj("class", -1); + + Tcl_IncrRefCount(objectObj); + Tcl_IncrRefCount(classObj); + Tcl_DictObjPut(NULL, mapDict, objectObj, + Tcl_NewStringObj("::oo::InfoObject", -1)); + Tcl_DictObjPut(NULL, mapDict, classObj, + Tcl_NewStringObj("::oo::InfoClass", -1)); + Tcl_DecrRefCount(objectObj); + Tcl_DecrRefCount(classObj); + Tcl_SetEnsembleMappingDict(interp, infoCmd, mapDict); + } + } +} + +/* + * ---------------------------------------------------------------------- + * + * InfoObjectClassCmd -- + * + * Implements [info object class $objName ?$className?] + * + * ---------------------------------------------------------------------- + */ + +static int +InfoObjectClassCmd( + ClientData clientData, + Tcl_Interp *interp, + int objc, + Tcl_Obj *const objv[]) +{ + Object *oPtr; + + if (objc != 2 && objc != 3) { + Tcl_WrongNumArgs(interp, 1, objv, "objName ?className?"); + return TCL_ERROR; + } + + oPtr = (Object *) Tcl_GetObjectFromObj(interp, objv[1]); + if (oPtr == NULL) { + return TCL_ERROR; + } + + if (objc == 2) { + Tcl_SetObjResult(interp, + TclOOObjectName(interp, oPtr->selfCls->thisPtr)); + return TCL_OK; + } else { + Object *o2Ptr; + Class *mixinPtr; + int i; + + o2Ptr = (Object *) Tcl_GetObjectFromObj(interp, objv[2]); + if (o2Ptr == NULL) { + return TCL_ERROR; + } + if (o2Ptr->classPtr == NULL) { + Tcl_AppendResult(interp, "object \"", TclGetString(objv[2]), + "\" 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; + } +} + +/* + * ---------------------------------------------------------------------- + * + * InfoObjectDefnCmd -- + * + * Implements [info object definition $objName $methodName] + * + * ---------------------------------------------------------------------- + */ + +static int +InfoObjectDefnCmd( + ClientData clientData, + Tcl_Interp *interp, + int objc, + Tcl_Obj *const objv[]) +{ + Object *oPtr; + Tcl_HashEntry *hPtr; + Proc *procPtr; + CompiledLocal *localPtr; + Tcl_Obj *argsObj; + + if (objc != 3) { + Tcl_WrongNumArgs(interp, 3, objv, "objName methodName"); + return TCL_ERROR; + } + + oPtr = (Object *) Tcl_GetObjectFromObj(interp, objv[1]); + if (oPtr == NULL) { + return TCL_ERROR; + } + + if (!oPtr->methodsPtr) { + goto unknownMethod; + } + hPtr = Tcl_FindHashEntry(oPtr->methodsPtr, (char *) objv[2]); + if (hPtr == NULL) { + unknownMethod: + Tcl_AppendResult(interp, "unknown method \"", TclGetString(objv[2]), + "\"", 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; + } + + argsObj = Tcl_NewObj(); + for (localPtr=procPtr->firstLocalPtr; localPtr!=NULL; + localPtr=localPtr->nextPtr) { + if (TclIsVarArgument(localPtr)) { + Tcl_Obj *argObj; + + argObj = Tcl_NewObj(); + 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; +} + +/* + * ---------------------------------------------------------------------- + * + * InfoObjectFiltersCmd -- + * + * Implements [info object filters $objName] + * + * ---------------------------------------------------------------------- + */ + +static int +InfoObjectFiltersCmd( + ClientData clientData, + Tcl_Interp *interp, + int objc, + Tcl_Obj *const objv[]) +{ + int i; + Tcl_Obj *filterObj; + Object *oPtr; + + if (objc != 2) { + Tcl_WrongNumArgs(interp, 1, objv, "objName"); + return TCL_ERROR; + } + + oPtr = (Object *) Tcl_GetObjectFromObj(interp, objv[1]); + if (oPtr == NULL) { + return TCL_ERROR; + } + + FOREACH(filterObj, oPtr->filters) { + Tcl_ListObjAppendElement(NULL, Tcl_GetObjResult(interp), filterObj); + } + return TCL_OK; +} + +/* + * ---------------------------------------------------------------------- + * + * InfoObjectForwardCmd -- + * + * Implements [info object forward $objName $methodName] + * + * ---------------------------------------------------------------------- + */ + +static int +InfoObjectForwardCmd( + ClientData clientData, + Tcl_Interp *interp, + int objc, + Tcl_Obj *const objv[]) +{ + Object *oPtr; + Tcl_HashEntry *hPtr; + Tcl_Obj *prefixObj; + + if (objc != 3) { + Tcl_WrongNumArgs(interp, 1, objv, "objName methodName"); + return TCL_ERROR; + } + + oPtr = (Object *) Tcl_GetObjectFromObj(interp, objv[1]); + if (oPtr == NULL) { + return TCL_ERROR; + } + + if (!oPtr->methodsPtr) { + goto unknownMethod; + } + hPtr = Tcl_FindHashEntry(oPtr->methodsPtr, (char *) objv[2]); + if (hPtr == NULL) { + unknownMethod: + Tcl_AppendResult(interp, "unknown method \"", TclGetString(objv[2]), + "\"", 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; +} + +/* + * ---------------------------------------------------------------------- + * + * InfoObjectIsACmd -- + * + * Implements [info object isa $category $objName ...] + * + * ---------------------------------------------------------------------- + */ + +static int +InfoObjectIsACmd( + ClientData clientData, + 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 < 3) { + Tcl_WrongNumArgs(interp, 1, objv, "category objName ?arg ...?"); + return TCL_ERROR; + } + if (Tcl_GetIndexFromObj(interp, objv[1], 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 != 3) { + Tcl_WrongNumArgs(interp, 2, objv, "objName"); + return TCL_ERROR; + } + Tcl_SetObjResult(interp, Tcl_NewIntObj(oPtr->classPtr ? 1 : 0)); + return TCL_OK; + case IsMetaclass: + if (objc != 3) { + Tcl_WrongNumArgs(interp, 2, objv, "objName"); + return TCL_ERROR; + } + if (oPtr->classPtr == NULL) { + Tcl_SetObjResult(interp, Tcl_NewIntObj(0)); + } else { + Class *classCls = TclOOGetFoundation(interp)->classCls; + + Tcl_SetObjResult(interp, Tcl_NewIntObj( + TclOOIsReachable(classCls, oPtr->classPtr) ? 1 : 0)); + } + return TCL_OK; + case IsMixin: + if (objc != 4) { + Tcl_WrongNumArgs(interp, 2, objv, "objName className"); + return TCL_ERROR; + } + o2Ptr = (Object *) Tcl_GetObjectFromObj(interp, objv[3]); + 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 != 4) { + Tcl_WrongNumArgs(interp, 2, objv, "objName className"); + return TCL_ERROR; + } + o2Ptr = (Object *) Tcl_GetObjectFromObj(interp, objv[3]); + 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; +} + +/* + * ---------------------------------------------------------------------- + * + * InfoObjectMethodsCmd -- + * + * Implements [info object methods $objName ?$option ...?] + * + * ---------------------------------------------------------------------- + */ + +static int +InfoObjectMethodsCmd( + ClientData clientData, + Tcl_Interp *interp, + int objc, + Tcl_Obj *const objv[]) +{ + Object *oPtr; + int flag = PUBLIC_METHOD, recurse = 0; + FOREACH_HASH_DECLS; + Tcl_Obj *namePtr; + Method *mPtr; + static const char *options[] = { + "-all", "-localprivate", "-private", NULL + }; + enum Options { + OPT_ALL, OPT_LOCALPRIVATE, OPT_PRIVATE + }; + + if (objc < 2) { + Tcl_WrongNumArgs(interp, 1, objv, "objName ?options...?"); + return TCL_ERROR; + } + oPtr = (Object *) Tcl_GetObjectFromObj(interp, objv[1]); + if (oPtr == NULL) { + return TCL_ERROR; + } + if (objc != 2) { + int i, idx; + + for (i=2 ; i<objc ; i++) { + if (Tcl_GetIndexFromObj(interp, objv[i], options, "option", 0, + &idx) != TCL_OK) { + return TCL_ERROR; + } + switch ((enum Options) idx) { + case OPT_ALL: + recurse = 1; + break; + case OPT_LOCALPRIVATE: + flag = PRIVATE_METHOD; + break; + case OPT_PRIVATE: + flag = 0; + break; + } + } + } + + if (recurse) { + const char **names; + int i, numNames = TclOOGetSortedMethodList(oPtr, flag, &names); + Tcl_Obj *resultObj = Tcl_NewObj(); + + for (i=0 ; i<numNames ; i++) { + Tcl_ListObjAppendElement(NULL, resultObj, + Tcl_NewStringObj(names[i], -1)); + } + ckfree((char *) names); + Tcl_SetObjResult(interp, resultObj); + return TCL_OK; + } + + if (oPtr->methodsPtr) { + FOREACH_HASH(namePtr, mPtr, oPtr->methodsPtr) { + if (mPtr->typePtr != NULL && (mPtr->flags & flag) == flag) { + Tcl_ListObjAppendElement(NULL, Tcl_GetObjResult(interp), + namePtr); + } + } + } + return TCL_OK; +} + +/* + * ---------------------------------------------------------------------- + * + * InfoObjectMixinsCmd -- + * + * Implements [info object mixins $objName] + * + * ---------------------------------------------------------------------- + */ + +static int +InfoObjectMixinsCmd( + ClientData clientData, + Tcl_Interp *interp, + int objc, + Tcl_Obj *const objv[]) +{ + Class *mixinPtr; + Object *oPtr; + int i; + + if (objc != 2) { + Tcl_WrongNumArgs(interp, 3, objv, "objName"); + return TCL_ERROR; + } + oPtr = (Object *) Tcl_GetObjectFromObj(interp, objv[1]); + if (oPtr == NULL) { + return TCL_ERROR; + } + + FOREACH(mixinPtr, oPtr->mixins) { + Tcl_ListObjAppendElement(NULL, Tcl_GetObjResult(interp), + TclOOObjectName(interp, mixinPtr->thisPtr)); + } + return TCL_OK; +} + +/* + * ---------------------------------------------------------------------- + * + * InfoObjectVarsCmd -- + * + * Implements [info object vars $objName ?$pattern?] + * + * ---------------------------------------------------------------------- + */ + +static int +InfoObjectVarsCmd( + ClientData clientData, + Tcl_Interp *interp, + int objc, + Tcl_Obj *const objv[]) +{ + Object *oPtr; + const char *pattern = NULL; + FOREACH_HASH_DECLS; + VarInHash *vihPtr; + Tcl_Obj *nameObj, *resultObj; + + if (objc != 2 && objc != 3) { + Tcl_WrongNumArgs(interp, 1, objv, "objName ?pattern?"); + return TCL_ERROR; + } + oPtr = (Object *) Tcl_GetObjectFromObj(interp, objv[1]); + if (oPtr == NULL) { + return TCL_ERROR; + } + if (objc == 3) { + pattern = TclGetString(objv[2]); + } + resultObj = Tcl_NewObj(); + + /* + * Extract the information we need from the object's namespace's table of + * variables. Note that this involves horrific knowledge of the guts of + * tclVar.c, so we can't leverage our hash-iteration macros properly. + */ + + FOREACH_HASH_VALUE(vihPtr, + &((Namespace *) oPtr->namespacePtr)->varTable.table) { + nameObj = vihPtr->entry.key.objPtr; + + if (TclIsVarUndefined(&vihPtr->var) + || !TclIsVarNamespaceVar(&vihPtr->var)) { + continue; + } + if (pattern != NULL + && !Tcl_StringMatch(TclGetString(nameObj), pattern)) { + continue; + } + Tcl_ListObjAppendElement(NULL, resultObj, nameObj); + } + + Tcl_SetObjResult(interp, resultObj); + return TCL_OK; +} + +/* + * ---------------------------------------------------------------------- + * + * InfoClassConstrCmd -- + * + * Implements [info class constructor $clsName] + * + * ---------------------------------------------------------------------- + */ + +static int +InfoClassConstrCmd( + ClientData clientData, + Tcl_Interp *interp, + int objc, + Tcl_Obj *const objv[]) +{ + Proc *procPtr; + CompiledLocal *localPtr; + Tcl_Obj *argsObj; + Object *oPtr; + Class *clsPtr; + + if (objc != 2) { + Tcl_WrongNumArgs(interp, 1, objv, "className"); + return TCL_ERROR; + } + oPtr = (Object *) Tcl_GetObjectFromObj(interp, objv[1]); + if (oPtr == NULL) { + return TCL_ERROR; + } + if (oPtr->classPtr == NULL) { + Tcl_AppendResult(interp, "\"", TclGetString(objv[1]), + "\" is not a class", NULL); + return TCL_ERROR; + } + clsPtr = oPtr->classPtr; + + 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; + } + + argsObj = Tcl_NewObj(); + for (localPtr=procPtr->firstLocalPtr; localPtr!=NULL; + localPtr=localPtr->nextPtr) { + if (TclIsVarArgument(localPtr)) { + Tcl_Obj *argObj; + + argObj = Tcl_NewObj(); + 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; +} + +/* + * ---------------------------------------------------------------------- + * + * InfoClassDefnCmd -- + * + * Implements [info class definition $clsName $methodName] + * + * ---------------------------------------------------------------------- + */ + +static int +InfoClassDefnCmd( + ClientData clientData, + Tcl_Interp *interp, + int objc, + Tcl_Obj *const objv[]) +{ + Tcl_HashEntry *hPtr; + Proc *procPtr; + CompiledLocal *localPtr; + Tcl_Obj *argsObj; + Object *oPtr; + Class *clsPtr; + + if (objc != 3) { + Tcl_WrongNumArgs(interp, 1, objv, "className methodName"); + return TCL_ERROR; + } + oPtr = (Object *) Tcl_GetObjectFromObj(interp, objv[1]); + if (oPtr == NULL) { + return TCL_ERROR; + } + if (oPtr->classPtr == NULL) { + Tcl_AppendResult(interp, "\"", TclGetString(objv[1]), + "\" is not a class", NULL); + return TCL_ERROR; + } + clsPtr = oPtr->classPtr; + + hPtr = Tcl_FindHashEntry(&clsPtr->classMethods, (char *) objv[2]); + if (hPtr == NULL) { + Tcl_AppendResult(interp, "unknown method \"", TclGetString(objv[2]), + "\"", 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; + } + + argsObj = Tcl_NewObj(); + for (localPtr=procPtr->firstLocalPtr; localPtr!=NULL; + localPtr=localPtr->nextPtr) { + if (TclIsVarArgument(localPtr)) { + Tcl_Obj *argObj; + + argObj = Tcl_NewObj(); + 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; +} + +/* + * ---------------------------------------------------------------------- + * + * InfoClassDestrCmd -- + * + * Implements [info class destructor $clsName] + * + * ---------------------------------------------------------------------- + */ + +static int +InfoClassDestrCmd( + ClientData clientData, + Tcl_Interp *interp, + int objc, + Tcl_Obj *const objv[]) +{ + Proc *procPtr; + Object *oPtr; + Class *clsPtr; + + if (objc != 2) { + Tcl_WrongNumArgs(interp, 1, objv, "className"); + return TCL_ERROR; + } + oPtr = (Object *) Tcl_GetObjectFromObj(interp, objv[1]); + if (oPtr == NULL) { + return TCL_ERROR; + } + if (oPtr->classPtr == NULL) { + Tcl_AppendResult(interp, "\"", TclGetString(objv[1]), + "\" is not a class", NULL); + return TCL_ERROR; + } + clsPtr = oPtr->classPtr; + + 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; +} + +/* + * ---------------------------------------------------------------------- + * + * InfoClassFiltersCmd -- + * + * Implements [info class filters $clsName] + * + * ---------------------------------------------------------------------- + */ + +static int +InfoClassFiltersCmd( + ClientData clientData, + Tcl_Interp *interp, + int objc, + Tcl_Obj *const objv[]) +{ + int i; + Tcl_Obj *filterObj; + Object *oPtr; + Class *clsPtr; + + if (objc != 2) { + Tcl_WrongNumArgs(interp, 1, objv, "className"); + return TCL_ERROR; + } + oPtr = (Object *) Tcl_GetObjectFromObj(interp, objv[1]); + if (oPtr == NULL) { + return TCL_ERROR; + } + if (oPtr->classPtr == NULL) { + Tcl_AppendResult(interp, "\"", TclGetString(objv[1]), + "\" is not a class", NULL); + return TCL_ERROR; + } + clsPtr = oPtr->classPtr; + + FOREACH(filterObj, clsPtr->filters) { + Tcl_ListObjAppendElement(NULL, Tcl_GetObjResult(interp), filterObj); + } + return TCL_OK; +} + +/* + * ---------------------------------------------------------------------- + * + * InfoClassForwardCmd -- + * + * Implements [info class forward $clsName $methodName] + * + * ---------------------------------------------------------------------- + */ + +static int +InfoClassForwardCmd( + ClientData clientData, + Tcl_Interp *interp, + int objc, + Tcl_Obj *const objv[]) +{ + Tcl_HashEntry *hPtr; + Tcl_Obj *prefixObj; + Object *oPtr; + Class *clsPtr; + + if (objc != 3) { + Tcl_WrongNumArgs(interp, 1, objv, "className methodName"); + return TCL_ERROR; + } + oPtr = (Object *) Tcl_GetObjectFromObj(interp, objv[1]); + if (oPtr == NULL) { + return TCL_ERROR; + } + if (oPtr->classPtr == NULL) { + Tcl_AppendResult(interp, "\"", TclGetString(objv[1]), + "\" is not a class", NULL); + return TCL_ERROR; + } + clsPtr = oPtr->classPtr; + + hPtr = Tcl_FindHashEntry(&clsPtr->classMethods, (char *) objv[2]); + if (hPtr == NULL) { + Tcl_AppendResult(interp, "unknown method \"", TclGetString(objv[2]), + "\"", 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; +} + +/* + * ---------------------------------------------------------------------- + * + * InfoClassInstancesCmd -- + * + * Implements [info class instances $clsName ?$pattern?] + * + * ---------------------------------------------------------------------- + */ + +static int +InfoClassInstancesCmd( + ClientData clientData, + Tcl_Interp *interp, + int objc, + Tcl_Obj *const objv[]) +{ + Object *oPtr; + Class *clsPtr; + int i; + const char *pattern = NULL; + + if (objc != 2 && objc != 3) { + Tcl_WrongNumArgs(interp, 1, objv, "className ?pattern?"); + return TCL_ERROR; + } + oPtr = (Object *) Tcl_GetObjectFromObj(interp, objv[1]); + if (oPtr == NULL) { + return TCL_ERROR; + } + if (oPtr->classPtr == NULL) { + Tcl_AppendResult(interp, "\"", TclGetString(objv[1]), + "\" is not a class", NULL); + return TCL_ERROR; + } + clsPtr = oPtr->classPtr; + if (objc == 3) { + pattern = TclGetString(objv[2]); + } + + FOREACH(oPtr, clsPtr->instances) { + Tcl_Obj *tmpObj = TclOOObjectName(interp, oPtr); + + if (pattern && !Tcl_StringMatch(TclGetString(tmpObj), pattern)) { + continue; + } + Tcl_ListObjAppendElement(NULL, Tcl_GetObjResult(interp), tmpObj); + } + return TCL_OK; +} + +/* + * ---------------------------------------------------------------------- + * + * InfoClassMethodsCmd -- + * + * Implements [info class methods $clsName ?-private?] + * + * ---------------------------------------------------------------------- + */ + +static int +InfoClassMethodsCmd( + ClientData clientData, + Tcl_Interp *interp, + int objc, + Tcl_Obj *const objv[]) +{ + int flag = PUBLIC_METHOD, recurse = 0; + FOREACH_HASH_DECLS; + Tcl_Obj *namePtr; + Method *mPtr; + Object *oPtr; + Class *clsPtr; + static const char *options[] = { + "-all", "-localprivate", "-private", NULL + }; + enum Options { + OPT_ALL, OPT_LOCALPRIVATE, OPT_PRIVATE + }; + + if (objc < 2) { + Tcl_WrongNumArgs(interp, 1, objv, "className ?options...?"); + return TCL_ERROR; + } + oPtr = (Object *) Tcl_GetObjectFromObj(interp, objv[1]); + if (oPtr == NULL) { + return TCL_ERROR; + } + if (oPtr->classPtr == NULL) { + Tcl_AppendResult(interp, "\"", TclGetString(objv[1]), + "\" is not a class", NULL); + return TCL_ERROR; + } + clsPtr = oPtr->classPtr; + if (objc != 2) { + int i, idx; + + for (i=2 ; i<objc ; i++) { + if (Tcl_GetIndexFromObj(interp, objv[i], options, "option", 0, + &idx) != TCL_OK) { + return TCL_ERROR; + } + switch ((enum Options) idx) { + case OPT_ALL: + recurse = 1; + break; + case OPT_LOCALPRIVATE: + flag = PRIVATE_METHOD; + break; + case OPT_PRIVATE: + flag = 0; + break; + } + } + } + + if (recurse) { + const char **names; + int i, numNames = TclOOGetSortedClassMethodList(clsPtr, flag, &names); + Tcl_Obj *resultObj = Tcl_NewObj(); + + for (i=0 ; i<numNames ; i++) { + Tcl_ListObjAppendElement(NULL, resultObj, + Tcl_NewStringObj(names[i], -1)); + } + ckfree((char *) names); + Tcl_SetObjResult(interp, resultObj); + return TCL_OK; + } + + FOREACH_HASH(namePtr, mPtr, &clsPtr->classMethods) { + if (mPtr->typePtr != NULL && (mPtr->flags & flag) == flag) { + Tcl_ListObjAppendElement(NULL, Tcl_GetObjResult(interp), namePtr); + } + } + return TCL_OK; +} + +/* + * ---------------------------------------------------------------------- + * + * InfoClassMixinsCmd -- + * + * Implements [info class mixins $clsName] + * + * ---------------------------------------------------------------------- + */ + +static int +InfoClassMixinsCmd( + ClientData clientData, + Tcl_Interp *interp, + int objc, + Tcl_Obj *const objv[]) +{ + Object *oPtr; + Class *clsPtr, *mixinPtr; + int i; + + if (objc != 2) { + Tcl_WrongNumArgs(interp, 1, objv, "className"); + return TCL_ERROR; + } + oPtr = (Object *) Tcl_GetObjectFromObj(interp, objv[1]); + if (oPtr == NULL) { + return TCL_ERROR; + } + if (oPtr->classPtr == NULL) { + Tcl_AppendResult(interp, "\"", TclGetString(objv[1]), + "\" is not a class", NULL); + return TCL_ERROR; + } + clsPtr = oPtr->classPtr; + + FOREACH(mixinPtr, clsPtr->mixins) { + Tcl_ListObjAppendElement(NULL, Tcl_GetObjResult(interp), + TclOOObjectName(interp, mixinPtr->thisPtr)); + } + return TCL_OK; +} + +/* + * ---------------------------------------------------------------------- + * + * InfoClassSubsCmd -- + * + * Implements [info class subclasses $clsName ?$pattern?] + * + * ---------------------------------------------------------------------- + */ + +static int +InfoClassSubsCmd( + ClientData clientData, + Tcl_Interp *interp, + int objc, + Tcl_Obj *const objv[]) +{ + Object *oPtr; + Class *clsPtr, *subclassPtr; + int i; + const char *pattern = NULL; + + if (objc != 2 && objc != 3) { + Tcl_WrongNumArgs(interp, 1, objv, "className ?pattern?"); + return TCL_ERROR; + } + oPtr = (Object *) Tcl_GetObjectFromObj(interp, objv[1]); + if (oPtr == NULL) { + return TCL_ERROR; + } + if (oPtr->classPtr == NULL) { + Tcl_AppendResult(interp, "\"", TclGetString(objv[1]), + "\" is not a class", NULL); + return TCL_ERROR; + } + clsPtr = oPtr->classPtr; + if (objc == 3) { + pattern = TclGetString(objv[2]); + } + + FOREACH(subclassPtr, clsPtr->subclasses) { + Tcl_Obj *tmpObj = TclOOObjectName(interp, subclassPtr->thisPtr); + + if (pattern && !Tcl_StringMatch(TclGetString(tmpObj), pattern)) { + continue; + } + Tcl_ListObjAppendElement(NULL, Tcl_GetObjResult(interp), tmpObj); + } + FOREACH(subclassPtr, clsPtr->mixinSubs) { + Tcl_Obj *tmpObj = TclOOObjectName(interp, subclassPtr->thisPtr); + + if (pattern && !Tcl_StringMatch(TclGetString(tmpObj), pattern)) { + continue; + } + Tcl_ListObjAppendElement(NULL, Tcl_GetObjResult(interp), tmpObj); + } + return TCL_OK; +} + +/* + * ---------------------------------------------------------------------- + * + * InfoClassSupersCmd -- + * + * Implements [info class superclasses $clsName] + * + * ---------------------------------------------------------------------- + */ + +static int +InfoClassSupersCmd( + ClientData clientData, + Tcl_Interp *interp, + int objc, + Tcl_Obj *const objv[]) +{ + Object *oPtr; + Class *clsPtr, *superPtr; + int i; + + if (objc != 2) { + Tcl_WrongNumArgs(interp, 1, objv, "className"); + return TCL_ERROR; + } + oPtr = (Object *) Tcl_GetObjectFromObj(interp, objv[1]); + if (oPtr == NULL) { + return TCL_ERROR; + } + if (oPtr->classPtr == NULL) { + Tcl_AppendResult(interp, "\"", TclGetString(objv[1]), + "\" is not a class", NULL); + return TCL_ERROR; + } + clsPtr = oPtr->classPtr; + + FOREACH(superPtr, clsPtr->superclasses) { + Tcl_ListObjAppendElement(NULL, Tcl_GetObjResult(interp), + TclOOObjectName(interp, superPtr->thisPtr)); + } + return TCL_OK; +} + +/* + * Local Variables: + * mode: c + * c-basic-offset: 4 + * fill-column: 78 + * End: + */ diff --git a/generic/tclOOInt.h b/generic/tclOOInt.h new file mode 100644 index 0000000..7c0b6a7 --- /dev/null +++ b/generic/tclOOInt.h @@ -0,0 +1,579 @@ +/* + * tclOOInt.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: tclOOInt.h,v 1.1 2008/05/31 11:42:18 dkf Exp $ + */ + +#include <tclInt.h> +#include "tclOO.h" + +/* + * Forward declarations. + */ + +struct CallChain; +struct Class; +struct Foundation; +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. */ + int refCount; + 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; + +/* + * Pre- and post-call callbacks, to allow procedure-like methods to be fine + * tuned in their behaviour. + */ + +typedef int (*TclOO_PreCallProc)(ClientData clientData, Tcl_Interp *interp, + Tcl_ObjectContext context, Tcl_CallFrame *framePtr, int *isFinished); +typedef int (*TclOO_PostCallProc)(ClientData clientData, Tcl_Interp *interp, + Tcl_ObjectContext context, Tcl_Namespace *namespacePtr, int result); +typedef void (*TclOO_PmCDDeleteProc)(ClientData clientData); +typedef ClientData (*TclOO_PmCDCloneProc)(ClientData clientData); + +/* + * Procedure-like methods have the following extra information. + */ + +typedef struct ProcedureMethod { + int version; /* Version of this structure. Currently must + * be 0. */ + Proc *procPtr; /* Core of the implementation of the method; + * includes the argument definition and the + * body bytecodes. */ + int flags; /* Flags to control features. */ + int refCount; + ClientData clientData; + TclOO_PmCDDeleteProc deleteClientdataProc; + TclOO_PmCDCloneProc cloneClientdataProc; + ProcErrorProc errProc; /* Replacement error handler. */ + TclOO_PreCallProc preCallProc; + /* Callback to allow for additional setup + * before the method executes. */ + TclOO_PostCallProc postCallProc; + /* Callback to allow for additional cleanup + * after the method executes. */ + GetFrameInfoValueProc gfivProc; + /* Callback to allow for fine tuning of how + * the method reports itself. */ +} ProcedureMethod; + +#define TCLOO_PROCEDURE_METHOD_VERSION 0 + +/* + * Flags for use in a ProcedureMethod. + * + * When the USE_DECLARER_NS flag is set, the method will use the namespace of + * the object or class that declared it (or the clone of it, if it was from + * such that the implementation of the method came to the particular use) + * instead of the namespace of the object on which the method was invoked. + * This flag must be distinct from all others that are associated with + * methods. + */ + +#define USE_DECLARER_NS 0x80 + +/* + * 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 { + struct Foundation *fPtr; /* The basis for the object system. Putting + * this here allows the avoidance of quite a + * lot of hash lookups on the critical path + * for object invokation and creation. */ + 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 *methodsPtr; /* 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 refCount; /* Number of strong references to this object. + * Note that there may be many more weak + * references; this mechanism is there to + * avoid Tcl_Preserve. */ + int flags; + int creationEpoch; /* Unique value to make comparisons of objects + * easier. */ + 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_Obj *cachedNameObj; /* Cache of the name of the object. */ + Tcl_HashTable *chainCache; /* Place to keep unused contexts. This table + * is indexed by method name as Tcl_Obj. */ + Tcl_ObjectMapMethodNameProc mapMethodNameProc; + /* Function to allow remapping of method + * names. For itcl-ng. */ +} 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. */ +#define USE_CLASS_CACHE 0x4000 /* Flag set to say that the object is a pure + * instance of the class, and has had nothing + * added that changes the dispatch chain (i.e. + * no methods, mixins, or filters. */ + +/* + * 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 refCount; /* Number of strong references to this class. + * Weak references are not counted; the + * purpose of this is to avoid Tcl_Preserve as + * that is quite slow. */ + 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. */ + 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. */ + struct CallChain *constructorChainPtr; + struct CallChain *destructorChainPtr; + Tcl_HashTable *classChainCache; + /* Places where call chains are stored. For + * constructors, the class chain is always + * used. For destructors and ordinary methods, + * the class chain is only used when the + * object doesn't override with its own mixins + * (and filters and method implementations for + * when getting method chains). */ +} 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 ThreadLocalData { + int nsCount; /* Master epoch counter is used for keeping + * the values used in Tcl_Obj internal + * representations sane. Must be thread-local + * because Tcl_Objs can cross interpreter + * boundaries within a thread (objects don't + * generally cross threads). */ +} ThreadLocalData; + +typedef struct Foundation { + Tcl_Interp *interp; + 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 *objdefNs; /* Namespace containing special commands for + * manipulating objects and classes. The + * "oo::objdefine" 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. */ + ThreadLocalData *tsdPtr; /* 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. */ + Tcl_Obj *constructorName; /* Shared object containing the "name" of a + * constructor. */ + Tcl_Obj *destructorName; /* Shared object containing the "name" of a + * destructor. */ +} 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. */ + Class *filterDeclarer; /* What class decided to add the filter; if + * NULL, it was added by the object. */ +}; + +typedef struct CallChain { + int objectCreationEpoch; /* The object's creation epoch. Note that the + * object reference is not stored in the call + * chain; it is in the call context. */ + int objectEpoch; /* Local (object structure) epoch counter + * snapshot. */ + int epoch; /* Global (class structure) epoch counter + * snapshot. */ + int flags; /* Assorted flags, see below. */ + int refCount; /* Reference count. */ + int numChain; /* Size of the call chain. */ + struct MInvoke *chain; /* Array of call chain entries. May point to + * staticChain if the number of entries is + * small. */ + struct MInvoke staticChain[CALL_CHAIN_STATIC_SIZE]; +} CallChain; + +typedef struct CallContext { + Object *oPtr; /* The object associated with this call. */ + int index; /* Index into the call chain of the currently + * executing method implementation. */ + int skip; /* Current number of arguments to skip; can + * vary depending on whether it is a direct + * method call or a continuation via the + * [next] command. */ + CallChain *callPtr; /* The actual call chain. */ +} CallContext; + +/* + * Bits for the 'flags' field of the call context. + */ + +#define PUBLIC_METHOD 0x01 /* This is a public (exported) method. */ +#define PRIVATE_METHOD 0x02 /* This is a private (class's direct instances + * only) method. */ +#define OO_UNKNOWN_METHOD 0x04 /* This is an unknown method. */ +#define CONSTRUCTOR 0x08 /* This is a constructor. */ +#define DESTRUCTOR 0x10 /* This is a destructor. */ + +/* + * Assorted flags for call frames. Note that bits 1 and 2 are already taken by + * Tcl itself. + */ + +#if 0 +#define FRAME_IS_METHOD 0x4 /* The frame is a method body, and the frame's + * clientData field contains a CallContext + * reference. */ +#define FRAME_IS_OO_DEFINE 0x8 /* The frame is part of the inside workings of + * the [oo::define] command; the clientData + * field contains an Object reference that has + * been confirmed to refer to a class. */ +#endif + +/* + * Structure containing definition information about basic class methods. + */ + +typedef struct { + const char *name; /* Name of the method in question. */ + int isPublic; /* Whether the method is public by default. */ + Tcl_MethodType definition; /* How to call the method. */ +} DeclaredClassMethod; + +/* + *---------------------------------------------------------------- + * 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 TclOOObjDefObjCmd(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 TclOODefineDeleteMethodObjCmd(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, const int objc, + Tcl_Obj *const *objv); +MODULE_SCOPE int TclOODefineRenameMethodObjCmd(ClientData clientData, + Tcl_Interp *interp, int objc, + Tcl_Obj *const *objv); +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 TclOODefineClassObjCmd(ClientData clientData, + Tcl_Interp *interp, int objc, + Tcl_Obj *const *objv); +MODULE_SCOPE int TclOODefineSelfObjCmd(ClientData clientData, + Tcl_Interp *interp, int objc, + Tcl_Obj *const *objv); +MODULE_SCOPE int TclOOUnknownDefinition(ClientData clientData, + Tcl_Interp *interp, int objc, + Tcl_Obj *const *objv); +MODULE_SCOPE int TclOOCopyObjectCmd(ClientData clientData, + Tcl_Interp *interp, int objc, + Tcl_Obj *const *objv); +MODULE_SCOPE int TclOONextObjCmd(ClientData clientData, + Tcl_Interp *interp, int objc, + Tcl_Obj *const *objv); +MODULE_SCOPE int TclOOSelfObjCmd(ClientData clientData, + Tcl_Interp *interp, int objc, + Tcl_Obj *const *objv); + +/* + * Method implementations (in tclOOBasic.c). + */ + +MODULE_SCOPE int TclOO_Class_Create(ClientData clientData, + Tcl_Interp *interp, Tcl_ObjectContext context, + int objc, Tcl_Obj *const *objv); +MODULE_SCOPE int TclOO_Class_CreateNs(ClientData clientData, + Tcl_Interp *interp, Tcl_ObjectContext context, + int objc, Tcl_Obj *const *objv); +MODULE_SCOPE int TclOO_Class_New(ClientData clientData, + Tcl_Interp *interp, Tcl_ObjectContext context, + int objc, Tcl_Obj *const *objv); +MODULE_SCOPE int TclOO_Object_Destroy(ClientData clientData, + Tcl_Interp *interp, Tcl_ObjectContext context, + int objc, Tcl_Obj *const *objv); +MODULE_SCOPE int TclOO_Object_Eval(ClientData clientData, + Tcl_Interp *interp, Tcl_ObjectContext context, + int objc, Tcl_Obj *const *objv); +MODULE_SCOPE int TclOO_Object_LinkVar(ClientData clientData, + Tcl_Interp *interp, Tcl_ObjectContext context, + int objc, Tcl_Obj *const *objv); +MODULE_SCOPE int TclOO_Object_Unknown(ClientData clientData, + Tcl_Interp *interp, Tcl_ObjectContext context, + int objc, Tcl_Obj *const *objv); +MODULE_SCOPE int TclOO_Object_VarName(ClientData clientData, + Tcl_Interp *interp, Tcl_ObjectContext context, + int objc, Tcl_Obj *const *objv); + +/* + * Private definitions, some of which perhaps ought to be exposed properly or + * maybe just put in the internal stubs table. + */ + +MODULE_SCOPE void TclOOAddToInstances(Object *oPtr, Class *clsPtr); +MODULE_SCOPE void TclOOAddToMixinSubs(Class *subPtr, Class *mixinPtr); +MODULE_SCOPE void TclOOAddToSubclasses(Class *subPtr, Class *superPtr); +MODULE_SCOPE void TclOODeleteChain(CallChain *callPtr); +MODULE_SCOPE void TclOODeleteChainCache(Tcl_HashTable *tablePtr); +MODULE_SCOPE void TclOODeleteContext(CallContext *contextPtr); +MODULE_SCOPE void TclOODelMethodRef(Method *method); +MODULE_SCOPE CallContext *TclOOGetCallContext(Object *oPtr, + Tcl_Obj *methodNameObj, int flags); +MODULE_SCOPE Foundation *TclOOGetFoundation(Tcl_Interp *interp); +MODULE_SCOPE Tcl_Obj * TclOOGetFwdFromMethod(Method *mPtr); +MODULE_SCOPE Proc * TclOOGetProcFromMethod(Method *mPtr); +MODULE_SCOPE int TclOOGetSortedClassMethodList(Class *clsPtr, + int flags, const char ***stringsPtr); +MODULE_SCOPE int TclOOGetSortedMethodList(Object *oPtr, int flags, + const char ***stringsPtr); +MODULE_SCOPE int TclOOInit(Tcl_Interp *interp); +MODULE_SCOPE void TclOOInitInfo(Tcl_Interp *interp); +MODULE_SCOPE int TclOOInvokeContext(Tcl_Interp *interp, + CallContext *contextPtr, int objc, + Tcl_Obj *const *objv); +MODULE_SCOPE void TclOONewBasicMethod(Tcl_Interp *interp, Class *clsPtr, + const DeclaredClassMethod *dcm); +MODULE_SCOPE Tcl_Obj * TclOOObjectName(Tcl_Interp *interp, Object *oPtr); +MODULE_SCOPE void TclOORemoveFromInstances(Object *oPtr, Class *clsPtr); +MODULE_SCOPE void TclOORemoveFromMixinSubs(Class *subPtr, + Class *mixinPtr); +MODULE_SCOPE void TclOORemoveFromSubclasses(Class *subPtr, + Class *superPtr); +MODULE_SCOPE void TclOOStashContext(Tcl_Obj *objPtr, + CallContext *contextPtr); + +/* + * Include all the private API, generated from tclOO.decls. + */ + +#include "tclOOIntDecls.h" + +/* + * 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) + +/* + * Alternatives to Tcl_Preserve/Tcl_EventuallyFree/Tcl_Release. + */ + +#define AddRef(ptr) ((ptr)->refCount++) +#define DelRef(ptr) do { \ + if (--(ptr)->refCount < 1) { \ + ckfree((char *) (ptr)); \ + } \ + } while(0) + +/* + * Local Variables: + * mode: c + * c-basic-offset: 4 + * fill-column: 78 + * End: + */ diff --git a/generic/tclOOIntDecls.h b/generic/tclOOIntDecls.h new file mode 100644 index 0000000..e39b457 --- /dev/null +++ b/generic/tclOOIntDecls.h @@ -0,0 +1,209 @@ +/* + * $Id: tclOOIntDecls.h,v 1.1 2008/05/31 11:42:18 dkf Exp $ + * + * This file is (mostly) automatically generated from tclOO.decls. + */ + +/* !BEGIN!: Do not edit below this line. */ + +#define TCLOOINT_STUBS_EPOCH 0 +#define TCLOOINT_STUBS_REVISION 44 + +#if !defined(USE_TCLOO_STUBS) + +/* + * Exported function declarations: + */ + +/* 0 */ +TCLOOAPI Tcl_Object TclOOGetDefineCmdContext (Tcl_Interp * interp); +/* 1 */ +TCLOOAPI Tcl_Method TclOOMakeProcInstanceMethod (Tcl_Interp * interp, + Object * oPtr, int flags, Tcl_Obj * nameObj, + Tcl_Obj * argsObj, Tcl_Obj * bodyObj, + const Tcl_MethodType * typePtr, + ClientData clientData, Proc ** procPtrPtr); +/* 2 */ +TCLOOAPI Tcl_Method TclOOMakeProcMethod (Tcl_Interp * interp, + Class * clsPtr, int flags, Tcl_Obj * nameObj, + const char * namePtr, Tcl_Obj * argsObj, + Tcl_Obj * bodyObj, + const Tcl_MethodType * typePtr, + ClientData clientData, Proc ** procPtrPtr); +/* 3 */ +TCLOOAPI Method * TclOONewProcInstanceMethod (Tcl_Interp * interp, + Object * oPtr, int flags, Tcl_Obj * nameObj, + Tcl_Obj * argsObj, Tcl_Obj * bodyObj, + ProcedureMethod ** pmPtrPtr); +/* 4 */ +TCLOOAPI Method * TclOONewProcMethod (Tcl_Interp * interp, + Class * clsPtr, int flags, Tcl_Obj * nameObj, + Tcl_Obj * argsObj, Tcl_Obj * bodyObj, + ProcedureMethod ** pmPtrPtr); +/* 5 */ +TCLOOAPI int TclOOObjectCmdCore (Object * oPtr, + Tcl_Interp * interp, int objc, + Tcl_Obj *const * objv, int publicOnly, + Class * startCls); +/* 6 */ +TCLOOAPI int TclOOIsReachable (Class * targetPtr, + Class * startPtr); +/* 7 */ +TCLOOAPI Method * TclOONewForwardMethod (Tcl_Interp * interp, + Class * clsPtr, int isPublic, + Tcl_Obj * nameObj, Tcl_Obj * prefixObj); +/* 8 */ +TCLOOAPI Method * TclOONewForwardInstanceMethod (Tcl_Interp * interp, + Object * oPtr, int isPublic, + Tcl_Obj * nameObj, Tcl_Obj * prefixObj); +/* 9 */ +TCLOOAPI Tcl_Method TclOONewProcInstanceMethodEx (Tcl_Interp * interp, + Tcl_Object oPtr, + TclOO_PreCallProc preCallPtr, + TclOO_PostCallProc postCallPtr, + ProcErrorProc errProc, ClientData clientData, + Tcl_Obj * nameObj, Tcl_Obj * argsObj, + Tcl_Obj * bodyObj, int flags, + void ** internalTokenPtr); +/* 10 */ +TCLOOAPI Tcl_Method TclOONewProcMethodEx (Tcl_Interp * interp, + Tcl_Class clsPtr, + TclOO_PreCallProc preCallPtr, + TclOO_PostCallProc postCallPtr, + ProcErrorProc errProc, ClientData clientData, + Tcl_Obj * nameObj, Tcl_Obj * argsObj, + Tcl_Obj * bodyObj, int flags, + void ** internalTokenPtr); +/* 11 */ +TCLOOAPI int TclOOInvokeObject (Tcl_Interp * interp, + Tcl_Object object, Tcl_Class startCls, + int publicPrivate, int objc, + Tcl_Obj *const * objv); +/* 12 */ +TCLOOAPI void TclOOObjectSetFilters (Object * oPtr, int numFilters, + Tcl_Obj *const * filters); +/* 13 */ +TCLOOAPI void TclOOClassSetFilters (Tcl_Interp * interp, + Class * classPtr, int numFilters, + Tcl_Obj *const * filters); +/* 14 */ +TCLOOAPI void TclOOObjectSetMixins (Object * oPtr, int numMixins, + Class *const * mixins); +/* 15 */ +TCLOOAPI void TclOOClassSetMixins (Tcl_Interp * interp, + Class * classPtr, int numMixins, + Class *const * mixins); + +#endif /* !defined(USE_TCLOO_STUBS) */ + +typedef struct TclOOIntStubs { + int magic; + int epoch; + int revision; + struct TclOOIntStubHooks *hooks; + + Tcl_Object (*tclOOGetDefineCmdContext) (Tcl_Interp * interp); /* 0 */ + Tcl_Method (*tclOOMakeProcInstanceMethod) (Tcl_Interp * interp, Object * oPtr, int flags, Tcl_Obj * nameObj, Tcl_Obj * argsObj, Tcl_Obj * bodyObj, const Tcl_MethodType * typePtr, ClientData clientData, Proc ** procPtrPtr); /* 1 */ + Tcl_Method (*tclOOMakeProcMethod) (Tcl_Interp * interp, Class * clsPtr, int flags, Tcl_Obj * nameObj, const char * namePtr, Tcl_Obj * argsObj, Tcl_Obj * bodyObj, const Tcl_MethodType * typePtr, ClientData clientData, Proc ** procPtrPtr); /* 2 */ + Method * (*tclOONewProcInstanceMethod) (Tcl_Interp * interp, Object * oPtr, int flags, Tcl_Obj * nameObj, Tcl_Obj * argsObj, Tcl_Obj * bodyObj, ProcedureMethod ** pmPtrPtr); /* 3 */ + Method * (*tclOONewProcMethod) (Tcl_Interp * interp, Class * clsPtr, int flags, Tcl_Obj * nameObj, Tcl_Obj * argsObj, Tcl_Obj * bodyObj, ProcedureMethod ** pmPtrPtr); /* 4 */ + int (*tclOOObjectCmdCore) (Object * oPtr, Tcl_Interp * interp, int objc, Tcl_Obj *const * objv, int publicOnly, Class * startCls); /* 5 */ + int (*tclOOIsReachable) (Class * targetPtr, Class * startPtr); /* 6 */ + Method * (*tclOONewForwardMethod) (Tcl_Interp * interp, Class * clsPtr, int isPublic, Tcl_Obj * nameObj, Tcl_Obj * prefixObj); /* 7 */ + Method * (*tclOONewForwardInstanceMethod) (Tcl_Interp * interp, Object * oPtr, int isPublic, Tcl_Obj * nameObj, Tcl_Obj * prefixObj); /* 8 */ + Tcl_Method (*tclOONewProcInstanceMethodEx) (Tcl_Interp * interp, Tcl_Object oPtr, TclOO_PreCallProc preCallPtr, TclOO_PostCallProc postCallPtr, ProcErrorProc errProc, ClientData clientData, Tcl_Obj * nameObj, Tcl_Obj * argsObj, Tcl_Obj * bodyObj, int flags, void ** internalTokenPtr); /* 9 */ + Tcl_Method (*tclOONewProcMethodEx) (Tcl_Interp * interp, Tcl_Class clsPtr, TclOO_PreCallProc preCallPtr, TclOO_PostCallProc postCallPtr, ProcErrorProc errProc, ClientData clientData, Tcl_Obj * nameObj, Tcl_Obj * argsObj, Tcl_Obj * bodyObj, int flags, void ** internalTokenPtr); /* 10 */ + int (*tclOOInvokeObject) (Tcl_Interp * interp, Tcl_Object object, Tcl_Class startCls, int publicPrivate, int objc, Tcl_Obj *const * objv); /* 11 */ + void (*tclOOObjectSetFilters) (Object * oPtr, int numFilters, Tcl_Obj *const * filters); /* 12 */ + void (*tclOOClassSetFilters) (Tcl_Interp * interp, Class * classPtr, int numFilters, Tcl_Obj *const * filters); /* 13 */ + void (*tclOOObjectSetMixins) (Object * oPtr, int numMixins, Class *const * mixins); /* 14 */ + void (*tclOOClassSetMixins) (Tcl_Interp * interp, Class * classPtr, int numMixins, Class *const * mixins); /* 15 */ +} TclOOIntStubs; + +#ifdef __cplusplus +extern "C" { +#endif +extern const TclOOIntStubs *tclOOIntStubsPtr; +#ifdef __cplusplus +} +#endif + +#if defined(USE_TCLOO_STUBS) + +/* + * Inline function declarations: + */ + +#ifndef TclOOGetDefineCmdContext +#define TclOOGetDefineCmdContext \ + (tclOOIntStubsPtr->tclOOGetDefineCmdContext) /* 0 */ +#endif +#ifndef TclOOMakeProcInstanceMethod +#define TclOOMakeProcInstanceMethod \ + (tclOOIntStubsPtr->tclOOMakeProcInstanceMethod) /* 1 */ +#endif +#ifndef TclOOMakeProcMethod +#define TclOOMakeProcMethod \ + (tclOOIntStubsPtr->tclOOMakeProcMethod) /* 2 */ +#endif +#ifndef TclOONewProcInstanceMethod +#define TclOONewProcInstanceMethod \ + (tclOOIntStubsPtr->tclOONewProcInstanceMethod) /* 3 */ +#endif +#ifndef TclOONewProcMethod +#define TclOONewProcMethod \ + (tclOOIntStubsPtr->tclOONewProcMethod) /* 4 */ +#endif +#ifndef TclOOObjectCmdCore +#define TclOOObjectCmdCore \ + (tclOOIntStubsPtr->tclOOObjectCmdCore) /* 5 */ +#endif +#ifndef TclOOIsReachable +#define TclOOIsReachable \ + (tclOOIntStubsPtr->tclOOIsReachable) /* 6 */ +#endif +#ifndef TclOONewForwardMethod +#define TclOONewForwardMethod \ + (tclOOIntStubsPtr->tclOONewForwardMethod) /* 7 */ +#endif +#ifndef TclOONewForwardInstanceMethod +#define TclOONewForwardInstanceMethod \ + (tclOOIntStubsPtr->tclOONewForwardInstanceMethod) /* 8 */ +#endif +#ifndef TclOONewProcInstanceMethodEx +#define TclOONewProcInstanceMethodEx \ + (tclOOIntStubsPtr->tclOONewProcInstanceMethodEx) /* 9 */ +#endif +#ifndef TclOONewProcMethodEx +#define TclOONewProcMethodEx \ + (tclOOIntStubsPtr->tclOONewProcMethodEx) /* 10 */ +#endif +#ifndef TclOOInvokeObject +#define TclOOInvokeObject \ + (tclOOIntStubsPtr->tclOOInvokeObject) /* 11 */ +#endif +#ifndef TclOOObjectSetFilters +#define TclOOObjectSetFilters \ + (tclOOIntStubsPtr->tclOOObjectSetFilters) /* 12 */ +#endif +#ifndef TclOOClassSetFilters +#define TclOOClassSetFilters \ + (tclOOIntStubsPtr->tclOOClassSetFilters) /* 13 */ +#endif +#ifndef TclOOObjectSetMixins +#define TclOOObjectSetMixins \ + (tclOOIntStubsPtr->tclOOObjectSetMixins) /* 14 */ +#endif +#ifndef TclOOClassSetMixins +#define TclOOClassSetMixins \ + (tclOOIntStubsPtr->tclOOClassSetMixins) /* 15 */ +#endif + +#endif /* defined(USE_TCLOO_STUBS) */ + +/* !END!: Do not edit above this line. */ + +struct TclOOStubAPI { + TclOOStubs *stubsPtr; + TclOOIntStubs *intStubsPtr; +}; diff --git a/generic/tclOOMethod.c b/generic/tclOOMethod.c new file mode 100644 index 0000000..f190533 --- /dev/null +++ b/generic/tclOOMethod.c @@ -0,0 +1,1425 @@ +/* + * tclOOMethod.c -- + * + * This file contains code to create and manage methods. + * + * Copyright (c) 2005-2008 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: tclOOMethod.c,v 1.1 2008/05/31 11:42:19 dkf Exp $ + */ + +#ifdef HAVE_CONFIG_H +#include "config.h" +#endif +#include "tclInt.h" +#include "tclOOInt.h" + +/* + * Structure used to help delay computing names of objects or classes for + * [info frame] until needed, making invokation faster in the normal case. + */ + +struct PNI { + Tcl_Interp *interp; /* Interpreter in which to compute the name of + * a method. */ + Tcl_Method method; /* Method to compute the name of. */ +}; + +/* + * Structure used to contain all the information needed about a call frame + * used in a procedure-like method. + */ + +typedef struct { + CallFrame *framePtr; /* Reference to the call frame itself (it's + * actually allocated on the Tcl stack). */ + ProcErrorProc errProc; /* The error handler for the body. */ + Tcl_Obj *nameObj; /* The "name" of the command. */ + Command cmd; /* The command structure. Mostly bogus. */ + ExtraFrameInfo efi; /* Extra information used for [info frame]. */ + struct PNI pni; /* Specialist information used in the efi + * field for this type of call. */ +} PMFrameData; + +/* + * Function declarations for things defined in this file. + */ + +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 InvokeProcedureMethod(ClientData clientData, + Tcl_Interp *interp, Tcl_ObjectContext context, + int objc, Tcl_Obj *const *objv); +static int PushMethodCallFrame(Tcl_Interp *interp, + CallContext *contextPtr, ProcedureMethod *pmPtr, + int objc, Tcl_Obj *const *objv, + PMFrameData *fdPtr); +static void DeleteProcedureMethodRecord(ProcedureMethod *pmPtr); +static void DeleteProcedureMethod(ClientData clientData); +static int CloneProcedureMethod(Tcl_Interp *interp, + ClientData clientData, ClientData *newClientData); +static void MethodErrorHandler(Tcl_Interp *interp, + Tcl_Obj *procNameObj); +static void ConstructorErrorHandler(Tcl_Interp *interp, + Tcl_Obj *procNameObj); +static void DestructorErrorHandler(Tcl_Interp *interp, + Tcl_Obj *procNameObj); +static Tcl_Obj * RenderDeclarerName(ClientData clientData); +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(Tcl_Interp *interp, + ClientData clientData, ClientData *newClientData); + +/* + * 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 +}; + +/* + * ---------------------------------------------------------------------- + * + * Tcl_NewInstanceMethod -- + * + * Attach a method to an object instance. + * + * ---------------------------------------------------------------------- + */ + +Tcl_Method +Tcl_NewInstanceMethod( + 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 flags, /* 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; + } + if (!oPtr->methodsPtr) { + oPtr->methodsPtr = (Tcl_HashTable *) ckalloc(sizeof(Tcl_HashTable)); + Tcl_InitObjHashTable(oPtr->methodsPtr); + oPtr->flags &= ~USE_CLASS_CACHE; + } + hPtr = Tcl_CreateHashEntry(oPtr->methodsPtr, (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->refCount = 1; + mPtr->flags = 0; + mPtr->declaringObjectPtr = oPtr; + mPtr->declaringClassPtr = NULL; + if (flags) { + mPtr->flags |= flags & (PUBLIC_METHOD | PRIVATE_METHOD); + } + oPtr->epoch++; + return (Tcl_Method) mPtr; +} + +/* + * ---------------------------------------------------------------------- + * + * Tcl_NewMethod -- + * + * Attach a method to a class. + * + * ---------------------------------------------------------------------- + */ + +Tcl_Method +Tcl_NewMethod( + 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 flags, /* 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: + clsPtr->thisPtr->fPtr->epoch++; + mPtr->typePtr = typePtr; + mPtr->clientData = clientData; + mPtr->refCount = 1; + mPtr->flags = 0; + mPtr->declaringObjectPtr = NULL; + mPtr->declaringClassPtr = clsPtr; + if (flags) { + mPtr->flags |= flags & (PUBLIC_METHOD | PRIVATE_METHOD); + } + + return (Tcl_Method) mPtr; +} + +/* + * ---------------------------------------------------------------------- + * + * TclOODelMethodRef -- + * + * How to delete a method. + * + * ---------------------------------------------------------------------- + */ + +void +TclOODelMethodRef( + Method *mPtr) +{ + if ((mPtr != NULL) && (--mPtr->refCount < 0)) { + if (mPtr->typePtr != NULL && mPtr->typePtr->deleteProc != NULL) { + mPtr->typePtr->deleteProc(mPtr->clientData); + } + if (mPtr->namePtr != NULL) { + Tcl_DecrRefCount(mPtr->namePtr); + } + + ckfree((char *) mPtr); + } +} + +/* + * ---------------------------------------------------------------------- + * + * TclOONewBasicMethod -- + * + * Helper that makes it cleaner to create very simple methods during + * basic system initialization. Not suitable for general use. + * + * ---------------------------------------------------------------------- + */ + +void +TclOONewBasicMethod( + Tcl_Interp *interp, + Class *clsPtr, /* Class to attach the method to. */ + const DeclaredClassMethod *dcm) + /* Name of the method, whether it is public, + * and the function to implement it. */ +{ + Tcl_Obj *namePtr = Tcl_NewStringObj(dcm->name, -1); + + Tcl_IncrRefCount(namePtr); + Tcl_NewMethod(interp, (Tcl_Class) clsPtr, namePtr, + (dcm->isPublic ? PUBLIC_METHOD : 0), &dcm->definition, NULL); + Tcl_DecrRefCount(namePtr); +} + +/* + * ---------------------------------------------------------------------- + * + * TclOONewProcInstanceMethod -- + * + * Create a new procedure-like method for an object. + * + * ---------------------------------------------------------------------- + */ + +Method * +TclOONewProcInstanceMethod( + Tcl_Interp *interp, /* The interpreter containing the object. */ + Object *oPtr, /* The object to modify. */ + int flags, /* 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. */ + ProcedureMethod **pmPtrPtr) /* Place to write pointer to procedure method + * structure to allow for deeper tuning of the + * structure's contents. NULL if caller is not + * interested. */ +{ + int argsLen; + register ProcedureMethod *pmPtr; + Tcl_Method method; + + if (Tcl_ListObjLength(interp, argsObj, &argsLen) != TCL_OK) { + return NULL; + } + pmPtr = (ProcedureMethod *) ckalloc(sizeof(ProcedureMethod)); + memset(pmPtr, 0, sizeof(ProcedureMethod)); + pmPtr->version = TCLOO_PROCEDURE_METHOD_VERSION; + pmPtr->flags = flags & USE_DECLARER_NS; + pmPtr->refCount = 1; + method = TclOOMakeProcInstanceMethod(interp, oPtr, flags, nameObj, + argsObj, bodyObj, &procMethodType, pmPtr, &pmPtr->procPtr); + if (method == NULL) { + ckfree((char *) pmPtr); + } else if (pmPtrPtr != NULL) { + *pmPtrPtr = pmPtr; + } + return (Method *) method; +} + +/* + * ---------------------------------------------------------------------- + * + * TclOONewProcMethod -- + * + * Create a new procedure-like method for a class. + * + * ---------------------------------------------------------------------- + */ + +Method * +TclOONewProcMethod( + Tcl_Interp *interp, /* The interpreter containing the class. */ + Class *clsPtr, /* The class to modify. */ + int flags, /* 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. */ + ProcedureMethod **pmPtrPtr) /* Place to write pointer to procedure method + * structure to allow for deeper tuning of the + * structure's contents. NULL if caller is not + * interested. */ +{ + int argsLen; /* -1 => delete argsObj before exit */ + register ProcedureMethod *pmPtr; + const char *procName; + Tcl_Method method; + + if (argsObj == NULL) { + argsLen = -1; + argsObj = Tcl_NewObj(); + 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)); + memset(pmPtr, 0, sizeof(ProcedureMethod)); + pmPtr->version = TCLOO_PROCEDURE_METHOD_VERSION; + pmPtr->flags = flags & USE_DECLARER_NS; + pmPtr->refCount = 1; + + method = TclOOMakeProcMethod(interp, clsPtr, flags, nameObj, + procName, argsObj, bodyObj, &procMethodType, pmPtr, + &pmPtr->procPtr); + + if (argsLen == -1) { + Tcl_DecrRefCount(argsObj); + } + if (method == NULL) { + ckfree((char *) pmPtr); + } else if (pmPtrPtr != NULL) { + *pmPtrPtr = pmPtr; + } + + return (Method *) method; +} + +/* + * ---------------------------------------------------------------------- + * + * TclOOMakeProcInstanceMethod -- + * + * The guts of the code to make a procedure-like method for an object. + * Split apart so that it is easier for other extensions to reuse (in + * particular, it frees them from having to pry so deeply into Tcl's + * guts). + * + * ---------------------------------------------------------------------- + */ + +Tcl_Method +TclOOMakeProcInstanceMethod( + Tcl_Interp *interp, /* The interpreter containing the object. */ + Object *oPtr, /* The object to modify. */ + int flags, /* 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. */ + const Tcl_MethodType *typePtr, + /* The type of the method to create. */ + ClientData clientData, /* The per-method type-specific data. */ + Proc **procPtrPtr) /* A pointer to the variable in which to write + * the procedure record reference. Presumably + * inside the structure indicated by the + * pointer in clientData. */ +{ + Interp *iPtr = (Interp *) interp; + Proc *procPtr; + + if (TclCreateProc(interp, NULL, TclGetString(nameObj), argsObj, bodyObj, + procPtrPtr) != TCL_OK) { + return NULL; + } + procPtr = *procPtrPtr; + procPtr->cmdPtr = NULL; + + if (iPtr->cmdFramePtr) { + CmdFrame context = *iPtr->cmdFramePtr; + + if (context.type == TCL_LOCATION_BC) { + /* + * Retrieve source information from the bytecode, if possible. If + * the information is retrieved successfully, context.type will be + * TCL_LOCATION_SOURCE and the reference held by + * context.data.eval.path will be counted. + */ + + TclGetSrcInfoForPc(&context); + } else if (context.type == TCL_LOCATION_SOURCE) { + /* + * The copy into 'context' up above has created another reference + * to 'context.data.eval.path'; account for it. + */ + + Tcl_IncrRefCount(context.data.eval.path); + } + + if (context.type == TCL_LOCATION_SOURCE) { + /* + * We can account for source location within a proc only if the + * proc body was not created by substitution. + * (FIXME: check that this is sane and correct!) + */ + + if (context.line + && (context.nline >= 4) && (context.line[3] >= 0)) { + int isNew; + CmdFrame *cfPtr = (CmdFrame *) ckalloc(sizeof(CmdFrame)); + Tcl_HashEntry *hPtr; + + cfPtr->level = -1; + cfPtr->type = context.type; + cfPtr->line = (int *) ckalloc(sizeof(int)); + cfPtr->line[0] = context.line[3]; + cfPtr->nline = 1; + cfPtr->framePtr = NULL; + cfPtr->nextPtr = NULL; + + cfPtr->data.eval.path = context.data.eval.path; + Tcl_IncrRefCount(cfPtr->data.eval.path); + + cfPtr->cmd.str.cmd = NULL; + cfPtr->cmd.str.len = 0; + + hPtr = Tcl_CreateHashEntry(iPtr->linePBodyPtr, + (char *) procPtr, &isNew); + Tcl_SetHashValue(hPtr, cfPtr); + } + + /* + * 'context' is going out of scope; account for the reference that + * it's holding to the path name. + */ + + Tcl_DecrRefCount(context.data.eval.path); + context.data.eval.path = NULL; + } + } + + return Tcl_NewInstanceMethod(interp, (Tcl_Object) oPtr, nameObj, flags, + typePtr, clientData); +} + +/* + * ---------------------------------------------------------------------- + * + * TclOOMakeProcMethod -- + * + * The guts of the code to make a procedure-like method for a class. + * Split apart so that it is easier for other extensions to reuse (in + * particular, it frees them from having to pry so deeply into Tcl's + * guts). + * + * ---------------------------------------------------------------------- + */ + +Tcl_Method +TclOOMakeProcMethod( + Tcl_Interp *interp, /* The interpreter containing the class. */ + Class *clsPtr, /* The class to modify. */ + int flags, /* 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). */ + const char *namePtr, /* The name of the method as a string, 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. */ + const Tcl_MethodType *typePtr, + /* The type of the method to create. */ + ClientData clientData, /* The per-method type-specific data. */ + Proc **procPtrPtr) /* A pointer to the variable in which to write + * the procedure record reference. Presumably + * inside the structure indicated by the + * pointer in clientData. */ +{ + Interp *iPtr = (Interp *) interp; + Proc *procPtr; + + if (TclCreateProc(interp, NULL, namePtr, argsObj, bodyObj, + procPtrPtr) != TCL_OK) { + return NULL; + } + procPtr = *procPtrPtr; + procPtr->cmdPtr = NULL; + + if (iPtr->cmdFramePtr) { + CmdFrame context = *iPtr->cmdFramePtr; + + if (context.type == TCL_LOCATION_BC) { + /* + * Retrieve source information from the bytecode, if possible. If + * the information is retrieved successfully, context.type will be + * TCL_LOCATION_SOURCE and the reference held by + * context.data.eval.path will be counted. + */ + + TclGetSrcInfoForPc(&context); + } else if (context.type == TCL_LOCATION_SOURCE) { + /* + * The copy into 'context' up above has created another reference + * to 'context.data.eval.path'; account for it. + */ + + Tcl_IncrRefCount(context.data.eval.path); + } + + if (context.type == TCL_LOCATION_SOURCE) { + /* + * We can account for source location within a proc only if the + * proc body was not created by substitution. + * (FIXME: check that this is sane and correct!) + */ + + if (context.line + && (context.nline >= 4) && (context.line[3] >= 0)) { + int isNew; + CmdFrame *cfPtr = (CmdFrame *) ckalloc(sizeof(CmdFrame)); + Tcl_HashEntry *hPtr; + + cfPtr->level = -1; + cfPtr->type = context.type; + cfPtr->line = (int *) ckalloc(sizeof(int)); + cfPtr->line[0] = context.line[3]; + cfPtr->nline = 1; + cfPtr->framePtr = NULL; + cfPtr->nextPtr = NULL; + + cfPtr->data.eval.path = context.data.eval.path; + Tcl_IncrRefCount(cfPtr->data.eval.path); + + cfPtr->cmd.str.cmd = NULL; + cfPtr->cmd.str.len = 0; + + hPtr = Tcl_CreateHashEntry(iPtr->linePBodyPtr, + (char *) procPtr, &isNew); + Tcl_SetHashValue(hPtr, cfPtr); + } + + /* + * 'context' is going out of scope; account for the reference that + * it's holding to the path name. + */ + + Tcl_DecrRefCount(context.data.eval.path); + context.data.eval.path = NULL; + } + } + + return Tcl_NewMethod(interp, (Tcl_Class) clsPtr, nameObj, flags, typePtr, + clientData); +} + +/* + * ---------------------------------------------------------------------- + * + * InvokeProcedureMethod, PushMethodCallFrame -- + * + * 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. */ +{ + ProcedureMethod *pmPtr = clientData; + int result; + register int skip; + PMFrameData *fdPtr; /* Important data that has to have a lifetime + * matched by this function (or rather, by the + * call frame's lifetime). */ + + /* + * Allocate the special frame data. + */ + + fdPtr = (PMFrameData *) TclStackAlloc(interp, sizeof(PMFrameData)); + pmPtr->refCount++; + + /* + * Create a call frame for this method. + */ + + result = PushMethodCallFrame(interp, (CallContext *) context, pmPtr, + objc, objv, fdPtr); + if (result != TCL_OK) { + goto done; + } + + /* + * Give the pre-call callback a chance to do some setup and, possibly, + * veto the call. + */ + + if (pmPtr->preCallProc != NULL) { + int isFinished; + + result = pmPtr->preCallProc(pmPtr->clientData, interp, context, + (Tcl_CallFrame *) fdPtr->framePtr, &isFinished); + if (isFinished || result != TCL_OK) { + Tcl_PopCallFrame(interp); + TclStackFree(interp, fdPtr->framePtr); + goto done; + } + } + + /* + * Now invoke the body of the method. Note that we need to take special + * action when doing unknown processing to ensure that the missing method + * name is passed as an argument. + */ + + skip = Tcl_ObjectContextSkippedArgs(context); + result = TclObjInterpProcCore(interp, fdPtr->nameObj, skip, + fdPtr->errProc); + + /* + * Give the post-call callback a chance to do some cleanup. Note that at + * this point the call frame itself is invalid; it's already been popped. + */ + + if (pmPtr->postCallProc) { + result = pmPtr->postCallProc(pmPtr->clientData, interp, context, + Tcl_GetObjectNamespace(Tcl_ObjectContextObject(context)), + result); + } + + /* + * Scrap the special frame data now that we're done with it. Note that we + * are inlining DeleteProcedureMethod() here; this location is highly + * sensitive when it comes to performance! + */ + + done: + if (--pmPtr->refCount < 1) { + DeleteProcedureMethodRecord(pmPtr); + } + TclStackFree(interp, fdPtr); + return result; +} + +static int +PushMethodCallFrame( + Tcl_Interp *interp, /* Current interpreter. */ + CallContext *contextPtr, /* Current method call context. */ + ProcedureMethod *pmPtr, /* Information about this procedure-like + * method. */ + int objc, /* Number of arguments. */ + Tcl_Obj *const *objv, /* Array of arguments. */ + PMFrameData *fdPtr) /* Place to store information about the call + * frame. */ +{ + Tcl_Namespace *nsPtr = contextPtr->oPtr->namespacePtr; + register int result; + const char *namePtr; + CallFrame **framePtrPtr = &fdPtr->framePtr; + static Tcl_ObjType *byteCodeTypePtr = NULL; /* HACK! */ + + /* + * Compute basic information on the basis of the type of method it is. + */ + + if (contextPtr->callPtr->flags & CONSTRUCTOR) { + namePtr = "<constructor>"; + fdPtr->nameObj = contextPtr->oPtr->fPtr->constructorName; + fdPtr->errProc = ConstructorErrorHandler; + } else if (contextPtr->callPtr->flags & DESTRUCTOR) { + namePtr = "<destructor>"; + fdPtr->nameObj = contextPtr->oPtr->fPtr->destructorName; + fdPtr->errProc = DestructorErrorHandler; + } else { + fdPtr->nameObj = Tcl_MethodName( + Tcl_ObjectContextMethod((Tcl_ObjectContext) contextPtr)); + namePtr = TclGetString(fdPtr->nameObj); + fdPtr->errProc = MethodErrorHandler; + } + if (pmPtr->errProc != NULL) { + fdPtr->errProc = pmPtr->errProc; + } + + /* + * Magic to enable things like [incr Tcl], which wants methods to run in + * their class's namespace. + */ + + if (pmPtr->flags & USE_DECLARER_NS) { + register Method *mPtr = + contextPtr->callPtr->chain[contextPtr->index].mPtr; + + if (mPtr->declaringClassPtr != NULL) { + nsPtr = mPtr->declaringClassPtr->thisPtr->namespacePtr; + } else { + nsPtr = mPtr->declaringObjectPtr->namespacePtr; + } + } + + /* + * Compile the body. This operation may fail. + */ + + fdPtr->efi.length = 2; + memset(&fdPtr->cmd, 0, sizeof(Command)); + fdPtr->cmd.nsPtr = (Namespace *) nsPtr; + fdPtr->cmd.clientData = &fdPtr->efi; + pmPtr->procPtr->cmdPtr = &fdPtr->cmd; + + /* Should be a reference to tclByteCodeType, but that's MODULE_SCOPE */ + if (byteCodeTypePtr == NULL || + pmPtr->procPtr->bodyPtr->typePtr != byteCodeTypePtr) { + result = TclProcCompileProc(interp, pmPtr->procPtr, + pmPtr->procPtr->bodyPtr, (Namespace *) nsPtr, + "body of method", namePtr); + if (result != TCL_OK) { + return result; + } + if (byteCodeTypePtr == NULL) { + byteCodeTypePtr = pmPtr->procPtr->bodyPtr->typePtr; + } + } + + /* + * Make the stack frame and fill it out with information about this call. + * This operation may fail. + */ + + result = TclPushStackFrame(interp, (Tcl_CallFrame **) framePtrPtr, nsPtr, + FRAME_IS_PROC|FRAME_IS_METHOD); + if (result != TCL_OK) { + return result; + } + + fdPtr->framePtr->clientData = contextPtr; + fdPtr->framePtr->objc = objc; + fdPtr->framePtr->objv = objv; + fdPtr->framePtr->procPtr = pmPtr->procPtr; + + /* + * Finish filling out the extra frame info so that [info frame] works. + */ + + fdPtr->efi.fields[0].name = "method"; + fdPtr->efi.fields[0].proc = NULL; + fdPtr->efi.fields[0].clientData = fdPtr->nameObj; + if (pmPtr->gfivProc != NULL) { + fdPtr->efi.fields[1].proc = pmPtr->gfivProc; + fdPtr->efi.fields[1].clientData = pmPtr; + } else { + register Tcl_Method method = + Tcl_ObjectContextMethod((Tcl_ObjectContext) contextPtr); + + if (Tcl_MethodDeclarerObject(method) != NULL) { + fdPtr->efi.fields[1].name = "object"; + } else { + fdPtr->efi.fields[1].name = "class"; + } + fdPtr->efi.fields[1].proc = RenderDeclarerName; + fdPtr->efi.fields[1].clientData = &fdPtr->pni; + fdPtr->pni.interp = interp; + fdPtr->pni.method = method; + } + + return TCL_OK; +} + +/* + * ---------------------------------------------------------------------- + * + * RenderDeclarerName -- + * + * Returns the name of the entity (object or class) which declared a + * method. Used for producing information for [info frame] in such a way + * that the expensive part of this (generating the object or class name + * itself) isn't done until it is needed. + * + * ---------------------------------------------------------------------- + */ + +static Tcl_Obj * +RenderDeclarerName( + ClientData clientData) +{ + struct PNI *pni = clientData; + Tcl_Object object = Tcl_MethodDeclarerObject(pni->method); + + if (object == NULL) { + object = Tcl_GetClassAsObject(Tcl_MethodDeclarerClass(pni->method)); + } + return TclOOObjectName(pni->interp, (Object *) object); +} + +/* + * ---------------------------------------------------------------------- + * + * MethodErrorHandler, ConstructorErrorHandler, DestructorErrorHandler -- + * + * How to fill in the stack trace correctly upon error in various forms + * of procedure-like methods. LIMIT is how long the inserted strings in + * the error traces should get before being converted to have ellipses, + * and ELLIPSIFY is a macro to do the conversion (with the help of a + * %.*s%s format field). Note that ELLIPSIFY is only safe for use in + * suitable formatting contexts. + * + * ---------------------------------------------------------------------- + */ + +#define LIMIT 60 +#define ELLIPSIFY(str,len) \ + ((len) > LIMIT ? LIMIT : (len)), (str), ((len) > LIMIT ? "..." : "") + +static void +MethodErrorHandler( + Tcl_Interp *interp, + Tcl_Obj *methodNameObj) +{ + int nameLen, objectNameLen; + CallContext *contextPtr = ((Interp *) interp)->varFramePtr->clientData; + Method *mPtr = contextPtr->callPtr->chain[contextPtr->index].mPtr; + const char *objectName, *kindName, *methodName = + Tcl_GetStringFromObj(mPtr->namePtr, &nameLen); + Object *declarerPtr; + + if (mPtr->declaringObjectPtr != NULL) { + declarerPtr = mPtr->declaringObjectPtr; + kindName = "object"; + } else { + if (mPtr->declaringClassPtr == NULL) { + Tcl_Panic("method not declared in class or object"); + } + declarerPtr = mPtr->declaringClassPtr->thisPtr; + kindName = "class"; + } + + objectName = Tcl_GetStringFromObj(TclOOObjectName(interp, declarerPtr), + &objectNameLen); + Tcl_AppendObjToErrorInfo(interp, Tcl_ObjPrintf( + "\n (%s \"%.*s%s\" method \"%.*s%s\" line %d)", + kindName, ELLIPSIFY(objectName, objectNameLen), + ELLIPSIFY(methodName, nameLen), interp->errorLine)); +} + +static void +ConstructorErrorHandler( + Tcl_Interp *interp, + Tcl_Obj *methodNameObj) +{ + CallContext *contextPtr = ((Interp *) interp)->varFramePtr->clientData; + Method *mPtr = contextPtr->callPtr->chain[contextPtr->index].mPtr; + Object *declarerPtr; + const char *objectName, *kindName; + int objectNameLen; + + if (interp->errorLine == 0xDEADBEEF) { + /* + * Horrible hack to deal with certain constructors that must not add + * information to the error trace. + */ + + return; + } + + if (mPtr->declaringObjectPtr != NULL) { + declarerPtr = mPtr->declaringObjectPtr; + kindName = "object"; + } else { + if (mPtr->declaringClassPtr == NULL) { + Tcl_Panic("method not declared in class or object"); + } + declarerPtr = mPtr->declaringClassPtr->thisPtr; + kindName = "class"; + } + + objectName = Tcl_GetStringFromObj(TclOOObjectName(interp, declarerPtr), + &objectNameLen); + Tcl_AppendObjToErrorInfo(interp, Tcl_ObjPrintf( + "\n (%s \"%.*s%s\" constructor line %d)", kindName, + ELLIPSIFY(objectName, objectNameLen), interp->errorLine)); +} + +static void +DestructorErrorHandler( + Tcl_Interp *interp, + Tcl_Obj *methodNameObj) +{ + CallContext *contextPtr = ((Interp *) interp)->varFramePtr->clientData; + Method *mPtr = contextPtr->callPtr->chain[contextPtr->index].mPtr; + Object *declarerPtr; + const char *objectName, *kindName; + int objectNameLen; + + if (mPtr->declaringObjectPtr != NULL) { + declarerPtr = mPtr->declaringObjectPtr; + kindName = "object"; + } else { + if (mPtr->declaringClassPtr == NULL) { + Tcl_Panic("method not declared in class or object"); + } + declarerPtr = mPtr->declaringClassPtr->thisPtr; + kindName = "class"; + } + + objectName = Tcl_GetStringFromObj(TclOOObjectName(interp, declarerPtr), + &objectNameLen); + Tcl_AppendObjToErrorInfo(interp, Tcl_ObjPrintf( + "\n (%s \"%.*s%s\" destructor line %d)", kindName, + ELLIPSIFY(objectName, objectNameLen), interp->errorLine)); +} + +/* + * ---------------------------------------------------------------------- + * + * DeleteProcedureMethod, CloneProcedureMethod -- + * + * How to delete and clone procedure-like methods. + * + * ---------------------------------------------------------------------- + */ + +static void +DeleteProcedureMethodRecord( + ProcedureMethod *pmPtr) +{ + TclProcDeleteProc(pmPtr->procPtr); + if (pmPtr->deleteClientdataProc) { + pmPtr->deleteClientdataProc(pmPtr->clientData); + } + ckfree((char *) pmPtr); +} + +static void +DeleteProcedureMethod( + ClientData clientData) +{ + register ProcedureMethod *pmPtr = clientData; + + if (--pmPtr->refCount < 1) { + DeleteProcedureMethodRecord(pmPtr); + } +} + +static int +CloneProcedureMethod( + Tcl_Interp *interp, + ClientData clientData, + ClientData *newClientData) +{ + ProcedureMethod *pmPtr = clientData; + ProcedureMethod *pm2Ptr = (ProcedureMethod *) + ckalloc(sizeof(ProcedureMethod)); + + memcpy(pm2Ptr, pmPtr, sizeof(ProcedureMethod)); + pm2Ptr->refCount = 1; + pm2Ptr->procPtr->refCount++; + if (pmPtr->cloneClientdataProc) { + pm2Ptr->clientData = pmPtr->cloneClientdataProc(pmPtr->clientData); + } + *newClientData = pm2Ptr; + return TCL_OK; +} + +/* + * ---------------------------------------------------------------------- + * + * TclOONewForwardMethod -- + * + * Create a forwarded method for an object. + * + * ---------------------------------------------------------------------- + */ + +Method * +TclOONewForwardInstanceMethod( + Tcl_Interp *interp, /* Interpreter for error reporting. */ + Object *oPtr, /* The object to attach the method to. */ + int flags, /* 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_NewInstanceMethod(interp, (Tcl_Object) oPtr, + nameObj, flags, &fwdMethodType, fmPtr); +} + +/* + * ---------------------------------------------------------------------- + * + * TclOONewForwardMethod -- + * + * Create a new forwarded method for a class. + * + * ---------------------------------------------------------------------- + */ + +Method * +TclOONewForwardMethod( + Tcl_Interp *interp, /* Interpreter for error reporting. */ + Class *clsPtr, /* The class to attach the method to. */ + int flags, /* 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_Class) clsPtr, nameObj, + flags, &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 = clientData; + Tcl_Obj **argObjs, **prefixObjs; + int numPrefixes, result, len, skip = contextPtr->skip; + + /* + * 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, skip, + numPrefixes, prefixObjs, &len); + + result = Tcl_EvalObjv(interp, len, argObjs, TCL_EVAL_INVOKE); + TclStackFree(interp, argObjs); + return result; +} + +/* + * ---------------------------------------------------------------------- + * + * DeleteForwardMethod, CloneForwardMethod -- + * + * How to delete and clone forwarded methods. + * + * ---------------------------------------------------------------------- + */ + +static void +DeleteForwardMethod( + ClientData clientData) +{ + ForwardMethod *fmPtr = clientData; + + Tcl_DecrRefCount(fmPtr->prefixObj); + ckfree((char *) fmPtr); +} + +static int +CloneForwardMethod( + Tcl_Interp *interp, + ClientData clientData, + ClientData *newClientData) +{ + ForwardMethod *fmPtr = clientData; + ForwardMethod *fm2Ptr = (ForwardMethod *) ckalloc(sizeof(ForwardMethod)); + + fm2Ptr->prefixObj = fmPtr->prefixObj; + Tcl_IncrRefCount(fm2Ptr->prefixObj); + *newClientData = fm2Ptr; + return TCL_OK; +} + +/* + * ---------------------------------------------------------------------- + * + * 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 = TclStackAlloc(interp, 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; +} + +/* + * ---------------------------------------------------------------------- + * + * assorted trivial 'getter' functions + * + * ---------------------------------------------------------------------- + */ + +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; +} + +/* + * Extended method construction for itcl-ng. + */ + +Tcl_Method +TclOONewProcInstanceMethodEx( + Tcl_Interp *interp, /* The interpreter containing the object. */ + Tcl_Object oPtr, /* The object to modify. */ + TclOO_PreCallProc preCallPtr, + TclOO_PostCallProc postCallPtr, + ProcErrorProc errProc, + ClientData clientData, + 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 flags, /* Whether this is a public method. */ + void **internalTokenPtr) /* If non-NULL, points to a variable that gets + * the reference to the ProcedureMethod + * structure. */ +{ + ProcedureMethod *pmPtr; + Tcl_Method method = (Tcl_Method) TclOONewProcInstanceMethod(interp, + (Object *) oPtr, flags, nameObj, argsObj, bodyObj, &pmPtr); + + if (method == NULL) { + return NULL; + } + pmPtr->flags = flags & USE_DECLARER_NS; + pmPtr->preCallProc = preCallPtr; + pmPtr->postCallProc = postCallPtr; + pmPtr->errProc = errProc; + pmPtr->clientData = clientData; + if (internalTokenPtr != NULL) { + *internalTokenPtr = pmPtr; + } + return method; +} + +Tcl_Method +TclOONewProcMethodEx( + Tcl_Interp *interp, /* The interpreter containing the class. */ + Tcl_Class clsPtr, /* The class to modify. */ + TclOO_PreCallProc preCallPtr, + TclOO_PostCallProc postCallPtr, + ProcErrorProc errProc, + ClientData clientData, + 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 flags, /* Whether this is a public method. */ + void **internalTokenPtr) /* If non-NULL, points to a variable that gets + * the reference to the ProcedureMethod + * structure. */ +{ + ProcedureMethod *pmPtr; + Tcl_Method method = (Tcl_Method) TclOONewProcMethod(interp, + (Class *) clsPtr, flags, nameObj, argsObj, bodyObj, &pmPtr); + + if (method == NULL) { + return NULL; + } + pmPtr->flags = flags & USE_DECLARER_NS; + pmPtr->preCallProc = preCallPtr; + pmPtr->postCallProc = postCallPtr; + pmPtr->errProc = errProc; + pmPtr->clientData = clientData; + if (internalTokenPtr != NULL) { + *internalTokenPtr = pmPtr; + } + return method; +} + +/* + * Local Variables: + * mode: c + * c-basic-offset: 4 + * fill-column: 78 + * End: + */ diff --git a/generic/tclOOStubInit.c b/generic/tclOOStubInit.c new file mode 100644 index 0000000..b49dc12 --- /dev/null +++ b/generic/tclOOStubInit.c @@ -0,0 +1,79 @@ +/* + * $Id: tclOOStubInit.c,v 1.1 2008/05/31 11:42:19 dkf Exp $ + * + * This file is (mostly) automatically generated from tclOO.decls. + * It is compiled and linked in with the tclOO package proper. + */ + +#ifdef HAVE_CONFIG_H +#include "config.h" +#endif +#include "tclOO.h" +#include "tclOOInt.h" + +/* !BEGIN!: Do not edit below this line. */ + +TclOOStubs tclOOStubs = { + TCL_STUB_MAGIC, + TCLOO_STUBS_EPOCH, + TCLOO_STUBS_REVISION, + 0, + Tcl_CopyObjectInstance, /* 0 */ + Tcl_GetClassAsObject, /* 1 */ + Tcl_GetObjectAsClass, /* 2 */ + Tcl_GetObjectCommand, /* 3 */ + Tcl_GetObjectFromObj, /* 4 */ + Tcl_GetObjectNamespace, /* 5 */ + Tcl_MethodDeclarerClass, /* 6 */ + Tcl_MethodDeclarerObject, /* 7 */ + Tcl_MethodIsPublic, /* 8 */ + Tcl_MethodIsType, /* 9 */ + Tcl_MethodName, /* 10 */ + Tcl_NewInstanceMethod, /* 11 */ + Tcl_NewMethod, /* 12 */ + Tcl_NewObjectInstance, /* 13 */ + Tcl_ObjectDeleted, /* 14 */ + Tcl_ObjectContextIsFiltering, /* 15 */ + Tcl_ObjectContextMethod, /* 16 */ + Tcl_ObjectContextObject, /* 17 */ + Tcl_ObjectContextSkippedArgs, /* 18 */ + Tcl_ClassGetMetadata, /* 19 */ + Tcl_ClassSetMetadata, /* 20 */ + Tcl_ObjectGetMetadata, /* 21 */ + Tcl_ObjectSetMetadata, /* 22 */ + Tcl_ObjectContextInvokeNext, /* 23 */ + Tcl_ObjectGetMethodNameMapper, /* 24 */ + Tcl_ObjectSetMethodNameMapper, /* 25 */ + Tcl_ClassSetConstructor, /* 26 */ + Tcl_ClassSetDestructor, /* 27 */ +}; + +TclOOIntStubs tclOOIntStubs = { + TCL_STUB_MAGIC, + TCLOOINT_STUBS_EPOCH, + TCLOOINT_STUBS_REVISION, + 0, + TclOOGetDefineCmdContext, /* 0 */ + TclOOMakeProcInstanceMethod, /* 1 */ + TclOOMakeProcMethod, /* 2 */ + TclOONewProcInstanceMethod, /* 3 */ + TclOONewProcMethod, /* 4 */ + TclOOObjectCmdCore, /* 5 */ + TclOOIsReachable, /* 6 */ + TclOONewForwardMethod, /* 7 */ + TclOONewForwardInstanceMethod, /* 8 */ + TclOONewProcInstanceMethodEx, /* 9 */ + TclOONewProcMethodEx, /* 10 */ + TclOOInvokeObject, /* 11 */ + TclOOObjectSetFilters, /* 12 */ + TclOOClassSetFilters, /* 13 */ + TclOOObjectSetMixins, /* 14 */ + TclOOClassSetMixins, /* 15 */ +}; + +/* !END!: Do not edit above this line. */ + +struct TclOOStubAPI tclOOStubAPI = { + &tclOOStubs, + &tclOOIntStubs +}; diff --git a/generic/tclOOStubLib.c b/generic/tclOOStubLib.c new file mode 100644 index 0000000..6988638 --- /dev/null +++ b/generic/tclOOStubLib.c @@ -0,0 +1,82 @@ +/* + * $Id: tclOOStubLib.c,v 1.1 2008/05/31 11:42:19 dkf Exp $ + * ORIGINAL SOURCE: tk/generic/tkStubLib.c, version 1.9 2004/03/17 + */ + +#ifdef HAVE_CONFIG_H +#include "config.h" +#endif +#include "tcl.h" + +#define USE_TCLOO_STUBS 1 +#include "tclOO.h" +#include "tclOOInt.h" + +const TclOOStubs *tclOOStubsPtr; +const TclOOIntStubs *tclOOIntStubsPtr; + +/* + *---------------------------------------------------------------------- + * + * TclOOInitializeStubs -- + * Load the tclOO package, initialize stub table pointer. Do not call + * this function directly, use Tcl_OOInitStubs() macro instead. + * + * Results: + * The actual version of the package that satisfies the request, or NULL + * to indicate that an error occurred. + * + * Side effects: + * Sets the stub table pointer. + * + */ + +const char *TclOOInitializeStubs( + Tcl_Interp *interp, const char *version, int epoch, int revision) +{ + int exact = 0; + const char *packageName = "TclOO"; + const char *errMsg = NULL; + ClientData clientData = NULL; + const char *actualVersion = + Tcl_PkgRequireEx(interp, packageName,version, exact, &clientData); + struct TclOOStubAPI *stubsAPIPtr = clientData; + + if (stubsAPIPtr == NULL) { + Tcl_ResetResult(interp); + Tcl_AppendResult(interp, "Error loading ", packageName, " package; ", + "package not present or incomplete", NULL); + return NULL; + } else { + TclOOStubs *stubsPtr = stubsAPIPtr->stubsPtr; + TclOOIntStubs *intStubsPtr = stubsAPIPtr->intStubsPtr; + + if (!actualVersion) { + return NULL; + } + + if (!stubsPtr || !intStubsPtr) { + errMsg = "missing stub table pointer"; + goto error; + } + if (stubsPtr->epoch != epoch || intStubsPtr->epoch != epoch) { + errMsg = "epoch number mismatch"; + goto error; + } + if (stubsPtr->revision<revision || intStubsPtr->revision<revision) { + errMsg = "require later revision"; + goto error; + } + + tclOOStubsPtr = stubsPtr; + tclOOIntStubsPtr = intStubsPtr; + return actualVersion; + + error: + Tcl_ResetResult(interp); + Tcl_AppendResult(interp, "Error loading ", packageName, " package", + " (requested version '", version, "', loaded version '", + actualVersion, "'): ", errMsg, NULL); + return NULL; + } +} diff --git a/tests/info.test b/tests/info.test index a6fa48d..b6b708c 100644 --- a/tests/info.test +++ b/tests/info.test @@ -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: info.test,v 1.47 2007/12/13 15:26:06 dgp Exp $ +# RCS: @(#) $Id: info.test,v 1.48 2008/05/31 11:42:20 dkf Exp $ if {[lsearch [namespace children] ::tcltest] == -1} { package require tcltest 2 @@ -675,16 +675,16 @@ test info-21.1 {miscellaneous error conditions} -returnCodes error -body { } -result {wrong # args: should be "info subcommand ?argument ...?"} test info-21.2 {miscellaneous error conditions} -returnCodes error -body { info gorp -} -result {unknown or ambiguous subcommand "gorp": must be args, body, cmdcount, commands, complete, default, exists, frame, functions, globals, hostname, level, library, loaded, locals, nameofexecutable, patchlevel, procs, script, sharedlibextension, tclversion, or vars} +} -result {unknown or ambiguous subcommand "gorp": must be args, body, class, cmdcount, commands, complete, default, exists, frame, functions, globals, hostname, level, library, loaded, locals, nameofexecutable, object, patchlevel, procs, script, sharedlibextension, tclversion, or vars} test info-21.3 {miscellaneous error conditions} -returnCodes error -body { info c -} -result {unknown or ambiguous subcommand "c": must be args, body, cmdcount, commands, complete, default, exists, frame, functions, globals, hostname, level, library, loaded, locals, nameofexecutable, patchlevel, procs, script, sharedlibextension, tclversion, or vars} +} -result {unknown or ambiguous subcommand "c": must be args, body, class, cmdcount, commands, complete, default, exists, frame, functions, globals, hostname, level, library, loaded, locals, nameofexecutable, object, patchlevel, procs, script, sharedlibextension, tclversion, or vars} test info-21.4 {miscellaneous error conditions} -returnCodes error -body { info l -} -result {unknown or ambiguous subcommand "l": must be args, body, cmdcount, commands, complete, default, exists, frame, functions, globals, hostname, level, library, loaded, locals, nameofexecutable, patchlevel, procs, script, sharedlibextension, tclversion, or vars} +} -result {unknown or ambiguous subcommand "l": must be args, body, class, cmdcount, commands, complete, default, exists, frame, functions, globals, hostname, level, library, loaded, locals, nameofexecutable, object, patchlevel, procs, script, sharedlibextension, tclversion, or vars} test info-21.5 {miscellaneous error conditions} -returnCodes error -body { info s -} -result {unknown or ambiguous subcommand "s": must be args, body, cmdcount, commands, complete, default, exists, frame, functions, globals, hostname, level, library, loaded, locals, nameofexecutable, patchlevel, procs, script, sharedlibextension, tclversion, or vars} +} -result {unknown or ambiguous subcommand "s": must be args, body, class, cmdcount, commands, complete, default, exists, frame, functions, globals, hostname, level, library, loaded, locals, nameofexecutable, object, patchlevel, procs, script, sharedlibextension, tclversion, or vars} ## # ### ### ### ######### ######### ######### diff --git a/tests/interp.test b/tests/interp.test index 76d642b..2bbd7a3 100644 --- a/tests/interp.test +++ b/tests/interp.test @@ -10,7 +10,7 @@ # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # -# RCS: @(#) $Id: interp.test,v 1.54 2008/03/02 19:12:41 msofer Exp $ +# RCS: @(#) $Id: interp.test,v 1.55 2008/05/31 11:42:20 dkf Exp $ if {[lsearch [namespace children] ::tcltest] == -1} { package require tcltest 2.1 @@ -2360,22 +2360,23 @@ test interp-28.1 {getting fooled by slave's namespace ?} { set r } {} -test interp-28.2 {master's nsName cache should not cross} { +test interp-28.2 {master's nsName cache should not cross} -setup { set i [interp create] - set res [$i eval { +} -body { + $i eval { set x {namespace children ::} set y [list namespace children ::] - namespace delete [{*}$y] + namespace delete {*}[{*}$y] set j [interp create] $j eval {namespace delete {*}[namespace children ::]} namespace eval foo {} set res [list [eval $x] [eval $y] [$j eval $x] [$j eval $y]] interp delete $j set res - }] + } +} -cleanup { interp delete $i - set res -} {::foo ::foo {} {}} +} -result {::foo ::foo {} {}} # Part 29: recursion limit # 29.1.* Argument checking diff --git a/tests/oo.test b/tests/oo.test new file mode 100644 index 0000000..087e786 --- /dev/null +++ b/tests/oo.test @@ -0,0 +1,1769 @@ +# This file contains a collection of tests for Tcl's built-in object system. +# Sourcing this file into Tcl runs the tests and generates output for errors. +# No output means no errors were found. +# +# Copyright (c) 2006-2008 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: oo.test,v 1.4 2008/05/31 11:42:20 dkf Exp $ + +package require TclOO 0.4 ;# Must match value in configure.in +if {[lsearch [namespace children] ::tcltest] == -1} { + package require tcltest 2 + namespace import -force ::tcltest::* +} + +testConstraint memory [llength [info commands memory]] +if {[testConstraint memory]} { + proc getbytes {} { + set lines [split [memory info] \n] + return [lindex $lines 3 3] + } + proc leaktest {script {iterations 3}} { + set end [getbytes] + for {set i 0} {$i < $iterations} {incr i} { + uplevel 1 $script + set tmp $end + set end [getbytes] + } + return [expr {$end - $tmp}] + } +} + +proc initInterpreter name { + $name eval [list package ifneeded TclOO [package provide TclOO] \ + [package ifneeded TclOO [package provide TclOO]]] +} + +test oo-0.1 {basic test of OO's ability to clean up its initial state} { + interp create t + initInterpreter t + t eval { + package require TclOO + } + interp delete t +} {} +test oo-0.2 {basic test of OO's ability to clean up its initial state} { + set i [interp create] + initInterpreter $i + interp eval $i { + package require TclOO + namespace delete :: + } +} {} +test oo-0.3 {basic test of OO's ability to clean up its initial state} -body { + leaktest { + [oo::object new] destroy + } +} -constraints memory -result 0 +test oo-0.4 {basic test of OO's ability to clean up its initial state} -body { + leaktest { + oo::class create foo + foo new + foo destroy + } +} -constraints memory -result 0 + +test oo-1.1 {basic test of OO functionality: no classes} { + set result {} + lappend result [oo::object create foo] + lappend result [oo::objdefine foo { + method bar args { + global result + lappend result {*}$args + return [llength $args] + } + }] + lappend result [foo bar a b c] + lappend result [foo destroy] [info commands foo] +} {::foo {} a b c 3 {} {}} +test oo-1.2 {basic test of OO functionality: no classes} -body { + oo::define oo::object method missingArgs +} -returnCodes 1 -result "wrong # args: should be \"oo::define oo::object method name args body\"" +test oo-1.3 {basic test of OO functionality: no classes} { + catch {oo::define oo::object method missingArgs} + set errorInfo +} "wrong # args: should be \"oo::define oo::object method name args body\" + while executing +\"oo::define oo::object method missingArgs\"" +test oo-1.4 {basic test of OO functionality} -body { + oo::object create {} +} -returnCodes 1 -result {object name must not be empty} +test oo-1.5 {basic test of OO functionality} -body { + oo::object doesnotexist +} -returnCodes 1 -result {unknown method "doesnotexist": must be create, destroy or new} +test oo-1.6 {basic test of OO functionality} -setup { + oo::object create aninstance +} -body { + oo::objdefine aninstance unexport destroy + aninstance doesnotexist +} -cleanup { + rename aninstance {} +} -returnCodes 1 -result {object "::aninstance" has no visible methods} +test oo-1.7 {basic test of OO functionality} -setup { + oo::object create aninstance +} -body { + oo::objdefine aninstance { + # Do not do this in real code! Ever! This is *not* supported! + ::oo::define::method ha ha ha + } +} -returnCodes error -cleanup { + aninstance destroy +} -result {attempt to misuse API} +test oo-1.8 {basic test of OO functionality} -setup { + oo::object create obj + set result {} +} -cleanup { + obj destroy +} -body { + oo::objdefine obj method foo {} {return bar} + lappend result [obj foo] + oo::objdefine obj method foo {} {} + lappend result [obj foo] +} -result {bar {}} +test oo-1.9 {basic test of OO functionality} -setup { + oo::object create a + oo::object create b +} -cleanup { + catch {a destroy} + b destroy +} -body { + oo::objdefine a method foo {} { return A } + oo::objdefine b method foo {} { return B } + apply {{} { + set m foo + return [a $m],[a destroy],[b $m] + }} +} -result A,,B +test oo-1.10 {basic test of OO functionality} -body { + namespace eval foo { + namespace eval bar { + oo::object create o + namespace export o + } + namespace import bar::o + } + list [info object isa object foo::bar::o] [info object isa object foo::o] +} -cleanup { + namespace delete foo +} -result {1 1} +test oo-1.11 {basic test of OO functionality: abbreviating} -setup { + oo::class create c +} -cleanup { + c destroy +} -body { + oo::define c super oo::class + info class super c +} -result ::oo::class +test oo-1.12 {basic test of OO functionality: abbreviating} -setup { + oo::class create c +} -cleanup { + c destroy +} -body { + oo::define c {super oo::class} + info class super c +} -result ::oo::class +test oo-1.13 {basic test of OO functionality: abbreviating} -setup { + oo::class create c +} -cleanup { + c destroy +} -body { + oo::define c self {forw a b} + info object forw c a +} -result b +test oo-1.14 {basic test of OO functionality: abbreviating} -setup { + oo::class create c +} -cleanup { + c destroy +} -body { + oo::define c self forw a b + info object forw c a +} -result b +test oo-1.15 {basic test of OO functionality: abbreviating} -setup { + oo::object create o +} -cleanup { + o destroy +} -body { + oo::objdefine o {forw a b} + info object forw o a +} -result b +test oo-1.16 {basic test of OO functionality: abbreviating} -setup { + oo::object create o +} -cleanup { + o destroy +} -body { + oo::objdefine o forw a b + info object forw o a +} -result b + +test oo-2.1 {basic test of OO functionality: constructor} -setup { + # This is a bit complex because it needs to run in a sub-interp as + # we're modifying the root object class's constructor + interp create subinterp + initInterpreter subinterp + subinterp eval { + package require TclOO + } +} -body { + subinterp eval { + oo::define oo::object constructor {} { + lappend ::result [info level 0] + } + lappend result 1 + lappend result 2 [oo::object create foo] + } +} -cleanup { + interp delete subinterp +} -result {1 {oo::object create foo} 2 ::foo} +test oo-2.2 {basic test of OO functionality: constructor} { + oo::class create testClass { + constructor {} { + global result + lappend result "[self]->construct" + } + method bar {} { + global result + lappend result "[self]->bar" + } + } + set result {} + [testClass create foo] bar + testClass destroy + return $result +} {::foo->construct ::foo->bar} + +test oo-3.1 {basic test of OO functionality: destructor} -setup { + # This is a bit complex because it needs to run in a sub-interp as + # we're modifying the root object class's constructor + interp create subinterp + initInterpreter subinterp + subinterp eval { + package require TclOO + } +} -body { + subinterp eval { + oo::define oo::object destructor { + lappend ::result died + } + lappend result 1 [oo::object create foo] + lappend result 2 [rename foo {}] + oo::define oo::object destructor {} + return $result + } +} -cleanup { + interp delete subinterp +} -result {1 ::foo died 2 {}} +test oo-3.2 {basic test of OO functionality: destructor} -setup { + # This is a bit complex because it needs to run in a sub-interp as + # we're modifying the root object class's constructor + interp create subinterp + initInterpreter subinterp + subinterp eval { + package require TclOO + } +} -body { + subinterp eval { + oo::define oo::object destructor { + lappend ::result died + } + lappend result 1 [oo::object create foo] + lappend result 2 [rename foo {}] + } +} -cleanup { + interp delete subinterp +} -result {1 ::foo died 2 {}} + +test oo-4.1 {basic test of OO functionality: export} { + set o [oo::object new] + set result {} + oo::objdefine $o method Foo {} {lappend ::result Foo; return} + lappend result [catch {$o Foo} msg] $msg + oo::objdefine $o export Foo + lappend result [$o Foo] [$o destroy] +} {1 {unknown method "Foo": must be destroy} Foo {} {}} +test oo-4.2 {basic test of OO functionality: unexport} { + set o [oo::object new] + set result {} + oo::objdefine $o method foo {} {lappend ::result foo; return} + lappend result [$o foo] + oo::objdefine $o unexport foo + lappend result [catch {$o foo} msg] $msg [$o destroy] +} {foo {} 1 {unknown method "foo": must be destroy} {}} +test oo-4.3 {exporting and error messages, Bug 1824958} -setup { + oo::class create testClass +} -cleanup { + testClass destroy +} -body { + oo::define testClass self export Bad + testClass Bad +} -returnCodes 1 -result {unknown method "Bad": must be create, destroy or new} +test oo-4.4 {exporting a class method from an object} -setup { + oo::class create testClass + testClass create testObject +} -cleanup { + testClass destroy +} -body { + oo::define testClass method Good {} { return ok } + oo::objdefine testObject export Good + testObject Good +} -result ok + +test oo-5.1 {OO: manipulation of classes as objects} -setup { + set obj [oo::object new] +} -body { + oo::objdefine oo::object method foo {} { return "in object" } + catch {$obj foo} result + list [catch {$obj foo} result] $result [oo::object foo] +} -cleanup { + oo::objdefine oo::object deletemethod foo + $obj destroy +} -result {1 {unknown method "foo": must be destroy} {in object}} +test oo-5.2 {OO: manipulation of classes as objects} -setup { + set obj [oo::object new] +} -body { + oo::define oo::object self method foo {} { return "in object" } + catch {$obj foo} result + list [catch {$obj foo} result] $result [oo::object foo] +} -cleanup { + oo::objdefine oo::object deletemethod foo + $obj destroy +} -result {1 {unknown method "foo": must be destroy} {in object}} +test oo-5.3 {OO: manipulation of classes as objects} -setup { + set obj [oo::object new] +} -body { + oo::objdefine oo::object { + method foo {} { return "in object" } + } + catch {$obj foo} result + list [catch {$obj foo} result] $result [oo::object foo] +} -cleanup { + oo::objdefine oo::object deletemethod foo + $obj destroy +} -result {1 {unknown method "foo": must be destroy} {in object}} +test oo-5.4 {OO: manipulation of classes as objects} -setup { + set obj [oo::object new] +} -body { + oo::define oo::object { + self method foo {} { return "in object" } + } + catch {$obj foo} result + list [catch {$obj foo} result] $result [oo::object foo] +} -cleanup { + oo::objdefine oo::object deletemethod foo + $obj destroy +} -result {1 {unknown method "foo": must be destroy} {in object}} +test oo-5.5 {OO: manipulation of classes as objects} -setup { + set obj [oo::object new] +} -body { + oo::define oo::object { + self { + method foo {} { return "in object" } + } + } + catch {$obj foo} result + list [catch {$obj foo} result] $result [oo::object foo] +} -cleanup { + oo::objdefine oo::object deletemethod foo + $obj destroy +} -result {1 {unknown method "foo": must be destroy} {in object}} + +test oo-6.1 {OO: forward} { + oo::object create foo + oo::objdefine foo { + forward a lappend + forward b lappend result + } + set result {} + foo a result 1 + foo b 2 + foo destroy + return $result +} {1 2} + +test oo-7.1 {OO: inheritance 101} -setup { + oo::class create superClass + oo::class create subClass + subClass create instance +} -body { + oo::define superClass method doit x {lappend ::result $x} + oo::define subClass superclass superClass + set result [list [catch {subClass doit bad} msg] $msg] + instance doit ok + return $result +} -cleanup { + subClass destroy + superClass destroy +} -result {1 {unknown method "doit": must be create, destroy or new} ok} +test oo-7.2 {OO: inheritance 101} -setup { + oo::class create superClass + oo::class create subClass + subClass create instance +} -body { + oo::define superClass method doit x { + lappend ::result |$x| + } + oo::define subClass superclass superClass + oo::objdefine instance method doit x { + lappend ::result =$x= + next [incr x] + } + set result {} + instance doit 1 + return $result +} -cleanup { + subClass destroy + superClass destroy +} -result {=1= |2|} +test oo-7.3 {OO: inheritance 101} -setup { + oo::class create superClass + oo::class create subClass + subClass create instance +} -body { + oo::define superClass method doit x { + lappend ::result |$x| + } + oo::define subClass { + superclass superClass + method doit x {lappend ::result -$x-; next [incr x]} + } + oo::objdefine instance method doit x { + lappend ::result =$x=; + next [incr x] + } + set result {} + instance doit 1 + return $result +} -cleanup { + subClass destroy + superClass destroy +} -result {=1= -2- |3|} +test oo-7.4 {OO: inheritance from oo::class} -body { + oo::class create meta { + superclass oo::class + self { + unexport create new + method make {x {definitions {}}} { + if {![string match ::* $x]} { + set ns [uplevel 1 {::namespace current}] + set x ${ns}::$x + } + set o [my create $x] + lappend ::result "made $o" + oo::define $o $definitions + return $o + } + } + } + set result [list [catch {meta create foo} msg] $msg] + lappend result [meta make classinstance { + lappend ::result "in definition script in [namespace current]" + }] + lappend result [classinstance create instance] +} -cleanup { + catch {classinstance destroy} + catch {meta destroy} +} -result {1 {unknown method "create": must be destroy or make} {made ::classinstance} {in definition script in ::oo::define} ::classinstance ::instance} +test oo-7.5 {OO: inheritance from oo::class in the secondary chain} -body { + oo::class create other + oo::class create meta { + superclass other oo::class + self { + unexport create new + method make {x {definitions {}}} { + if {![string match ::* $x]} { + set ns [uplevel 1 {::namespace current}] + set x ${ns}::$x + } + set o [my create $x] + lappend ::result "made $o" + oo::define $o $definitions + return $o + } + } + } + set result [list [catch {meta create foo} msg] $msg] + lappend result [meta make classinstance { + lappend ::result "in definition script in [namespace current]" + }] + lappend result [classinstance create instance] +} -cleanup { + catch {classinstance destroy} + catch {meta destroy} + catch {other destroy} +} -result {1 {unknown method "create": must be destroy or make} {made ::classinstance} {in definition script in ::oo::define} ::classinstance ::instance} +test oo-7.6 {OO: inheritance 101 - overridden methods should be oblivious} -setup { + oo::class create Aclass + oo::class create Bclass + Bclass create Binstance +} -body { + oo::define Aclass { + method incr {var step} { + upvar 1 $var v + ::incr v $step + } + } + oo::define Bclass { + superclass Aclass + method incr {var {step 1}} { + global result + lappend result $var $step + set r [next $var $step] + lappend result returning:$r + return $r + } + } + set result {} + set x 10 + lappend result x=$x + lappend result [Binstance incr x] + lappend result x=$x +} -result {x=10 x 1 returning:11 11 x=11} -cleanup { + Aclass destroy +} +test oo-7.7 {OO: inheritance and errorInfo} -setup { + oo::class create A + oo::class create B + B create c +} -body { + oo::define A method foo {} {error foo!} + oo::define B { + superclass A + method foo {} { next } + } + oo::objdefine c method foo {} { next } + catch {c ?} msg + set result [list $msg] + catch {c foo} msg + lappend result $msg $errorInfo +} -cleanup { + A destroy +} -result {{unknown method "?": must be destroy or foo} foo! {foo! + while executing +"error foo!" + (class "::A" method "foo" line 1) + invoked from within +"next " + (class "::B" method "foo" line 1) + invoked from within +"next " + (object "::c" method "foo" line 1) + invoked from within +"c foo"}} +test oo-7.8 {OO: next at the end of the method chain} { + oo::class create foo { + method bar {} {lappend ::result [next] foo} + } + oo::class create foo2 { + superclass foo + method bar {} {lappend ::result [next] foo2} + } + set o [foo2 new] + set ::result "" + catch {$o bar} + foo destroy + return $result +} {{} foo {{} foo} foo2} + +test oo-8.1 {OO: global must work in methods} { + oo::object create foo + oo::objdefine foo method bar x {global result; lappend result $x} + set result {} + foo bar this + foo bar is + lappend result a + foo bar test + foo destroy + return $result +} {this is a test} + +test oo-9.1 {OO: multiple inheritance} -setup { + oo::class create A + oo::class create B + oo::class create C + oo::class create D + D create foo +} -body { + oo::define A method test {} {lappend ::result A; return ok} + oo::define B { + superclass A + method test {} {lappend ::result B; next} + } + oo::define C { + superclass A + method test {} {lappend ::result C; next} + } + oo::define D { + superclass B C + method test {} {lappend ::result D; next} + } + set result {} + lappend result [foo test] +} -cleanup { + D destroy + C destroy + B destroy + A destroy +} -result {D B C A ok} +test oo-9.2 {OO: multiple inheritance} -setup { + oo::class create A + oo::class create B + oo::class create C + oo::class create D + D create foo +} -body { + oo::define A method test {} {lappend ::result A; return ok} + oo::define B { + superclass A + method test {} {lappend ::result B; next} + } + oo::define C { + superclass A + method test {} {lappend ::result C; next} + } + oo::define D { + superclass B C + method test {} {lappend ::result D; next} + } + set result {} + lappend result [foo test] +} -cleanup { + A destroy +} -result {D B C A ok} + +test oo-10.1 {OO: recursive invoke and modify} -setup { + [oo::class create C] create O +} -cleanup { + C destroy +} -body { + oo::define C method foo x { + lappend ::result $x + if {$x} { + [self object] foo [incr x -1] + } + } + oo::objdefine O method foo x { + lappend ::result -$x- + if {$x == 1} { + oo::objdefine O deletemethod foo + } + next $x + } + set result {} + O foo 2 + return $result +} -result {-2- 2 -1- 1 0} +test oo-10.2 {OO: recursive invoke and modify} -setup { + oo::object create O +} -cleanup { + O destroy +} -body { + oo::objdefine O method foo {} { + oo::objdefine [self] method foo {} { + error "not called" + } + return [format %s%s call ed] + } + O foo +} -result called +test oo-10.3 {OO: invoke and modify} -setup { + oo::class create A { + method a {} {return A.a} + method b {} {return A.b} + method c {} {return A.c} + } + oo::class create B { + superclass A + method a {} {return [next],B.a} + method b {} {return [next],B.b} + method c {} {return [next],B.c} + } + B create C + set result {} +} -cleanup { + A destroy +} -body { + lappend result [C a] [C b] [C c] - + oo::define B deletemethod b + lappend result [C a] [C b] [C c] - + oo::define B renamemethod a b + lappend result [C a] [C b] [C c] - + oo::define B deletemethod b c + lappend result [C a] [C b] [C c] +} -result {A.a,B.a A.b,B.b A.c,B.c - A.a,B.a A.b A.c,B.c - A.a A.b,B.a A.c,B.c - A.a A.b A.c} + +test oo-11.1 {OO: cleanup} { + oo::object create foo + set result [list [catch {oo::object create foo} msg] $msg] + lappend result [foo destroy] [oo::object create foo] [foo destroy] +} {1 {can't create object "foo": command already exists with that name} {} ::foo {}} +test oo-11.2 {OO: cleanup} { + oo::class create bar + bar create foo + set result [list [catch {bar create foo} msg] $msg] + lappend result [bar destroy] [oo::object create foo] [foo destroy] +} {1 {can't create object "foo": command already exists with that name} {} ::foo {}} +test oo-11.3 {OO: cleanup} { + oo::class create bar0 + oo::class create bar + oo::define bar superclass bar0 + bar create foo + set result [list [catch {bar create foo} msg] $msg] + lappend result [bar0 destroy] [oo::object create foo] [foo destroy] +} {1 {can't create object "foo": command already exists with that name} {} ::foo {}} +test oo-11.4 {OO: cleanup} { + oo::class create bar0 + oo::class create bar1 + oo::define bar1 superclass bar0 + oo::class create bar2 + oo::define bar2 { + superclass bar0 + destructor {lappend ::result destroyed} + } + oo::class create bar + oo::define bar superclass bar1 bar2 + bar create foo + set result [list [catch {bar create foo} msg] $msg] + lappend result [bar0 destroy] [oo::object create foo] [foo destroy] \ + [oo::object create bar2] [bar2 destroy] +} {1 {can't create object "foo": command already exists with that name} destroyed {} ::foo {} ::bar2 {}} + +test oo-12.1 {OO: filters} { + oo::class create Aclass + Aclass create Aobject + oo::define Aclass { + method concatenate args { + global result + lappend result {*}$args + join $args {} + } + method logFilter args { + global result + lappend result "calling [self object]->[self method] $args" + set r [next {*}$args] + lappend result "result=$r" + return $r + } + } + oo::objdefine Aobject filter logFilter + set result {} + lappend result [Aobject concatenate 1 2 3 4 5] + Aclass destroy + return $result +} {{calling ::Aobject->logFilter 1 2 3 4 5} 1 2 3 4 5 result=12345 12345} +test oo-12.2 {OO: filters} -setup { + oo::class create Aclass + Aclass create Aobject +} -body { + oo::define Aclass { + method concatenate args { + global result + lappend result {*}$args + join $args {} + } + method logFilter args { + global result + lappend result "calling [self object]->[self method] $args" + set r [next {*}$args] + lappend result "result=$r" + return $r + } + } + oo::objdefine Aobject filter logFilter + set result {} + lappend result [Aobject concatenate 1 2 3 4 5] [Aobject destroy] +} -cleanup { + Aclass destroy +} -result {{calling ::Aobject->logFilter 1 2 3 4 5} 1 2 3 4 5 result=12345 {calling ::Aobject->logFilter } result= 12345 {}} +test oo-12.3 {OO: filters} -setup { + oo::class create Aclass + Aclass create Aobject +} -body { + oo::define Aclass { + method concatenate args { + global result + lappend result {*}$args + join $args {} + } + method logFilter args { + global result + lappend result "calling [self object]->[self method] $args" + set r [next {*}$args] + lappend result "result=$r" + return $r + } + filter logFilter + } + set result {} + lappend result [Aobject concatenate 1 2 3 4 5] [Aobject destroy] +} -cleanup { + Aclass destroy +} -result {{calling ::Aobject->logFilter 1 2 3 4 5} 1 2 3 4 5 result=12345 {calling ::Aobject->logFilter } result= 12345 {}} +test oo-12.4 {OO: filters} -setup { + oo::class create Aclass + Aclass create Aobject +} -body { + oo::define Aclass { + method foo {} { return foo } + method Bar {} { return 1 } + method boo {} { if {[my Bar]} { next } { error forbidden } } + filter boo + } + Aobject foo +} -cleanup { + Aclass destroy +} -result foo +test oo-12.5 {OO: filters} -setup { + oo::class create Aclass + Aclass create Aobject +} -body { + oo::define Aclass { + method foo {} { return foo } + method Bar {} { return [my Bar2] } + method Bar2 {} { return 1 } + method boo {} { if {[my Bar]} { next } { error forbidden } } + filter boo + } + Aobject foo +} -cleanup { + Aclass destroy +} -result foo +test oo-12.6 {OO: filters} -setup { + oo::class create Aclass + Aclass create Aobject +} -body { + oo::define Aclass { + method foo {} { return foo } + method Bar {} { return [my Bar2] } + method Bar2 {} { return [my Bar3] } + method Bar3 {} { return 1 } + method boo {} { if {[my Bar]} { next } { error forbidden } } + filter boo + } + Aobject foo +} -cleanup { + Aclass destroy +} -result foo +test oo-12.7 {OO: filters} -setup { + oo::class create Aclass + Aclass create Aobject +} -body { + oo::define Aclass { + method outerfoo {} { return [my InnerFoo] } + method InnerFoo {} { return foo } + method Bar {} { return [my Bar2] } + method Bar2 {} { return [my Bar3] } + method Bar3 {} { return 1 } + method boo {} { + lappend ::log [self target] + if {[my Bar]} { next } else { error forbidden } + } + filter boo + } + set log {} + list [Aobject outerfoo] $log +} -cleanup { + Aclass destroy +} -result {foo {{::Aclass outerfoo} {::Aclass InnerFoo}}} + +test oo-13.1 {OO: changing an object's class} { + oo::class create Aclass + oo::define Aclass {method bar {} {lappend ::result "in A [self object]"}} + oo::class create Bclass + oo::define Bclass {method bar {} {lappend ::result "in B [self object]"}} + set result [Aclass create foo] + foo bar + oo::objdefine foo class Bclass + foo bar + Aclass destroy + lappend result [info command foo] + Bclass destroy + return $result +} {::foo {in A ::foo} {in B ::foo} foo} +test oo-13.2 {OO: changing an object's class} -body { + oo::object create foo + oo::objdefine foo class oo::class +} -cleanup { + foo destroy +} -returnCodes 1 -result {may not change a non-class object into a class object} +test oo-13.3 {OO: changing an object's class} -body { + oo::class create foo + oo::objdefine foo class oo::object +} -cleanup { + foo destroy +} -returnCodes 1 -result {may not change a class object into a non-class object} +# todo: changing a class subtype (metaclass) to another class subtype + +test oo-14.1 {OO: mixins} { + oo::class create Aclass + oo::define Aclass method bar {} {lappend ::result "[self object] in bar"} + oo::class create Bclass + oo::define Bclass method boo {} {lappend ::result "[self object] in boo"} + oo::objdefine [Aclass create fooTest] mixin Bclass + oo::objdefine [Aclass create fooTest2] mixin Bclass + set result [list [catch {fooTest ?} msg] $msg] + fooTest bar + fooTest boo + fooTest2 bar + fooTest2 boo + oo::objdefine fooTest2 mixin + lappend result [Bclass destroy] [info command fooTest*] [Aclass destroy] +} {1 {unknown method "?": must be bar, boo or destroy} {::fooTest in bar} {::fooTest in boo} {::fooTest2 in bar} {::fooTest2 in boo} {} fooTest2 {}} +test oo-14.2 {OO: mixins} { + oo::class create Aclass { + method bar {} {return "[self object] in bar"} + } + oo::class create Bclass { + method boo {} {return "[self object] in boo"} + } + oo::define Aclass mixin Bclass + Aclass create fooTest + set result [list [catch {fooTest ?} msg] $msg] + lappend result [catch {fooTest bar} msg] $msg + lappend result [catch {fooTest boo} msg] $msg + lappend result [Bclass destroy] [info commands Aclass] +} {1 {unknown method "?": must be bar, boo or destroy} 0 {::fooTest in bar} 0 {::fooTest in boo} {} {}} +test oo-14.3 {OO and mixins and filters - advanced case} -setup { + oo::class create mix + oo::class create c { + mixin mix + } + c create i +} -body { + oo::define mix { + method foo {} {return >>[next]<<} + filter foo + } + oo::objdefine i method bar {} {return foobar} + i bar +} -cleanup { + mix destroy + if {[info object isa object i]} { + error "mixin deletion failed to destroy dependent instance" + } +} -result >>foobar<< +test oo-14.4 {OO: mixin error case} -setup { + oo::class create c +} -body { + oo::define c mixin c +} -returnCodes error -cleanup { + c destroy +} -result {may not mix a class into itself} +test oo-14.5 {OO and mixins and filters - advanced case} -setup { + oo::class create mix + oo::class create c { + mixin mix + } + c create i +} -body { + oo::define mix { + method foo {} {return >>[next]<<} + filter foo + } + oo::objdefine i method bar {} {return foobar} + i bar +} -cleanup { + c destroy + mix destroy +} -result >>foobar<< +test oo-14.6 {OO and mixins of mixins - Bug 1960703} -setup { + oo::class create master +} -cleanup { + master destroy +} -body { + oo::class create A { + superclass master + method egg {} { + return chicken + } + } + oo::class create B { + superclass master + mixin A + method bar {} { + # mixin from A + my egg + } + } + oo::class create C { + superclass master + mixin B + method foo {} { + # mixin from B + my bar + } + } + [C new] foo +} -result chicken +test oo-14.7 {OO and filters from mixins of mixins} -setup { + oo::class create master +} -cleanup { + master destroy +} -body { + oo::class create A { + superclass master + method egg {} { + return chicken + } + filter f + method f args { + set m [lindex [self target] 1] + return "($m) [next {*}$args] ($m)" + } + } + oo::class create B { + superclass master + mixin A + filter f + method bar {} { + # mixin from A + my egg + } + } + oo::class create C { + superclass master + mixin B + filter f + method foo {} { + # mixin from B + my bar + } + } + [C new] foo +} -result {(foo) (bar) (egg) chicken (egg) (bar) (foo)} + +test oo-15.1 {OO: object cloning} { + oo::class create Aclass + oo::define Aclass method test {} {lappend ::result [self object]->test} + Aclass create Ainstance + set result {} + Ainstance test + oo::copy Ainstance Binstance + Binstance test + Ainstance test + Ainstance destroy + namespace eval foo { + oo::copy Binstance Cinstance + Cinstance test + } + Aclass destroy + namespace delete foo + lappend result [info commands Binstance] +} {::Ainstance->test ::Binstance->test ::Ainstance->test ::foo::Cinstance->test {}} +test oo-15.2 {OO: object cloning} { + oo::object create foo + oo::objdefine foo { + method m x {lappend ::result [self object] >$x<} + forward f ::lappend ::result fwd + } + set result {} + foo m 1 + foo f 2 + lappend result [oo::copy foo bar] + foo m 3 + foo f 4 + bar m 5 + bar f 6 + lappend result [foo destroy] + bar m 7 + bar f 8 + lappend result [bar destroy] +} {::foo >1< fwd 2 ::bar ::foo >3< fwd 4 ::bar >5< fwd 6 {} ::bar >7< fwd 8 {}} +catch {foo destroy} +catch {bar destroy} +test oo-15.3 {OO: class cloning} { + oo::class create foo { + method testme {} {lappend ::result [self class]->[self object]} + } + set result {} + foo create baseline + baseline testme + oo::copy foo bar + baseline testme + bar create tester + tester testme + foo destroy + tester testme + bar destroy + return $result +} {::foo->::baseline ::foo->::baseline ::bar->::tester ::bar->::tester} + +test oo-16.1 {OO: object introspection} -body { + info object +} -returnCodes 1 -result "wrong \# args: should be \"info object subcommand ?argument ...?\"" +test oo-16.2 {OO: object introspection} -body { + info object class NOTANOBJECT +} -returnCodes 1 -result {NOTANOBJECT does not refer to an object} +test oo-16.3 {OO: object introspection} -body { + info object gorp oo::object +} -returnCodes 1 -result {unknown or ambiguous subcommand "gorp": must be class, definition, filters, forward, isa, methods, mixins, or vars} +test oo-16.4 {OO: object introspection} -setup { + oo::class create meta { superclass oo::class } + [meta create instance1] create instance2 +} -body { + list [list [info object class oo::object] \ + [info object class oo::class] \ + [info object class meta] \ + [info object class instance1] \ + [info object class instance2]] \ + [list [info object isa class oo::object] \ + [info object isa class meta] \ + [info object isa class instance1] \ + [info object isa class instance2]] \ + [list [info object isa metaclass oo::object] \ + [info object isa metaclass oo::class] \ + [info object isa metaclass meta] \ + [info object isa metaclass instance1] \ + [info object isa metaclass instance2]] \ + [list [info object isa object oo::object] \ + [info object isa object oo::class] \ + [info object isa object meta] \ + [info object isa object instance1] \ + [info object isa object instance2] \ + [info object isa object oo::define] \ + [info object isa object NOTANOBJECT]] +} -cleanup { + meta destroy +} -result {{::oo::class ::oo::class ::oo::class ::meta ::instance1} {1 1 1 0} {0 1 1 0 0} {1 1 1 1 1 0 0}} +test oo-16.5 {OO: object introspection} {info object methods oo::object} {} +test oo-16.6 {OO: object introspection} { + oo::object create foo + set result [list [info object methods foo]] + oo::objdefine foo method bar {} {...} + lappend result [info object methods foo] [foo destroy] +} {{} bar {}} +test oo-16.7 {OO: object introspection} -setup { + oo::object create foo +} -body { + oo::objdefine foo method bar {a {b c} args} {the body} + set result [info object methods foo] + lappend result [info object definition foo bar] +} -cleanup { + foo destroy +} -result {bar {{a {b c} args} {the body}}} +test oo-16.8 {OO: object introspection} { + oo::object create foo + oo::class create bar + oo::objdefine foo mixin bar + set result [list [info object mixins foo] \ + [info object isa mixin foo bar] \ + [info object isa mixin foo oo::class]] + foo destroy + bar destroy + return $result +} {::bar 1 0} +test oo-16.9 {OO: object introspection} -body { + oo::class create Ac + oo::class create Bc; oo::define Bc superclass Ac + oo::class create Cc; oo::define Cc superclass Bc + oo::class create Dc; oo::define Dc mixin Cc + Cc create E + Dc create F + list [info object isa typeof E oo::class] \ + [info object isa typeof E Ac] \ + [info object isa typeof F Bc] \ + [info object isa typeof F Cc] +} -cleanup { + catch {Ac destroy} +} -result {0 1 1 1} +test oo-16.10 {OO: object introspection} -setup { + oo::object create foo +} -body { + oo::objdefine foo export eval + foo eval {variable c 3 a 1 b 2 ddd 4 e} + lsort [info object vars foo ?] +} -cleanup { + foo destroy +} -result {a b c} +test oo-16.11 {OO: object introspection} -setup { + oo::class create foo + foo create bar +} -body { + oo::define foo method spong {} {...} + oo::objdefine bar method boo {a {b c} args} {the body} + list [info object methods bar -all] [info object methods bar -all -private] +} -cleanup { + foo destroy +} -result {{boo destroy spong} {boo destroy eval spong unknown variable varname}} + +test oo-17.1 {OO: class introspection} -body { + info class +} -returnCodes 1 -result "wrong \# args: should be \"info class subcommand ?argument ...?\"" +test oo-17.2 {OO: class introspection} -body { + info class superclass NOTANOBJECT +} -returnCodes 1 -result {NOTANOBJECT does not refer to an object} +test oo-17.3 {OO: class introspection} -setup { + oo::object create foo +} -body { + info class superclass foo +} -returnCodes 1 -cleanup { + foo destroy +} -result {"foo" is not a class} +test oo-17.4 {OO: class introspection} -body { + info class gorp oo::object +} -returnCodes 1 -result {unknown or ambiguous subcommand "gorp": must be constructor, definition, destructor, filters, forward, instances, methods, mixins, subclasses, or superclasses} +test oo-17.5 {OO: class introspection} -setup { + oo::class create testClass +} -body { + testClass create foo + testClass create bar + testClass create spong + lsort [info class instances testClass] +} -cleanup { + testClass destroy +} -result {::bar ::foo ::spong} +test oo-17.6 {OO: class introspection} -setup { + oo::class create foo +} -body { + oo::define foo method bar {a {b c} args} {the body} + set result [info class methods foo] + lappend result [info class definition foo bar] +} -cleanup { + foo destroy +} -result {bar {{a {b c} args} {the body}}} +test oo-17.7 {OO: class introspection} { + info class superclasses oo::class +} ::oo::object +test oo-17.8 {OO: class introspection} -setup { + oo::class create testClass + oo::class create superClass1 + oo::class create superClass2 +} -body { + oo::define testClass superclass superClass1 superClass2 + list [info class superclasses testClass] \ + [lsort [info class subclass oo::object ::superClass?]] +} -cleanup { + testClass destroy + superClass1 destroy + superClass2 destroy +} -result {{::superClass1 ::superClass2} {::superClass1 ::superClass2}} +test oo-17.9 {OO: class introspection} -setup { + oo::class create foo + oo::class create subfoo {superclass foo} +} -body { + oo::define foo { + method bar {a {b c} args} {the body} + self { + method bad {} {...} + } + } + oo::define subfoo method boo {a {b c} args} {the body} + list [info class methods subfoo -all] \ + [info class methods subfoo -all -private] +} -cleanup { + foo destroy +} -result {{bar boo destroy} {bar boo destroy eval unknown variable varname}} + +test oo-18.1 {OO: define command support} { + list [catch {oo::define oo::object {error foo}} msg] $msg $errorInfo +} {1 foo {foo + while executing +"error foo" + (in definition script for object "oo::object" line 1) + invoked from within +"oo::define oo::object {error foo}"}} +test oo-18.2 {OO: define command support} { + list [catch {oo::define oo::object error foo} msg] $msg $errorInfo +} {1 foo {foo + while executing +"oo::define oo::object error foo"}} +test oo-18.3 {OO: define command support} { + list [catch {oo::class create foo {error bar}} msg] $msg $errorInfo +} {1 bar {bar + while executing +"error bar" + (in definition script for object "::foo" line 1) + invoked from within +"oo::class create foo {error bar}"}} +test oo-18.4 {OO: more error traces from the guts} -setup { + oo::object create obj +} -body { + oo::objdefine obj method bar {} {my eval {error foo}} + list [catch {obj bar} msg] $msg $errorInfo +} -cleanup { + obj destroy +} -result {1 foo {foo + while executing +"error foo" + (in "my eval" script line 1) + invoked from within +"my eval {error foo}" + (object "::obj" method "bar" line 1) + invoked from within +"obj bar"}} +test oo-18.5 {OO: more error traces from the guts} -setup { + [oo::class create cls] create obj + set errorInfo {} +} -body { + oo::define cls { + method eval script {next $script} + export eval + } + oo::objdefine obj method bar {} {my eval {error foo}} + set result {} + lappend result [catch {obj bar} msg] $msg $errorInfo + lappend result [catch {obj eval {error bar}} msg] $msg $errorInfo +} -cleanup { + cls destroy +} -result {1 foo {foo + while executing +"error foo" + (in "my eval" script line 1) + invoked from within +"next $script" + (class "::cls" method "eval" line 1) + invoked from within +"my eval {error foo}" + (object "::obj" method "bar" line 1) + invoked from within +"obj bar"} 1 bar {bar + while executing +"error bar" + (in "::obj eval" script line 1) + invoked from within +"next $script" + (class "::cls" method "eval" line 1) + invoked from within +"obj eval {error bar}"}} + +test oo-19.1 {OO: varname method} -setup { + oo::object create inst + oo::objdefine inst export eval + set result {} +} -body { + inst eval {trace add variable x write foo} + set ns [inst eval namespace current] + proc foo args { + global ns result + set context [uplevel 1 namespace current] + lappend result $args [expr { + $ns eq $context ? "ok" : [list $ns ne $context] + }] [expr { + "${ns}::x" eq [uplevel 1 my varname x] ? "ok" : [list ${ns}::x ne [uplevel 1 my varname x]] + }] + } + lappend result [inst eval set x 0] +} -cleanup { + inst destroy + rename foo {} +} -result {{x {} write} ok ok 0} + +test oo-20.1 {OO: variable method} -body { + oo::class create testClass { + constructor {} { + my variable ok + set ok {} + } + } + lsort [info object vars [testClass new]] +} -cleanup { + catch {testClass destroy} +} -result ok +test oo-20.2 {OO: variable method} -body { + oo::class create testClass { + constructor {} { + my variable a b c + set a [set b [set c {}]] + } + } + lsort [info object vars [testClass new]] +} -cleanup { + catch {testClass destroy} +} -result {a b c} +test oo-20.3 {OO: variable method} -body { + oo::class create testClass { + export varname + method bar {} { + my variable a(b) + } + } + testClass create foo + array set [foo varname a] {b c} + foo bar +} -returnCodes 1 -cleanup { + catch {testClass destroy} +} -result {can't define "a(b)": name refers to an element in an array} +test oo-20.4 {OO: variable method} -body { + oo::class create testClass { + export varname + method bar {} { + my variable a(b) + } + } + testClass create foo + set [foo varname a] b + foo bar +} -returnCodes 1 -cleanup { + catch {testClass destroy} +} -result {can't define "a(b)": name refers to an element in an array} +test oo-20.5 {OO: variable method} -body { + oo::class create testClass { + method bar {} { + my variable a::b + } + } + testClass create foo + foo bar +} -returnCodes 1 -cleanup { + catch {testClass destroy} +} -result {variable name "a::b" illegal: must not contain namespace separator} +test oo-20.6 {OO: variable method} -setup { + oo::class create testClass { + export varname + self export eval + } +} -body { + testClass eval variable a 0 + oo::objdefine [testClass create foo] method bar {other} { + $other variable a + set a 3 + } + oo::objdefine [testClass create boo] export variable + set [foo varname a] 1 + set [boo varname a] 2 + foo bar boo + list [testClass eval set a] [set [foo varname a]] [set [boo varname a]] +} -cleanup { + testClass destroy +} -result {0 1 3} +test oo-20.7 {OO: variable method} -setup { + oo::class create cls +} -body { + oo::define cls { + method a {} { + my variable d b + lappend b $d + } + method e {} { + my variable b d + return [list $b $d] + } + method f {x y} { + my variable b d + set b $x + set d $y + } + } + cls create obj + obj f p q + obj a + obj a + obj e +} -cleanup { + cls destroy +} -result {{p q q} q} +# oo-20.8 tested explicitly for functionality removed due to [Bug 1959457] +test oo-20.9 {OO: variable method} -setup { + oo::object create obj +} -body { + oo::objdefine obj { + method a {} { + my variable ::b + } + } + obj a +} -returnCodes 1 -cleanup { + obj destroy +} -result {variable name "::b" illegal: must not contain namespace separator} +test oo-20.10 {OO: variable and varname methods refer to same things} -setup { + oo::object create obj +} -body { + oo::objdefine obj { + method a {} { + my variable b + set b [self] + return [my varname b] + } + } + list [set [obj a]] [namespace tail [obj a]] +} -cleanup { + obj destroy +} -result {::obj b} +test oo-20.11 {OO: variable mustn't crash when recursing} -body { + oo::class create A { + constructor {name} { + my variable np_name + set np_name $name + } + method copy {nm} { + set cpy [[info object class [self]] new $nm] + foreach var [info object vars [self]] { + my variable $var + set val [set $var] + if {[string match o_* $var]} { + set objs {} + foreach ref $val { + # call to "copy" crashes + lappend objs [$ref copy {}] + } + $cpy prop $var $objs + } else { + $cpy prop $var $val + } + } + return $cpy + } + method prop {name val} { + my variable $name + set $name $val + } + } + set o1 [A new {}] + set o2 [A new {}] + $o1 prop o_object $o2 + $o1 copy aa +} -cleanup { + catch {A destroy} +} -match glob -result * + +test oo-21.1 {OO: inheritance ordering} -setup { + oo::class create A +} -body { + oo::define A method m {} {lappend ::result A} + oo::class create B { + superclass A + method m {} {lappend ::result B;next} + } + oo::class create C { + superclass A + method m {} {lappend ::result C;next} + } + oo::class create D { + superclass B C + method m {} {lappend ::result D;next} + } + D create o + oo::objdefine o method m {} {lappend ::result o;next} + set result {} + o m + return $result +} -cleanup { + A destroy +} -result {o D B C A} +test oo-21.2 {OO: inheritance ordering} -setup { + oo::class create A +} -body { + oo::define A method m {} {lappend ::result A} + oo::class create B { + superclass A + method m {} {lappend ::result B;next} + } + oo::class create C { + superclass A + method m {} {lappend ::result C;next} + } + oo::class create D { + superclass B C + method m {} {lappend ::result D;next} + } + oo::class create Emix { + superclass C + method m {} {lappend ::result Emix;next} + } + oo::class create Fmix { + superclass Emix + method m {} {lappend ::result Fmix;next} + } + D create o + oo::objdefine o { + method m {} {lappend ::result o;next} + mixin Fmix + } + set result {} + o m + return $result +} -cleanup { + A destroy +} -result {Fmix Emix o D B C A} +test oo-21.3 {OO: inheritance ordering} -setup { + oo::class create A +} -body { + oo::define A method m {} {lappend ::result A} + oo::class create B { + superclass A + method m {} {lappend ::result B;next} + method f {} {lappend ::result B-filt;next} + } + oo::class create C { + superclass A + method m {} {lappend ::result C;next} + } + oo::class create D { + superclass B C + method m {} {lappend ::result D;next} + } + oo::class create Emix { + superclass C + method m {} {lappend ::result Emix;next} + method f {} {lappend ::result Emix-filt;next} + } + oo::class create Fmix { + superclass Emix + method m {} {lappend ::result Fmix;next} + } + D create o + oo::objdefine o { + method m {} {lappend ::result o;next} + mixin Fmix + filter f + } + set result {} + o m + return $result +} -cleanup { + A destroy +} -result {Emix-filt B-filt Fmix Emix o D B C A} +test oo-21.4 {OO: inheritance ordering} -setup { + oo::class create A +} -body { + oo::define A method m {} {lappend ::result A} + oo::class create B { + superclass A + method m {} {lappend ::result B;next} + method f {} {lappend ::result B-filt;next} + method g {} {lappend ::result B-cfilt;next} + } + oo::class create C { + superclass A + method m {} {lappend ::result C;next} + } + oo::class create D { + superclass B C + method m {} {lappend ::result D;next} + method g {} {lappend ::result D-cfilt;next} + filter g + } + oo::class create Emix { + superclass C + method m {} {lappend ::result Emix;next} + method f {} {lappend ::result Emix-filt;next} + } + oo::class create Fmix { + superclass Emix + method m {} {lappend ::result Fmix;next} + } + D create o + oo::objdefine o { + method m {} {lappend ::result o;next} + mixin Fmix + filter f + } + set result {} + o m + return $result +} -cleanup { + A destroy +} -result {Emix-filt B-filt D-cfilt B-cfilt Fmix Emix o D B C A} + +test oo-22.1 {OO and info frame} -setup { + oo::class create c + c create i +} -body { + oo::define c self method frame {} { + info frame 0 + } + oo::define c { + method frames {} { + info frame 0 + } + method level {} { + info frame + } + } + oo::objdefine i { + method frames {} { + list [next] [info frame 0] + } + method level {} { + expr {[next] - [info frame]} + } + } + list [i level] [i frames] [dict get [c frame] object] +} -cleanup { + c destroy +} -result {1 {{type proc line 2 cmd {info frame 0} method frames class ::c level 0} {type proc line 2 cmd {info frame 0} method frames object ::i level 0}} ::c} + +# Prove that the issue in [Bug 1865054] isn't an issue any more +test oo-23.1 {Self-like derivation; complex case!} -setup { + oo::class create SELF { + superclass oo::class + unexport create new + # Next is just a convenience + method method args {oo::define [self] method {*}$args} + method derive {name} { + set o [my new [list superclass [self]]] + oo::objdefine $o mixin $o + uplevel 1 [list rename $o $name]\;[list namespace which $name] + } + self mixin SELF + } + set result {} +} -body { + [SELF derive foo1] method bar1 {} {return 1} + lappend result [foo1 bar1] + [foo1 derive foo2] method bar2 {} {return [my bar1],2} + lappend result [foo2 bar2] + [foo2 derive foo3] method bar3 {} {return [my bar2],3} + lappend result [foo3 bar3] + [foo3 derive foo4] method bar4 {} {return [my bar3],4} + lappend result [foo4 bar4] + foo2 method bar2 {} {return [my bar1],x} + lappend result [foo4 bar4] +} -cleanup { + SELF destroy +} -result {1 1,2 1,2,3 1,2,3,4 1,x,3,4} + +test oo-24.1 {unknown method method - Bug 1965063} -setup { + oo::class create cls +} -cleanup { + cls destroy +} -returnCodes error -body { + oo::define cls { + method dummy {} {} + method unknown args {next {*}$args} + } + [cls new] foo bar +} -result {unknown method "foo": must be destroy, dummy or unknown} +test oo-24.2 {unknown method method - Bug 1965063} -setup { + oo::class create cls +} -cleanup { + cls destroy +} -returnCodes error -body { + oo::define cls { + method dummy {} {} + method unknown args {next {*}$args} + } + cls create obj + oo::objdefine obj { + method dummy2 {} {} + method unknown args {next {*}$args} + } + obj foo bar +} -result {unknown method "foo": must be destroy, dummy, dummy2 or unknown} + +# Probably need a better set of tests, but this is quite difficult to devise +test oo-25.1 {call chain caching} -setup { + oo::class create cls { + method ab {} {return ok} + } + set result {} +} -cleanup { + cls destroy +} -body { + cls create foo + cls create bar + set m1 ab + set m2 a; append m2 b ;# different object! + lappend result [foo $m1] [foo $m1] [bar $m1] [foo $m1] + lappend result [foo $m2] [bar $m2] + oo::objdefine foo method ab {} {return good} + lappend result [foo $m1] [bar $m2] +} -result {ok ok ok ok ok ok good ok} + +cleanupTests +return + +# Local Variables: +# mode: tcl +# End: diff --git a/unix/Makefile.in b/unix/Makefile.in index 12db7c0..25a067c 100644 --- a/unix/Makefile.in +++ b/unix/Makefile.in @@ -4,7 +4,7 @@ # "./configure", which is a configuration script generated by the "autoconf" # program (constructs like "@foo@" will get replaced in the actual Makefile. # -# RCS: @(#) $Id: Makefile.in,v 1.233 2008/05/23 21:05:13 andreas_kupries Exp $ +# RCS: @(#) $Id: Makefile.in,v 1.234 2008/05/31 11:42:21 dkf Exp $ VERSION = @TCL_VERSION@ MAJOR_VERSION = @TCL_MAJOR_VERSION@ @@ -294,6 +294,9 @@ GENERIC_OBJS = regcomp.o regexec.o regfree.o regerror.o tclAlloc.o \ tclTimer.o tclTrace.o tclUtf.o tclUtil.o tclVar.o \ tclTomMathInterface.o +OO_OBJS = tclOO.o tclOOBasic.o tclOOCall.o tclOODefineCmds.o tclOOInfo.o \ + tclOOMethod.o tclOOStubInit.o + TOMMATH_OBJS = bncore.o bn_reverse.o bn_fast_s_mp_mul_digs.o \ bn_fast_s_mp_sqr.o bn_mp_add.o bn_mp_and.o \ bn_mp_add_d.o bn_mp_clamp.o bn_mp_clear.o bn_mp_clear_multi.o \ @@ -328,13 +331,14 @@ MAC_OSX_OBJS = tclMacOSXBundle.o tclMacOSXFCmd.o tclMacOSXNotify.o DTRACE_OBJ = tclDTrace.o TCL_OBJS = ${GENERIC_OBJS} ${UNIX_OBJS} ${NOTIFY_OBJS} ${COMPAT_OBJS} \ - @DL_OBJS@ @PLAT_OBJS@ + ${OO_OBJS} @DL_OBJS@ @PLAT_OBJS@ OBJS = ${TCL_OBJS} ${TOMMATH_OBJS} @DTRACE_OBJ@ TCL_DECLS = \ $(GENERIC_DIR)/tcl.decls \ $(GENERIC_DIR)/tclInt.decls \ + $(GENERIC_DIR)/tclOO.decls \ $(GENERIC_DIR)/tclTomMath.decls GENERIC_HDRS = \ @@ -345,6 +349,10 @@ GENERIC_HDRS = \ $(GENERIC_DIR)/tclIntPlatDecls.h \ $(GENERIC_DIR)/tclTomMath.h \ $(GENERIC_DIR)/tclTomMathDecls.h \ + $(GENERIC_DIR)/tclOO.h \ + $(GENERIC_DIR)/tclOODecls.h \ + $(GENERIC_DIR)/tclOOInt.h \ + $(GENERIC_DIR)/tclOOIntDecls.h \ $(GENERIC_DIR)/tclPatch.h \ $(GENERIC_DIR)/tclPlatDecls.h \ $(GENERIC_DIR)/tclPort.h \ @@ -422,6 +430,15 @@ GENERIC_SRCS = \ $(GENERIC_DIR)/tclUtil.c \ $(GENERIC_DIR)/tclVar.c +OO_SRCS = \ + $(GENERIC_DIR)/tclOO.c \ + $(GENERIC_DIR)/tclOOBasic.c \ + $(GENERIC_DIR)/tclOOCall.c \ + $(GENERIC_DIR)/tclOODefineCmds.c \ + $(GENERIC_DIR)/tclOOInfo.c \ + $(GENERIC_DIR)/tclOOMethod.c \ + $(GENERIC_DIR)/tclOOStubInit.c + STUB_SRCS = \ $(GENERIC_DIR)/tclStubLib.c @@ -1104,6 +1121,27 @@ tclNamesp.o: $(GENERIC_DIR)/tclNamesp.c tclNotify.o: $(GENERIC_DIR)/tclNotify.c $(CC) -c $(CC_SWITCHES) $(GENERIC_DIR)/tclNotify.c +tclOO.o: $(GENERIC_DIR)/tclOO.c + $(CC) -c $(CC_SWITCHES) $(GENERIC_DIR)/tclOO.c + +tclOOBasic.o: $(GENERIC_DIR)/tclOOBasic.c + $(CC) -c $(CC_SWITCHES) $(GENERIC_DIR)/tclOOBasic.c + +tclOOCall.o: $(GENERIC_DIR)/tclOOCall.c + $(CC) -c $(CC_SWITCHES) $(GENERIC_DIR)/tclOOCall.c + +tclOODefineCmds.o: $(GENERIC_DIR)/tclOODefineCmds.c + $(CC) -c $(CC_SWITCHES) $(GENERIC_DIR)/tclOODefineCmds.c + +tclOOInfo.o: $(GENERIC_DIR)/tclOOInfo.c + $(CC) -c $(CC_SWITCHES) $(GENERIC_DIR)/tclOOInfo.c + +tclOOMethod.o: $(GENERIC_DIR)/tclOOMethod.c + $(CC) -c $(CC_SWITCHES) $(GENERIC_DIR)/tclOOMethod.c + +tclOOStubInit.o: $(GENERIC_DIR)/tclOOStubInit.c + $(CC) -c $(CC_SWITCHES) $(GENERIC_DIR)/tclOOStubInit.c + tclParse.o: $(GENERIC_DIR)/tclParse.c $(CC) -c $(CC_SWITCHES) $(GENERIC_DIR)/tclParse.c @@ -1512,6 +1550,9 @@ waitpid.o: $(COMPAT_DIR)/waitpid.c tclStubLib.o: $(GENERIC_DIR)/tclStubLib.c $(CC) -c $(STUB_CC_SWITCHES) $(GENERIC_DIR)/tclStubLib.c +tclOOStubLib.o: $(GENERIC_DIR)/tclOOStubLib.c + $(CC) -c $(STUB_CC_SWITCHES) $(GENERIC_DIR)/tclOOStubLib.c + .c.o: $(CC) -c $(CC_SWITCHES) $< @@ -1525,10 +1566,15 @@ $(GENERIC_DIR)/tclStubInit.c: $(GENERIC_DIR)/tcl.decls \ @echo "Developers may want to run \"make genstubs\" to regenerate." @echo "This warning can be safely ignored, do not report as a bug!" +$(GENERIC_DIR)/tclOOStubInit.c: $(GENERIC_DIR)/tclOO.decls + @echo "Warning: tclOOStubInit.c may be out of date." + @echo "Developers may want to run \"make genstubs\" to regenerate." + @echo "This warning can be safely ignored, do not report as a bug!" + genstubs: $(TCL_EXE) $(TOOL_DIR)/genStubs.tcl $(GENERIC_DIR) \ $(GENERIC_DIR)/tcl.decls $(GENERIC_DIR)/tclInt.decls \ - $(GENERIC_DIR)/tclTomMath.decls + $(GENERIC_DIR)/tclTomMath.decls $(GENERIC_DIR)/tclOO.decls # # Target to check that all exported functions have an entry in the stubs diff --git a/unix/tclConfig.h.in b/unix/tclConfig.h.in index 8848a62..527c116 100644 --- a/unix/tclConfig.h.in +++ b/unix/tclConfig.h.in @@ -31,6 +31,10 @@ /* Do we have access to Darwin CoreFoundation.framework? */ #undef HAVE_COREFOUNDATION +/* Define to 1 if you have the declaration of `tzname', and to 0 if you don't. + */ +#undef HAVE_DECL_TZNAME + /* Do we have fts functions? */ #undef HAVE_FTS @@ -493,7 +497,7 @@ /* Define to `int' if <sys/types.h> does not define. */ #undef pid_t -/* Define to `unsigned' if <sys/types.h> does not define. */ +/* Define to `unsigned int' if <sys/types.h> does not define. */ #undef size_t /* Define as int if socklen_t is not available */ |