summaryrefslogtreecommitdiffstats
diff options
context:
space:
mode:
Diffstat
-rw-r--r--ChangeLog93
-rw-r--r--doc/copy.n21
-rw-r--r--doc/define.n191
-rw-r--r--doc/object.n25
-rw-r--r--doc/string.n6
-rw-r--r--generic/tcl.h66
-rw-r--r--generic/tclCmdAH.c2
-rw-r--r--generic/tclCmdMZ.c28
-rw-r--r--generic/tclFCmd.c2
-rw-r--r--generic/tclInt.decls85
-rw-r--r--generic/tclIntPlatDecls.h280
-rw-r--r--generic/tclOO.c525
-rw-r--r--generic/tclOOBasic.c9
-rw-r--r--generic/tclOOCall.c18
-rw-r--r--generic/tclOODefineCmds.c1008
-rw-r--r--generic/tclOOInt.h17
-rw-r--r--generic/tclStubInit.c153
-rw-r--r--tests/oo.test299
-rw-r--r--tests/string.test82
-rw-r--r--unix/Makefile.in4
-rwxr-xr-xunix/configure2
-rw-r--r--unix/tcl.m42
-rw-r--r--win/tclWinError.c33
-rw-r--r--win/tclWinPort.h42
-rw-r--r--win/tclWinSerial.c2
-rw-r--r--win/tclWinSock.c6
26 files changed, 2298 insertions, 703 deletions
diff --git a/ChangeLog b/ChangeLog
index fb79e57..5c25427 100644
--- a/ChangeLog
+++ b/ChangeLog
@@ -1,11 +1,88 @@
+2012-03-27 Donal K. Fellows <dkf@users.sf.net>
+
+ IMPLEMENTATION OF TIP#395.
+
+ * generic/tclCmdMZ.c (StringIsCmd): Implementation of the [string is
+ entier] check. Code by Jos Decoster.
+
+2012-03-27 Jan Nijtmans <nijtmans@users.sf.net>
+
+ * generic/tcl.h: [Bug 3508771]: Wrong Tcl_StatBuf used on MinGW.
+ * generic/tclFCmd.c: [Bug 2015723]: Duplicate inodes from file stat
+ * generic/tclCmdAH.c: on windows (but now for cygwin as well).
+ * generic/tclOODefineCmds.c: minor gcc warning
+ * win/tclWinPort.h: Use lower numbers, preventing integer overflow.
+ (and remove the workaround for mingw-w64 bug 3407992. It's long fixed)
+
+2012-03-27 Donal K. Fellows <dkf@users.sf.net>
+
+ IMPLEMENTATION OF TIP#397.
+
+ * generic/tclOO.c (Tcl_CopyObjectInstance): [Bug 3474460]: Make the
+ target object name optional when copying classes. [RFE 3485060]: Add
+ callback method ("<cloned>") so that scripted control over copying is
+ easier.
+ ***POTENTIAL INCOMPATIBILITY***
+ If you'd previously been using the "<cloned>" method name, this now
+ has a standard semantics and call interface. Only a problem if you are
+ also using [oo::copy].
+
+2012-03-26 Donal K. Fellows <dkf@users.sf.net>
+
+ IMPLEMENTATION OF TIP#380.
+
+ * doc/define.n, doc/object.n, generic/tclOO.c, generic/tclOOBasic.c:
+ * generic/tclOOCall.c, generic/tclOODefineCmds.c, generic/tclOOInt.h:
+ * tests/oo.test: Switch definitions of lists of things in objects and
+ classes to a slot-based approach, which gives a lot more flexibility
+ and programmability at the script-level. Introduce new [::oo::Slot]
+ class which is the implementation of these things.
+
+ ***POTENTIAL INCOMPATIBILITY***
+ The unknown method handler now may be asked to deal with the case
+ where no method name is provided at all. The default implementation
+ generates a compatible error message, and any override that forces the
+ presence of a first argument (i.e., a method name) will continue to
+ function as at present as well, so this is a pretty small change.
+
+ * generic/tclOOBasic.c (TclOO_Object_Destroy): Made it easier to do a
+ tailcall inside a normally-invoked destructor; prevented leakage out
+ to calling command.
+
+2012-03-25 Jan Nijtmans <nijtmans@users.sf.net>
+
+ * generic/tclInt.decls: [Bug 3508771]: load tclreg.dll in cygwin
+ * generic/tclIntPlatDecls.h: tclsh. Implement TclWinConvertError,
+ * generic/tclStubInit.c: TclWinConvertWSAError, and various more
+ * unix/Makefile.in: win32-specific internal functions for
+ * unix/tcl.m4: Cygwin, so win32 extensions using those
+ * unix/configure: can be loaded in the cygwin version of
+ * win/tclWinError.c: tclsh.
+
+2012-03-23 Jan Nijtmans <nijtmans@users.sf.net>
+
+ * generic/tclInt.decls: Revert some cygwin-related signature
+ * generic/tclIntPlatDecls.h: changes from [835f8e1e9d] (2010-01-22).
+ * win/tclWinError.c: They were an attempt to make the cygwin
+ port compile again, but since cygwin is
+ based on unix this serves no purpose any
+ more.
+ * win/tclWinSerial.c: Use EAGAIN in stead of EWOULDBLOCK,
+ * win/tclWinSock.c: because in VS10+ the value of
+ EWOULDBLOCK is no longer the same as
+ EAGAIN.
+ * unix/Makefile.in: Add tclWinError.c to the CYGWIN build.
+ * unix/tcl.m4:
+ * unix/configure:
+
2012-03-20 Jan Nijtmans <nijtmans@users.sf.net>
- * generic/tcl.decls: [Bug 3508771] load tclreg.dll in cygwin tclsh
- * generic/tclInt.decls: Implement TclWinGetPlatformId, Tcl_WinUtfToTChar,
- * generic/tclIntPlatDecls.h: Tcl_WinTCharToUtf (and a dummy TclWinCPUID) for
- * generic/tclPlatDecls.h: Cygwin, so win32 extensions using those can be
- * generic/tclStubInit.c: loaded in the cygwin version of tclsh.
- * unix/tclUnixCompat.c:
+ * generic/tcl.decls: [Bug 3508771]: load tclreg.dll in cygwin
+ * generic/tclInt.decls: tclsh. Implement TclWinGetPlatformId,
+ * generic/tclIntPlatDecls.h: Tcl_WinUtfToTChar, Tcl_WinTCharToUtf (and
+ * generic/tclPlatDecls.h: a dummy TclWinCPUID) for Cygwin, so win32
+ * generic/tclStubInit.c: extensions using those can be loaded in
+ * unix/tclUnixCompat.c: the cygwin version of tclsh.
2012-03-19 Venkat Iyer <venkat@comit.com>
@@ -47,7 +124,7 @@
2012-03-15 Jan Nijtmans <nijtmans@users.sf.net>
- * generic/tcl.h: [Bug 3288345] Wrong Tcl_StatBuf used on Cygwin
+ * generic/tcl.h: [Bug 3288345]: Wrong Tcl_StatBuf used on Cygwin
* unix/tclUnixFile.c
* unix/tclUnixPort.h
* win/cat.c: Remove cygwin stuff no longer needed
@@ -56,7 +133,7 @@
2012-03-12 Jan Nijtmans <nijtmans@users.sf.net>
- * win/tclWinFile.c: [Bug 3388350] mingw64 compiler warnings
+ * win/tclWinFile.c: [Bug 3388350]: mingw64 compiler warnings
2012-03-11 Donal K. Fellows <dkf@users.sf.net>
diff --git a/doc/copy.n b/doc/copy.n
index 51ec844..f5002f8 100644
--- a/doc/copy.n
+++ b/doc/copy.n
@@ -26,10 +26,23 @@ 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.
+the class copied, but it will not have any of its instances copied.
+.PP
+.VS
+After the \fItargetObject\fR has been created and all definitions of its
+configuration (e.g., methods, filters, mixins) copied, the \fB<cloned>\fR
+method of \fItargetObject\fR will be invoked, to allow for customization of
+the created object such as installing related variable traces. The only
+argument given will be \fIsourceObject\fR. The default implementation of this
+method (in \fBoo::object\fR) just copies the procedures and variables in the
+namespace of \fIsourceObject\fR to the namespace of \fItargetObject\fR. If
+this method call does not return a result that is successful (i.e., an error
+or other kind of exception) then the \fItargetObject\fR will be deleted and an
+error returned.
+.VE
+.PP
+The result of the \fBoo::copy\fR command will be the fully-qualified name of
+the new object or class.
.SH EXAMPLES
.PP
This example creates an object, copies it, modifies the source object, and
diff --git a/doc/define.n b/doc/define.n
index 58bc4cd..6bdd9c5 100644
--- a/doc/define.n
+++ b/doc/define.n
@@ -81,14 +81,18 @@ 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
+\fBfilter\fR ?\fI\-slotOperation\fR? ?\fImethodName ...\fR?
+.VS
+This slot (see \fBSLOTTED DEFINITIONS\fR below)
+.VE
+sets or updates the list of method names that are used to guard whether
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.
+named since they may be defined by subclasses.
+.VS
+By default, this slot works by appending.
+.VE
.TP
\fBforward\fI name cmdName \fR?\fIarg ...\fR?
.
@@ -114,12 +118,16 @@ 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
+\fBmixin\fR ?\fI\-slotOperation\fR? ?\fIclassName ...\fR?
+.VS
+This slot (see \fBSLOTTED DEFINITIONS\fR below)
+.VE
+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.
+names a single class that is to be mixed in.
+.VS
+By default, this slot works by replacement.
+.VE
.TP
\fBrenamemethod\fI fromName toName\fR
.
@@ -144,12 +152,19 @@ and
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.
+\fBsuperclass\fI ?\fI\-slotOperation\fR? \fR?\fIclassName ...\fR?
+.VS
+This slot (see \fBSLOTTED DEFINITIONS\fR below)
+.VE
+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.
+being non-classes or vice-versa, that an empty parent class is equivalent to
+\fBoo::object\fR, and that the parent classes of \fBoo::object\fR and
+\fBoo::class\fR may not be modified.
+.VS
+By default, this slot works by replacement.
+.VE
.TP
\fBunexport\fI name \fR?\fIname ...\fR?
.
@@ -160,18 +175,18 @@ 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.
.TP
-\fBvariable\fR ?\fIname ...\fR?
+\fBvariable\fR ?\fI\-slotOperation\fR? ?\fIname ...\fR?
.VS
-This arranges for each of the named variables to be automatically made
+This slot (see \fBSLOTTED DEFINITIONS\fR below) arranges for each of the named
+variables to be automatically made
available in the methods, constructor and destructor declared by the class
-being defined. Note that the list of variable names is the whole list of
-variable names for the class. Each variable name must not have any namespace
+being defined. Each variable name must not have any namespace
separators and must not look like an array access. All variables will be
actually present in the instance object on which the method is executed. Note
that the variable lists declared by a superclass or subclass are completely
disjoint, as are variable lists declared by instances; the list of variable
names is just for methods (and constructors and destructors) declared by this
-class.
+class. By default, this slot works by appending.
.VE
.SS "CONFIGURING OBJECTS"
.PP
@@ -198,15 +213,19 @@ This arranges for each of the named methods, \fIname\fR, to be exported
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
+\fBfilter\fR ?\fI\-slotOperation\fR? ?\fImethodName ...\fR?
+.VS
+This slot (see \fBSLOTTED DEFINITIONS\fR below)
+.VE
+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.
+not exposed); it is not an error for a non-existent method to be named. Note
+that the actual list of filters also depends on the filters set upon any
+classes that the object is an instance of.
+.VS
+By default, this slot works by appending.
+.VE
.TP
\fBforward\fI name cmdName \fR?\fIarg ...\fR?
.
@@ -227,12 +246,16 @@ 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
+\fBmixin\fR ?\fI\-slotOperation\fR? ?\fIclassName ...\fR?
+.VS
+This slot (see \fBSLOTTED DEFINITIONS\fR below)
+.VE
+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.
+that is to be mixed in.
+.VS
+By default, this slot works by replacement.
+.VE
.TP
\fBrenamemethod\fI fromName toName\fR
.
@@ -250,16 +273,70 @@ 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.
.TP
-\fBvariable\fR ?\fIname ...\fR?
+\fBvariable\fR ?\fI\-slotOperation\fR? ?\fIname ...\fR?
+.VS
+This slot (see \fBSLOTTED DEFINITIONS\fR below) arranges for each of the named
+variables to be automatically made available in the methods declared by the
+object being defined. Each variable name must not have any namespace
+separators and must not look like an array access. All variables will be
+actually present in the object on which the method is executed. Note that the
+variable lists declared by the classes and mixins of which the object is an
+instance are completely disjoint; the list of variable names is just for
+methods declared by this object. By default, this slot works by appending.
+.SH "SLOTTED DEFINITIONS"
+Some of the configurable definitions of a class or object are \fIslotted
+definitions\fR. This means that the configuration is implemented by a slot
+object, that is an instance of the class \fBoo::Slot\fR, which manages a list
+of values (class names, variable names, etc.) that comprises the contents of
+the slot. The class defines three operations (as methods) that may be done on
+the slot:
+.VE
+.TP
+\fIslot\fR \fB\-append\fR ?\fImember ...\fR?
+.VS
+This appends the given \fImember\fR elements to the slot definition.
+.VE
+.TP
+\fIslot\fR \fB\-clear\fR
+.VS
+This sets the slot definition to the empty list.
+.VE
+.TP
+\fIslot\fR \fB\-set\fR ?\fImember ...\fR?
+.VS
+This replaces the slot definition with the given \fImember\fR elements.
+.PP
+A consequence of this is that any use of a slot's default operation where the
+first member argument begins with a hyphen will be an error. One of the above
+operations should be used explicitly in those circumstances.
+.SS "SLOT IMPLEMENTATION"
+Internally, slot objects also define a method \fB\-\-default\-operation\fR
+which is forwarded to the default operation of the slot (thus, for the class
+.QW \fBvariable\fR
+slot, this is forwarded to
+.QW "\fBmy \-append\fR" ),
+and these methods which provide the implementation interface:
+.VE
+.TP
+\fIslot\fR \fBGet\fR
+.VS
+Returns a list that is the current contents of the slot. This method must
+always be called from a stack frame created by a call to \fBoo::define\fR or
+\fBoo::objdefine\fR.
+.VE
+.TP
+\fIslot\fR \fBSet \fIelementList\fR
.VS
-This arranges for each of the named variables to be automatically made
-available in the methods declared by the object being defined. Note that the
-list of variable names is the whole list of variable names for the object.
-Each variable name must not have any namespace separators and must not look
-like an array access. All variables will be actually present in the object on
-which the method is executed. Note that the variable lists declared by the
-classes and mixins of which the object is an instance are completely disjoint;
-the list of variable names is just for methods declared by this object.
+Sets the contents of the slot to the list \fIelementList\fR and returns the
+empty string. This method must always be called from a stack frame created by
+a call to \fBoo::define\fR or \fBoo::objdefine\fR.
+.PP
+The implementation of these methods is slot-dependent (and responsible for
+accessing the correct part of the class or object definition). Slots also have
+an unknown method handler to tie all these pieces together, and they hide
+their \fBdestroy\fR method so that it is not invoked inadvertently. It is
+\fIrecommended\fR that any user changes to the slot mechanism be restricted to
+defining new operations whose names start with a hyphen.
.VE
.SH EXAMPLES
This example demonstrates how to use both forms of the \fBoo::define\fR and
@@ -286,11 +363,41 @@ 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
+.PP
+This example shows how additional classes can be mixed into an object. It also
+shows how \fBmixin\fR is a slot that supports appending:
+.PP
+.CS
+oo::object create inst
+inst m1 \fI\(-> error "unknown method m1"\fR
+inst m2 \fI\(-> error "unknown method m2"\fR
+
+oo::class create A {
+ \fBmethod\fR m1 {} {
+ puts "red brick"
+ }
+}
+\fBoo::objdefine\fR inst {
+ \fBmixin\fR A
+}
+inst m1 \fI\(-> prints "red brick"\fR
+inst m2 \fI\(-> error "unknown method m2"\fR
+
+oo::class create B {
+ \fBmethod\fR m2 {} {
+ puts "blue brick"
+ }
+}
+\fBoo::objdefine\fR inst {
+ \fBmixin -append\fR B
+}
+inst m1 \fI\(-> prints "red brick"\fR
+inst m2 \fI\(-> prints "blue brick"\fR
+.CE
.SH "SEE ALSO"
next(n), oo::class(n), oo::object(n)
.SH KEYWORDS
-class, definition, method, object
-
+class, definition, method, object, slot
.\" Local variables:
.\" mode: nroff
.\" fill-column: 78
diff --git a/doc/object.n b/doc/object.n
index 96a1bfb..6737e7e 100644
--- a/doc/object.n
+++ b/doc/object.n
@@ -65,14 +65,19 @@ 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?
+\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 arguments. 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.
+given as \fIarg\fR arguments.
+.VS
+If \fImethodName\fR is absent, the object was invoked with no method name at
+all (or any other arguments).
+.VE
+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 \fR?\fIvarName ...\fR?
.
@@ -86,6 +91,16 @@ must not have any namespace separators in it. The result is the empty string.
.
This method returns the globally qualified name of the variable \fIvarName\fR
in the unique namespace for the object \fIobj\fR.
+.TP
+\fIobj \fB<cloned> \fIsourceObjectName\fR
+.VS
+This method is used by the \fBoo::object\fR command to copy the state of one
+object to another. It is responsible for copying the procedures and variables
+of the namespace of the source object (\fIsourceObjectName\fR) to the current
+object. It does not copy any other types of commands or any traces on the
+variables; that can be added if desired by overriding this method in a
+subclass.
+.VE
.SH EXAMPLES
.PP
This example demonstrates basic use of an object.
diff --git a/doc/string.n b/doc/string.n
index d960b71..1cbea16 100644
--- a/doc/string.n
+++ b/doc/string.n
@@ -121,6 +121,12 @@ outside of the [0\-9] range.
Any of the valid forms for a double in Tcl, with optional surrounding
whitespace. In case of under/overflow in the value, 0 is returned and
the \fIvarname\fR will contain \-1.
+.IP \fBentier\fR 12
+.VS 8.6
+Any of the valid string formats for an integer value of arbitrary size
+in Tcl, with optional surrounding whitespace. The formats accepted are
+exactly those accepted by the C routine \fBTcl_GetBignumFromObj\fR.
+.VE
.IP \fBfalse\fR 12
Any of the forms allowed to \fBTcl_GetBoolean\fR where the value is
false.
diff --git a/generic/tcl.h b/generic/tcl.h
index cb90096..875a171 100644
--- a/generic/tcl.h
+++ b/generic/tcl.h
@@ -376,26 +376,13 @@ typedef long LONG;
# if defined(__WIN32__)
# define TCL_WIDE_INT_TYPE __int64
# ifdef __BORLANDC__
-typedef struct stati64 Tcl_StatBuf;
# define TCL_LL_MODIFIER "L"
# else /* __BORLANDC__ */
-# if defined(_WIN64)
-typedef struct __stat64 Tcl_StatBuf;
-# elif (defined(_MSC_VER) && (_MSC_VER < 1400)) || defined(_USE_32BIT_TIME_T)
-typedef struct _stati64 Tcl_StatBuf;
-# else
-typedef struct _stat32i64 Tcl_StatBuf;
-# endif /* _MSC_VER < 1400 */
# define TCL_LL_MODIFIER "I64"
# endif /* __BORLANDC__ */
# elif defined(__GNUC__)
# define TCL_WIDE_INT_TYPE long long
# define TCL_LL_MODIFIER "ll"
-# if defined(__WIN32__)
-typedef struct _stat32i64 Tcl_StatBuf;
-# else
-typedef struct stat Tcl_StatBuf;
-# endif
# else /* ! __WIN32__ && ! __GNUC__ */
/*
* Don't know what platform it is and configure hasn't discovered what is
@@ -422,7 +409,6 @@ typedef TCL_WIDE_INT_TYPE Tcl_WideInt;
typedef unsigned TCL_WIDE_INT_TYPE Tcl_WideUInt;
#ifdef TCL_WIDE_INT_IS_LONG
-typedef struct stat Tcl_StatBuf;
# define Tcl_WideAsLong(val) ((long)(val))
# define Tcl_LongAsWide(val) ((long)(val))
# define Tcl_WideAsDouble(val) ((double)((long)(val)))
@@ -436,25 +422,6 @@ typedef struct stat Tcl_StatBuf;
* or some other strange platform.
*/
# ifndef TCL_LL_MODIFIER
-# ifdef __CYGWIN__
-typedef struct _stat32i64 {
- dev_t st_dev;
- ino_t st_ino;
- unsigned short st_mode;
- short st_nlink;
- short st_uid;
- short st_gid;
- dev_t st_rdev;
- long long st_size;
- struct {long tv_sec;} st_atim;
- struct {long tv_sec;} st_mtim;
- struct {long tv_sec;} st_ctim;
-} Tcl_StatBuf;
-# elif defined(HAVE_STRUCT_STAT64)
-typedef struct stat64 Tcl_StatBuf;
-# else
-typedef struct stat Tcl_StatBuf;
-# endif /* HAVE_STRUCT_STAT64 */
# define TCL_LL_MODIFIER "ll"
# endif /* !TCL_LL_MODIFIER */
# define Tcl_WideAsLong(val) ((long)((Tcl_WideInt)(val)))
@@ -462,6 +429,39 @@ typedef struct stat Tcl_StatBuf;
# define Tcl_WideAsDouble(val) ((double)((Tcl_WideInt)(val)))
# define Tcl_DoubleAsWide(val) ((Tcl_WideInt)((double)(val)))
#endif /* TCL_WIDE_INT_IS_LONG */
+
+#if defined(__WIN32__)
+# ifdef __BORLANDC__
+ typedef struct stati64 Tcl_StatBuf;
+# elif defined(_WIN64)
+ typedef struct __stat64 Tcl_StatBuf;
+# elif (defined(_MSC_VER) && (_MSC_VER < 1400)) || defined(_USE_32BIT_TIME_T)
+ typedef struct _stati64 Tcl_StatBuf;
+# else
+ typedef struct _stat32i64 Tcl_StatBuf;
+# endif /* _MSC_VER < 1400 */
+#elif defined(__CYGWIN__)
+ typedef struct _stat32i64 {
+ dev_t st_dev;
+ unsigned short st_ino;
+ unsigned short st_mode;
+ short st_nlink;
+ short st_uid;
+ short st_gid;
+ /* Here is a 2-byte gap */
+ dev_t st_rdev;
+ /* Here is a 4-byte gap */
+ long long st_size;
+ struct {long tv_sec;} st_atim;
+ struct {long tv_sec;} st_mtim;
+ struct {long tv_sec;} st_ctim;
+ /* Here is a 4-byte gap */
+ } Tcl_StatBuf;
+#elif defined(HAVE_STRUCT_STAT64)
+ typedef struct stat64 Tcl_StatBuf;
+#else
+ typedef struct stat Tcl_StatBuf;
+#endif
/*
*----------------------------------------------------------------------------
diff --git a/generic/tclCmdAH.c b/generic/tclCmdAH.c
index 2308f33..1cbc4d2 100644
--- a/generic/tclCmdAH.c
+++ b/generic/tclCmdAH.c
@@ -1544,7 +1544,7 @@ FileAttrIsOwnedCmd(
* test for equivalence to the current user.
*/
-#ifdef __WIN32__
+#if defined(__WIN32__) || defined(__CYGWIN__)
value = 1;
#else
value = (geteuid() == buf.st_uid);
diff --git a/generic/tclCmdMZ.c b/generic/tclCmdMZ.c
index 1ef6fa8..ff300b0 100644
--- a/generic/tclCmdMZ.c
+++ b/generic/tclCmdMZ.c
@@ -18,6 +18,7 @@
#include "tclInt.h"
#include "tclRegexp.h"
+#include "tommath.h"
static inline Tcl_Obj * During(Tcl_Interp *interp, int resultCode,
Tcl_Obj *oldOptions, Tcl_Obj *errorInfo);
@@ -1433,21 +1434,23 @@ StringIsCmd(
int i, failat = 0, result = 1, strict = 0, index, length1, length2;
Tcl_Obj *objPtr, *failVarObj = NULL;
Tcl_WideInt w;
+ mp_int big;
static const char *const isClasses[] = {
"alnum", "alpha", "ascii", "control",
- "boolean", "digit", "double", "false",
- "graph", "integer", "list", "lower",
- "print", "punct", "space", "true",
- "upper", "wideinteger", "wordchar", "xdigit",
- NULL
+ "boolean", "digit", "double", "entier",
+ "false", "graph", "integer", "list",
+ "lower", "print", "punct", "space",
+ "true", "upper", "wideinteger", "wordchar",
+ "xdigit", NULL
};
enum isClasses {
- STR_IS_ALNUM, STR_IS_ALPHA, STR_IS_ASCII, STR_IS_CONTROL,
- STR_IS_BOOL, STR_IS_DIGIT, STR_IS_DOUBLE, STR_IS_FALSE,
- STR_IS_GRAPH, STR_IS_INT, STR_IS_LIST, STR_IS_LOWER,
- STR_IS_PRINT, STR_IS_PUNCT, STR_IS_SPACE, STR_IS_TRUE,
- STR_IS_UPPER, STR_IS_WIDE, STR_IS_WORD, STR_IS_XDIGIT
+ STR_IS_ALNUM, STR_IS_ALPHA, STR_IS_ASCII, STR_IS_CONTROL,
+ STR_IS_BOOL, STR_IS_DIGIT, STR_IS_DOUBLE, STR_IS_ENTIER,
+ STR_IS_FALSE, STR_IS_GRAPH, STR_IS_INT, STR_IS_LIST,
+ STR_IS_LOWER, STR_IS_PRINT, STR_IS_PUNCT, STR_IS_SPACE,
+ STR_IS_TRUE, STR_IS_UPPER, STR_IS_WIDE, STR_IS_WORD,
+ STR_IS_XDIGIT
};
static const char *const isOptions[] = {
"-strict", "-failindex", NULL
@@ -1575,6 +1578,11 @@ StringIsCmd(
break;
}
goto failedIntParse;
+ case STR_IS_ENTIER:
+ if (TCL_OK == Tcl_GetBignumFromObj(NULL, objPtr, &big)) {
+ break;
+ }
+ goto failedIntParse;
case STR_IS_WIDE:
if (TCL_OK == Tcl_GetWideIntFromObj(NULL, objPtr, &w)) {
break;
diff --git a/generic/tclFCmd.c b/generic/tclFCmd.c
index e95a136..a868fe3 100644
--- a/generic/tclFCmd.c
+++ b/generic/tclFCmd.c
@@ -520,7 +520,7 @@ CopyRenameOneFile(
* 16 bits and we get collisions. See bug #2015723.
*/
-#ifndef WIN32
+#if !defined(WIN32) && !defined(__CYGWIN__)
if ((sourceStatBuf.st_ino != 0) && (targetStatBuf.st_ino != 0)) {
if ((sourceStatBuf.st_ino == targetStatBuf.st_ino) &&
(sourceStatBuf.st_dev == targetStatBuf.st_dev)) {
diff --git a/generic/tclInt.decls b/generic/tclInt.decls
index cf88fd3..cb01b22 100644
--- a/generic/tclInt.decls
+++ b/generic/tclInt.decls
@@ -18,7 +18,6 @@ library tcl
# Define the unsupported generic interfaces.
interface tclInt
-scspec EXTERN
# Declare each of the functions in the unsupported internal Tcl
# interface. These interfaces are allowed to changed between versions.
@@ -689,12 +688,12 @@ declare 169 {
}
declare 170 {
int TclCheckInterpTraces(Tcl_Interp *interp, const char *command,
- int numChars, Command *cmdPtr, int result, int traceFlags,
+ int numChars, Command *cmdPtr, int result, int traceFlags,
int objc, Tcl_Obj *const objv[])
}
declare 171 {
int TclCheckExecutionTraces(Tcl_Interp *interp, const char *command,
- int numChars, Command *cmdPtr, int result, int traceFlags,
+ int numChars, Command *cmdPtr, int result, int traceFlags,
int objc, Tcl_Obj *const objv[])
}
declare 172 {
@@ -746,7 +745,7 @@ declare 177 {
# const char *file, int line)
#}
-# TclpGmtime and TclpLocaltime promoted to the interface from unix
+# TclpGmtime and TclpLocaltime promoted to the generic interface from unix
declare 182 {
struct tm *TclpLocaltime(const time_t *clock)
@@ -999,7 +998,6 @@ declare 249 {
char* TclDoubleDigits(double dv, int ndigits, int flags,
int* decpt, int* signum, char** endPtr)
}
-
# TIP #285: Script cancellation support.
declare 250 {
void TclSetSlaveCancelFlags(Tcl_Interp *interp, int flags, int force)
@@ -1016,10 +1014,10 @@ interface tclIntPlat
# Windows specific functions
declare 0 win {
- void TclWinConvertError(unsigned long errCode)
+ void TclWinConvertError(DWORD errCode)
}
declare 1 win {
- void TclWinConvertWSAError(unsigned long errCode)
+ void TclWinConvertWSAError(DWORD errCode)
}
declare 2 win {
struct servent *TclWinGetServByName(const char *nm,
@@ -1088,7 +1086,7 @@ declare 19 win {
TclFile TclpOpenFile(const char *fname, int mode)
}
declare 20 win {
- void TclWinAddProcess(void *hProcess, unsigned long id)
+ void TclWinAddProcess(HANDLE hProcess, DWORD id)
}
# removed permanently for 8.4
@@ -1106,7 +1104,7 @@ declare 23 win {
declare 24 win {
char *TclWinNoBackslash(char *path)
}
-# replaced by TclGetPlatform
+# replaced by generic TclGetPlatform
#declare 25 win {
# TclPlatformType *TclWinGetPlatform(void)
#}
@@ -1134,11 +1132,13 @@ declare 29 win {
# Pipe channel functions
+# On non-cygwin, this is actually a reference to TclGetAndDetachPids
declare 0 unix {
- void TclGetAndDetachPids(Tcl_Interp *interp, Tcl_Channel chan)
+ void TclWinConvertError(unsigned int errCode)
}
+# On non-cygwin, this is actually a reference to TclpCloseFile
declare 1 unix {
- int TclpCloseFile(TclFile file)
+ void TclWinConvertWSAError(unsigned int errCode)
}
declare 2 unix {
Tcl_Channel TclpCreateCommandChannel(TclFile readFile,
@@ -1147,20 +1147,23 @@ declare 2 unix {
declare 3 unix {
int TclpCreatePipe(TclFile *readPipe, TclFile *writePipe)
}
+# On non-cygwin, this is actually a reference to TclpCreateProcess
declare 4 unix {
- int TclpCreateProcess(Tcl_Interp *interp, int argc, const char **argv,
- TclFile inputFile, TclFile outputFile, TclFile errorFile,
- Tcl_Pid *pidPtr)
+ int TclWinGetTclInstance(void)
}
# Signature changed in 8.1:
# declare 5 unix {
# TclFile TclpCreateTempFile(char *contents, Tcl_DString *namePtr)
# }
+
+# On non-cygwin, this is actually a reference to TclpMakeFile
declare 6 unix {
- TclFile TclpMakeFile(Tcl_Channel channel, int direction)
+ unsigned short TclWinNToHS(unsigned short ns)
}
+# On non-cygwin, this is actually a reference to TclpOpenFile
declare 7 unix {
- TclFile TclpOpenFile(const char *fname, int mode)
+ int TclWinSetSockOpt(int s, int level, int optname,
+ const char *optval, int optlen)
}
declare 8 unix {
int TclUnixWaitForFile(int fd, int mask, int timeout)
@@ -1179,10 +1182,12 @@ declare 10 unix {
Tcl_DirEntry *TclpReaddir(DIR *dir)
}
# Slots 11 and 12 are forwarders for functions that were promoted to
-# Stubs
+# generic Stubs
+# On cygwin, this is actually a reference to TclGetAndDetachPids
declare 11 unix {
struct tm *TclpLocaltime_unix(const time_t *clock)
}
+# On cygwin, this is actually a reference to TclpCloseFile
declare 12 unix {
struct tm *TclpGmtime_unix(const time_t *clock)
}
@@ -1197,17 +1202,11 @@ declare 14 unix {
const Tcl_StatBuf *statBufPtr, int dontCopyAtts)
}
-declare 22 unix {
- TclFile TclpCreateTempFile(const char *contents)
-}
-declare 29 unix {
- int TclWinCPUID(unsigned int index, unsigned int *regs)
-}
-
################################
# Mac OS X specific functions
-declare 15 macosx {
+#On cygwin, TclpCreateProcess is here
+declare 15 {unix macosx} {
int TclMacOSXGetFileAttribute(Tcl_Interp *interp, int objIndex,
Tcl_Obj *fileName, Tcl_Obj **attributePtrPtr)
}
@@ -1219,14 +1218,46 @@ declare 17 macosx {
int TclMacOSXCopyFileAttributes(const char *src, const char *dst,
const Tcl_StatBuf *statBufPtr)
}
-declare 18 macosx {
+#On cygwin, TclpMakeFile is here
+declare 18 {unix macosx} {
int TclMacOSXMatchType(Tcl_Interp *interp, const char *pathName,
const char *fileName, Tcl_StatBuf *statBufPtr,
Tcl_GlobTypeData *types)
}
-declare 19 macosx {
+#On cygwin, TclpOpenFile is here
+declare 19 {unix macosx} {
void TclMacOSXNotifierAddRunLoopMode(const void *runLoopMode)
}
+declare 20 unix {
+ void TclWinAddProcess(void *hProcess, unsigned long id)
+}
+declare 22 unix {
+ TclFile TclpCreateTempFile(const char *contents)
+}
+declare 23 unix {
+ char *TclpGetTZName(int isdst)
+}
+declare 24 unix {
+ char *TclWinNoBackslash(char *path)
+}
+declare 26 unix {
+ void TclWinSetInterfaces(int wide)
+}
+declare 27 unix {
+ void TclWinFlushDirtyChannels(void)
+}
+declare 28 unix {
+ void TclWinResetInterfaces(void)
+}
+declare 29 unix {
+ int TclWinCPUID(unsigned int index, unsigned int *regs)
+}
+declare 30 unix {
+ void TclGetAndDetachPids(Tcl_Interp *interp, Tcl_Channel chan)
+}
+declare 31 unix {
+ int TclpCloseFile(TclFile file)
+}
# Local Variables:
diff --git a/generic/tclIntPlatDecls.h b/generic/tclIntPlatDecls.h
index 192005c..5d3e2ab 100644
--- a/generic/tclIntPlatDecls.h
+++ b/generic/tclIntPlatDecls.h
@@ -24,6 +24,16 @@
# endif
#endif
+#if !defined(__WIN32__) /* UNIX */
+EXTERN int TclpCreateProcess(Tcl_Interp *interp,
+ int argc, CONST char **argv, TclFile inputFile,
+ TclFile outputFile, TclFile errorFile, Tcl_Pid *pidPtr);
+EXTERN TclFile TclpMakeFile(Tcl_Channel channel,
+ int direction);
+EXTERN TclFile TclpOpenFile(CONST char *fname,
+ int mode);
+#endif
+
/*
* WARNING: This file is automatically generated by the tools/genStubs.tcl
* script. Any modifications to the function declarations below should be made
@@ -38,10 +48,9 @@
#if !defined(__WIN32__) && !defined(MAC_OSX_TCL) /* UNIX */
/* 0 */
-EXTERN void TclGetAndDetachPids(Tcl_Interp *interp,
- Tcl_Channel chan);
+EXTERN void TclWinConvertError(unsigned int errCode);
/* 1 */
-EXTERN int TclpCloseFile(TclFile file);
+EXTERN void TclWinConvertWSAError(unsigned int errCode);
/* 2 */
EXTERN Tcl_Channel TclpCreateCommandChannel(TclFile readFile,
TclFile writeFile, TclFile errorFile,
@@ -49,15 +58,13 @@ EXTERN Tcl_Channel TclpCreateCommandChannel(TclFile readFile,
/* 3 */
EXTERN int TclpCreatePipe(TclFile *readPipe, TclFile *writePipe);
/* 4 */
-EXTERN int TclpCreateProcess(Tcl_Interp *interp, int argc,
- const char **argv, TclFile inputFile,
- TclFile outputFile, TclFile errorFile,
- Tcl_Pid *pidPtr);
+EXTERN int TclWinGetTclInstance(void);
/* Slot 5 is reserved */
/* 6 */
-EXTERN TclFile TclpMakeFile(Tcl_Channel channel, int direction);
+EXTERN unsigned short TclWinNToHS(unsigned short ns);
/* 7 */
-EXTERN TclFile TclpOpenFile(const char *fname, int mode);
+EXTERN int TclWinSetSockOpt(int s, int level, int optname,
+ const char *optval, int optlen);
/* 8 */
EXTERN int TclUnixWaitForFile(int fd, int mask, int timeout);
/* 9 */
@@ -74,29 +81,49 @@ EXTERN char * TclpInetNtoa(struct in_addr addr);
EXTERN int TclUnixCopyFile(const char *src, const char *dst,
const Tcl_StatBuf *statBufPtr,
int dontCopyAtts);
-/* Slot 15 is reserved */
+/* 15 */
+EXTERN int TclMacOSXGetFileAttribute(Tcl_Interp *interp,
+ int objIndex, Tcl_Obj *fileName,
+ Tcl_Obj **attributePtrPtr);
/* Slot 16 is reserved */
/* Slot 17 is reserved */
-/* Slot 18 is reserved */
-/* Slot 19 is reserved */
-/* Slot 20 is reserved */
+/* 18 */
+EXTERN int TclMacOSXMatchType(Tcl_Interp *interp,
+ const char *pathName, const char *fileName,
+ Tcl_StatBuf *statBufPtr,
+ Tcl_GlobTypeData *types);
+/* 19 */
+EXTERN void TclMacOSXNotifierAddRunLoopMode(
+ const void *runLoopMode);
+/* 20 */
+EXTERN void TclWinAddProcess(void *hProcess, unsigned long id);
/* Slot 21 is reserved */
/* 22 */
EXTERN TclFile TclpCreateTempFile(const char *contents);
-/* Slot 23 is reserved */
-/* Slot 24 is reserved */
+/* 23 */
+EXTERN char * TclpGetTZName(int isdst);
+/* 24 */
+EXTERN char * TclWinNoBackslash(char *path);
/* Slot 25 is reserved */
-/* Slot 26 is reserved */
-/* Slot 27 is reserved */
-/* Slot 28 is reserved */
+/* 26 */
+EXTERN void TclWinSetInterfaces(int wide);
+/* 27 */
+EXTERN void TclWinFlushDirtyChannels(void);
+/* 28 */
+EXTERN void TclWinResetInterfaces(void);
/* 29 */
EXTERN int TclWinCPUID(unsigned int index, unsigned int *regs);
+/* 30 */
+EXTERN void TclGetAndDetachPids(Tcl_Interp *interp,
+ Tcl_Channel chan);
+/* 31 */
+EXTERN int TclpCloseFile(TclFile file);
#endif /* UNIX */
#ifdef __WIN32__ /* WIN */
/* 0 */
-EXTERN void TclWinConvertError(unsigned long errCode);
+EXTERN void TclWinConvertError(DWORD errCode);
/* 1 */
-EXTERN void TclWinConvertWSAError(unsigned long errCode);
+EXTERN void TclWinConvertWSAError(DWORD errCode);
/* 2 */
EXTERN struct servent * TclWinGetServByName(const char *nm,
const char *proto);
@@ -139,7 +166,7 @@ EXTERN TclFile TclpMakeFile(Tcl_Channel channel, int direction);
/* 19 */
EXTERN TclFile TclpOpenFile(const char *fname, int mode);
/* 20 */
-EXTERN void TclWinAddProcess(void *hProcess, unsigned long id);
+EXTERN void TclWinAddProcess(HANDLE hProcess, DWORD id);
/* Slot 21 is reserved */
/* 22 */
EXTERN TclFile TclpCreateTempFile(const char *contents);
@@ -159,10 +186,9 @@ EXTERN int TclWinCPUID(unsigned int index, unsigned int *regs);
#endif /* WIN */
#ifdef MAC_OSX_TCL /* MACOSX */
/* 0 */
-EXTERN void TclGetAndDetachPids(Tcl_Interp *interp,
- Tcl_Channel chan);
+EXTERN void TclWinConvertError(unsigned int errCode);
/* 1 */
-EXTERN int TclpCloseFile(TclFile file);
+EXTERN void TclWinConvertWSAError(unsigned int errCode);
/* 2 */
EXTERN Tcl_Channel TclpCreateCommandChannel(TclFile readFile,
TclFile writeFile, TclFile errorFile,
@@ -170,15 +196,13 @@ EXTERN Tcl_Channel TclpCreateCommandChannel(TclFile readFile,
/* 3 */
EXTERN int TclpCreatePipe(TclFile *readPipe, TclFile *writePipe);
/* 4 */
-EXTERN int TclpCreateProcess(Tcl_Interp *interp, int argc,
- const char **argv, TclFile inputFile,
- TclFile outputFile, TclFile errorFile,
- Tcl_Pid *pidPtr);
+EXTERN int TclWinGetTclInstance(void);
/* Slot 5 is reserved */
/* 6 */
-EXTERN TclFile TclpMakeFile(Tcl_Channel channel, int direction);
+EXTERN unsigned short TclWinNToHS(unsigned short ns);
/* 7 */
-EXTERN TclFile TclpOpenFile(const char *fname, int mode);
+EXTERN int TclWinSetSockOpt(int s, int level, int optname,
+ const char *optval, int optlen);
/* 8 */
EXTERN int TclUnixWaitForFile(int fd, int mask, int timeout);
/* 9 */
@@ -215,18 +239,29 @@ EXTERN int TclMacOSXMatchType(Tcl_Interp *interp,
/* 19 */
EXTERN void TclMacOSXNotifierAddRunLoopMode(
const void *runLoopMode);
-/* Slot 20 is reserved */
+/* 20 */
+EXTERN void TclWinAddProcess(void *hProcess, unsigned long id);
/* Slot 21 is reserved */
/* 22 */
EXTERN TclFile TclpCreateTempFile(const char *contents);
-/* Slot 23 is reserved */
-/* Slot 24 is reserved */
+/* 23 */
+EXTERN char * TclpGetTZName(int isdst);
+/* 24 */
+EXTERN char * TclWinNoBackslash(char *path);
/* Slot 25 is reserved */
-/* Slot 26 is reserved */
-/* Slot 27 is reserved */
-/* Slot 28 is reserved */
+/* 26 */
+EXTERN void TclWinSetInterfaces(int wide);
+/* 27 */
+EXTERN void TclWinFlushDirtyChannels(void);
+/* 28 */
+EXTERN void TclWinResetInterfaces(void);
/* 29 */
EXTERN int TclWinCPUID(unsigned int index, unsigned int *regs);
+/* 30 */
+EXTERN void TclGetAndDetachPids(Tcl_Interp *interp,
+ Tcl_Channel chan);
+/* 31 */
+EXTERN int TclpCloseFile(TclFile file);
#endif /* MACOSX */
typedef struct TclIntPlatStubs {
@@ -234,14 +269,14 @@ typedef struct TclIntPlatStubs {
const struct TclIntPlatStubHooks *hooks;
#if !defined(__WIN32__) && !defined(MAC_OSX_TCL) /* UNIX */
- void (*tclGetAndDetachPids) (Tcl_Interp *interp, Tcl_Channel chan); /* 0 */
- int (*tclpCloseFile) (TclFile file); /* 1 */
+ void (*tclWinConvertError) (unsigned int errCode); /* 0 */
+ void (*tclWinConvertWSAError) (unsigned int errCode); /* 1 */
Tcl_Channel (*tclpCreateCommandChannel) (TclFile readFile, TclFile writeFile, TclFile errorFile, int numPids, Tcl_Pid *pidPtr); /* 2 */
int (*tclpCreatePipe) (TclFile *readPipe, TclFile *writePipe); /* 3 */
- int (*tclpCreateProcess) (Tcl_Interp *interp, int argc, const char **argv, TclFile inputFile, TclFile outputFile, TclFile errorFile, Tcl_Pid *pidPtr); /* 4 */
+ int (*tclWinGetTclInstance) (void); /* 4 */
void (*reserved5)(void);
- TclFile (*tclpMakeFile) (Tcl_Channel channel, int direction); /* 6 */
- TclFile (*tclpOpenFile) (const char *fname, int mode); /* 7 */
+ unsigned short (*tclWinNToHS) (unsigned short ns); /* 6 */
+ int (*tclWinSetSockOpt) (int s, int level, int optname, const char *optval, int optlen); /* 7 */
int (*tclUnixWaitForFile) (int fd, int mask, int timeout); /* 8 */
int (*tclWinGetPlatformId) (void); /* 9 */
Tcl_DirEntry * (*tclpReaddir) (DIR *dir); /* 10 */
@@ -249,25 +284,27 @@ typedef struct TclIntPlatStubs {
struct tm * (*tclpGmtime_unix) (const time_t *clock); /* 12 */
char * (*tclpInetNtoa) (struct in_addr addr); /* 13 */
int (*tclUnixCopyFile) (const char *src, const char *dst, const Tcl_StatBuf *statBufPtr, int dontCopyAtts); /* 14 */
- void (*reserved15)(void);
+ int (*tclMacOSXGetFileAttribute) (Tcl_Interp *interp, int objIndex, Tcl_Obj *fileName, Tcl_Obj **attributePtrPtr); /* 15 */
void (*reserved16)(void);
void (*reserved17)(void);
- void (*reserved18)(void);
- void (*reserved19)(void);
- void (*reserved20)(void);
+ int (*tclMacOSXMatchType) (Tcl_Interp *interp, const char *pathName, const char *fileName, Tcl_StatBuf *statBufPtr, Tcl_GlobTypeData *types); /* 18 */
+ void (*tclMacOSXNotifierAddRunLoopMode) (const void *runLoopMode); /* 19 */
+ void (*tclWinAddProcess) (void *hProcess, unsigned long id); /* 20 */
void (*reserved21)(void);
TclFile (*tclpCreateTempFile) (const char *contents); /* 22 */
- void (*reserved23)(void);
- void (*reserved24)(void);
+ char * (*tclpGetTZName) (int isdst); /* 23 */
+ char * (*tclWinNoBackslash) (char *path); /* 24 */
void (*reserved25)(void);
- void (*reserved26)(void);
- void (*reserved27)(void);
- void (*reserved28)(void);
+ void (*tclWinSetInterfaces) (int wide); /* 26 */
+ void (*tclWinFlushDirtyChannels) (void); /* 27 */
+ void (*tclWinResetInterfaces) (void); /* 28 */
int (*tclWinCPUID) (unsigned int index, unsigned int *regs); /* 29 */
+ void (*tclGetAndDetachPids) (Tcl_Interp *interp, Tcl_Channel chan); /* 30 */
+ int (*tclpCloseFile) (TclFile file); /* 31 */
#endif /* UNIX */
#ifdef __WIN32__ /* WIN */
- void (*tclWinConvertError) (unsigned long errCode); /* 0 */
- void (*tclWinConvertWSAError) (unsigned long errCode); /* 1 */
+ void (*tclWinConvertError) (DWORD errCode); /* 0 */
+ void (*tclWinConvertWSAError) (DWORD errCode); /* 1 */
struct servent * (*tclWinGetServByName) (const char *nm, const char *proto); /* 2 */
int (*tclWinGetSockOpt) (SOCKET s, int level, int optname, char FAR *optval, int FAR *optlen); /* 3 */
HINSTANCE (*tclWinGetTclInstance) (void); /* 4 */
@@ -286,7 +323,7 @@ typedef struct TclIntPlatStubs {
void (*reserved17)(void);
TclFile (*tclpMakeFile) (Tcl_Channel channel, int direction); /* 18 */
TclFile (*tclpOpenFile) (const char *fname, int mode); /* 19 */
- void (*tclWinAddProcess) (void *hProcess, unsigned long id); /* 20 */
+ void (*tclWinAddProcess) (HANDLE hProcess, DWORD id); /* 20 */
void (*reserved21)(void);
TclFile (*tclpCreateTempFile) (const char *contents); /* 22 */
char * (*tclpGetTZName) (int isdst); /* 23 */
@@ -298,14 +335,14 @@ typedef struct TclIntPlatStubs {
int (*tclWinCPUID) (unsigned int index, unsigned int *regs); /* 29 */
#endif /* WIN */
#ifdef MAC_OSX_TCL /* MACOSX */
- void (*tclGetAndDetachPids) (Tcl_Interp *interp, Tcl_Channel chan); /* 0 */
- int (*tclpCloseFile) (TclFile file); /* 1 */
+ void (*tclWinConvertError) (unsigned int errCode); /* 0 */
+ void (*tclWinConvertWSAError) (unsigned int errCode); /* 1 */
Tcl_Channel (*tclpCreateCommandChannel) (TclFile readFile, TclFile writeFile, TclFile errorFile, int numPids, Tcl_Pid *pidPtr); /* 2 */
int (*tclpCreatePipe) (TclFile *readPipe, TclFile *writePipe); /* 3 */
- int (*tclpCreateProcess) (Tcl_Interp *interp, int argc, const char **argv, TclFile inputFile, TclFile outputFile, TclFile errorFile, Tcl_Pid *pidPtr); /* 4 */
+ int (*tclWinGetTclInstance) (void); /* 4 */
void (*reserved5)(void);
- TclFile (*tclpMakeFile) (Tcl_Channel channel, int direction); /* 6 */
- TclFile (*tclpOpenFile) (const char *fname, int mode); /* 7 */
+ unsigned short (*tclWinNToHS) (unsigned short ns); /* 6 */
+ int (*tclWinSetSockOpt) (int s, int level, int optname, const char *optval, int optlen); /* 7 */
int (*tclUnixWaitForFile) (int fd, int mask, int timeout); /* 8 */
int (*tclWinGetPlatformId) (void); /* 9 */
Tcl_DirEntry * (*tclpReaddir) (DIR *dir); /* 10 */
@@ -318,16 +355,18 @@ typedef struct TclIntPlatStubs {
int (*tclMacOSXCopyFileAttributes) (const char *src, const char *dst, const Tcl_StatBuf *statBufPtr); /* 17 */
int (*tclMacOSXMatchType) (Tcl_Interp *interp, const char *pathName, const char *fileName, Tcl_StatBuf *statBufPtr, Tcl_GlobTypeData *types); /* 18 */
void (*tclMacOSXNotifierAddRunLoopMode) (const void *runLoopMode); /* 19 */
- void (*reserved20)(void);
+ void (*tclWinAddProcess) (void *hProcess, unsigned long id); /* 20 */
void (*reserved21)(void);
TclFile (*tclpCreateTempFile) (const char *contents); /* 22 */
- void (*reserved23)(void);
- void (*reserved24)(void);
+ char * (*tclpGetTZName) (int isdst); /* 23 */
+ char * (*tclWinNoBackslash) (char *path); /* 24 */
void (*reserved25)(void);
- void (*reserved26)(void);
- void (*reserved27)(void);
- void (*reserved28)(void);
+ void (*tclWinSetInterfaces) (int wide); /* 26 */
+ void (*tclWinFlushDirtyChannels) (void); /* 27 */
+ void (*tclWinResetInterfaces) (void); /* 28 */
int (*tclWinCPUID) (unsigned int index, unsigned int *regs); /* 29 */
+ void (*tclGetAndDetachPids) (Tcl_Interp *interp, Tcl_Channel chan); /* 30 */
+ int (*tclpCloseFile) (TclFile file); /* 31 */
#endif /* MACOSX */
} TclIntPlatStubs;
@@ -346,21 +385,21 @@ extern const TclIntPlatStubs *tclIntPlatStubsPtr;
*/
#if !defined(__WIN32__) && !defined(MAC_OSX_TCL) /* UNIX */
-#define TclGetAndDetachPids \
- (tclIntPlatStubsPtr->tclGetAndDetachPids) /* 0 */
-#define TclpCloseFile \
- (tclIntPlatStubsPtr->tclpCloseFile) /* 1 */
+#define TclWinConvertError \
+ (tclIntPlatStubsPtr->tclWinConvertError) /* 0 */
+#define TclWinConvertWSAError \
+ (tclIntPlatStubsPtr->tclWinConvertWSAError) /* 1 */
#define TclpCreateCommandChannel \
(tclIntPlatStubsPtr->tclpCreateCommandChannel) /* 2 */
#define TclpCreatePipe \
(tclIntPlatStubsPtr->tclpCreatePipe) /* 3 */
-#define TclpCreateProcess \
- (tclIntPlatStubsPtr->tclpCreateProcess) /* 4 */
+#define TclWinGetTclInstance \
+ (tclIntPlatStubsPtr->tclWinGetTclInstance) /* 4 */
/* Slot 5 is reserved */
-#define TclpMakeFile \
- (tclIntPlatStubsPtr->tclpMakeFile) /* 6 */
-#define TclpOpenFile \
- (tclIntPlatStubsPtr->tclpOpenFile) /* 7 */
+#define TclWinNToHS \
+ (tclIntPlatStubsPtr->tclWinNToHS) /* 6 */
+#define TclWinSetSockOpt \
+ (tclIntPlatStubsPtr->tclWinSetSockOpt) /* 7 */
#define TclUnixWaitForFile \
(tclIntPlatStubsPtr->tclUnixWaitForFile) /* 8 */
#define TclWinGetPlatformId \
@@ -375,23 +414,36 @@ extern const TclIntPlatStubs *tclIntPlatStubsPtr;
(tclIntPlatStubsPtr->tclpInetNtoa) /* 13 */
#define TclUnixCopyFile \
(tclIntPlatStubsPtr->tclUnixCopyFile) /* 14 */
-/* Slot 15 is reserved */
+#define TclMacOSXGetFileAttribute \
+ (tclIntPlatStubsPtr->tclMacOSXGetFileAttribute) /* 15 */
/* Slot 16 is reserved */
/* Slot 17 is reserved */
-/* Slot 18 is reserved */
-/* Slot 19 is reserved */
-/* Slot 20 is reserved */
+#define TclMacOSXMatchType \
+ (tclIntPlatStubsPtr->tclMacOSXMatchType) /* 18 */
+#define TclMacOSXNotifierAddRunLoopMode \
+ (tclIntPlatStubsPtr->tclMacOSXNotifierAddRunLoopMode) /* 19 */
+#define TclWinAddProcess \
+ (tclIntPlatStubsPtr->tclWinAddProcess) /* 20 */
/* Slot 21 is reserved */
#define TclpCreateTempFile \
(tclIntPlatStubsPtr->tclpCreateTempFile) /* 22 */
-/* Slot 23 is reserved */
-/* Slot 24 is reserved */
+#define TclpGetTZName \
+ (tclIntPlatStubsPtr->tclpGetTZName) /* 23 */
+#define TclWinNoBackslash \
+ (tclIntPlatStubsPtr->tclWinNoBackslash) /* 24 */
/* Slot 25 is reserved */
-/* Slot 26 is reserved */
-/* Slot 27 is reserved */
-/* Slot 28 is reserved */
+#define TclWinSetInterfaces \
+ (tclIntPlatStubsPtr->tclWinSetInterfaces) /* 26 */
+#define TclWinFlushDirtyChannels \
+ (tclIntPlatStubsPtr->tclWinFlushDirtyChannels) /* 27 */
+#define TclWinResetInterfaces \
+ (tclIntPlatStubsPtr->tclWinResetInterfaces) /* 28 */
#define TclWinCPUID \
(tclIntPlatStubsPtr->tclWinCPUID) /* 29 */
+#define TclGetAndDetachPids \
+ (tclIntPlatStubsPtr->tclGetAndDetachPids) /* 30 */
+#define TclpCloseFile \
+ (tclIntPlatStubsPtr->tclpCloseFile) /* 31 */
#endif /* UNIX */
#ifdef __WIN32__ /* WIN */
#define TclWinConvertError \
@@ -450,21 +502,21 @@ extern const TclIntPlatStubs *tclIntPlatStubsPtr;
(tclIntPlatStubsPtr->tclWinCPUID) /* 29 */
#endif /* WIN */
#ifdef MAC_OSX_TCL /* MACOSX */
-#define TclGetAndDetachPids \
- (tclIntPlatStubsPtr->tclGetAndDetachPids) /* 0 */
-#define TclpCloseFile \
- (tclIntPlatStubsPtr->tclpCloseFile) /* 1 */
+#define TclWinConvertError \
+ (tclIntPlatStubsPtr->tclWinConvertError) /* 0 */
+#define TclWinConvertWSAError \
+ (tclIntPlatStubsPtr->tclWinConvertWSAError) /* 1 */
#define TclpCreateCommandChannel \
(tclIntPlatStubsPtr->tclpCreateCommandChannel) /* 2 */
#define TclpCreatePipe \
(tclIntPlatStubsPtr->tclpCreatePipe) /* 3 */
-#define TclpCreateProcess \
- (tclIntPlatStubsPtr->tclpCreateProcess) /* 4 */
+#define TclWinGetTclInstance \
+ (tclIntPlatStubsPtr->tclWinGetTclInstance) /* 4 */
/* Slot 5 is reserved */
-#define TclpMakeFile \
- (tclIntPlatStubsPtr->tclpMakeFile) /* 6 */
-#define TclpOpenFile \
- (tclIntPlatStubsPtr->tclpOpenFile) /* 7 */
+#define TclWinNToHS \
+ (tclIntPlatStubsPtr->tclWinNToHS) /* 6 */
+#define TclWinSetSockOpt \
+ (tclIntPlatStubsPtr->tclWinSetSockOpt) /* 7 */
#define TclUnixWaitForFile \
(tclIntPlatStubsPtr->tclUnixWaitForFile) /* 8 */
#define TclWinGetPlatformId \
@@ -489,18 +541,28 @@ extern const TclIntPlatStubs *tclIntPlatStubsPtr;
(tclIntPlatStubsPtr->tclMacOSXMatchType) /* 18 */
#define TclMacOSXNotifierAddRunLoopMode \
(tclIntPlatStubsPtr->tclMacOSXNotifierAddRunLoopMode) /* 19 */
-/* Slot 20 is reserved */
+#define TclWinAddProcess \
+ (tclIntPlatStubsPtr->tclWinAddProcess) /* 20 */
/* Slot 21 is reserved */
#define TclpCreateTempFile \
(tclIntPlatStubsPtr->tclpCreateTempFile) /* 22 */
-/* Slot 23 is reserved */
-/* Slot 24 is reserved */
+#define TclpGetTZName \
+ (tclIntPlatStubsPtr->tclpGetTZName) /* 23 */
+#define TclWinNoBackslash \
+ (tclIntPlatStubsPtr->tclWinNoBackslash) /* 24 */
/* Slot 25 is reserved */
-/* Slot 26 is reserved */
-/* Slot 27 is reserved */
-/* Slot 28 is reserved */
+#define TclWinSetInterfaces \
+ (tclIntPlatStubsPtr->tclWinSetInterfaces) /* 26 */
+#define TclWinFlushDirtyChannels \
+ (tclIntPlatStubsPtr->tclWinFlushDirtyChannels) /* 27 */
+#define TclWinResetInterfaces \
+ (tclIntPlatStubsPtr->tclWinResetInterfaces) /* 28 */
#define TclWinCPUID \
(tclIntPlatStubsPtr->tclWinCPUID) /* 29 */
+#define TclGetAndDetachPids \
+ (tclIntPlatStubsPtr->tclGetAndDetachPids) /* 30 */
+#define TclpCloseFile \
+ (tclIntPlatStubsPtr->tclpCloseFile) /* 31 */
#endif /* MACOSX */
#endif /* defined(USE_TCL_STUBS) */
@@ -512,4 +574,24 @@ extern const TclIntPlatStubs *tclIntPlatStubsPtr;
#undef TclpLocaltime_unix
#undef TclpGmtime_unix
+#if !defined(__WIN32__) && defined(USE_TCL_STUBS)
+# ifdef __CYGWIN__
+# define TclpCreateProcess ((int (*) _ANSI_ARGS_((Tcl_Interp *, int, \
+ CONST char **, TclFile, TclFile, TclFile, Tcl_Pid *))) \
+ tclIntPlatStubsPtr->tclMacOSXGetFileAttribute)
+# define TclpMakeFile ((TclFile (*) _ANSI_ARGS_((Tcl_Channel channel, \
+ int direction))) tclIntPlatStubsPtr->tclMacOSXMatchType)
+# define TclpOpenFile ((TclFile (*) _ANSI_ARGS_((CONST char *, int))) \
+ tclIntPlatStubsPtr->tclMacOSXNotifierAddRunLoopMode)
+# else
+# define TclpCreateProcess ((int (*) _ANSI_ARGS_((Tcl_Interp *, int, \
+ CONST char **, TclFile, TclFile, TclFile, Tcl_Pid *))) \
+ tclIntPlatStubsPtr->tclWinGetTclInstance)
+# define TclpMakeFile ((TclFile (*) _ANSI_ARGS_((Tcl_Channel channel, \
+ int direction))) tclIntPlatStubsPtr->tclWinNToHS)
+# define TclpOpenFile ((TclFile (*) _ANSI_ARGS_((CONST char *, int))) \
+ tclIntPlatStubsPtr->tclWinNToHS)
+# endif
+#endif
+
#endif /* _TCLINTPLATDECLS */
diff --git a/generic/tclOO.c b/generic/tclOO.c
index 8ac2039..9dd8162 100644
--- a/generic/tclOO.c
+++ b/generic/tclOO.c
@@ -28,27 +28,20 @@ static const struct {
{"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},
- {"variable", TclOODefineVariablesObjCmd, 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},
- {"variable", TclOODefineVariablesObjCmd, 1},
{NULL, NULL, 0}
};
@@ -79,7 +72,7 @@ static int FinalizeNext(ClientData data[],
Tcl_Interp *interp, int result);
static int FinalizeObjectCall(ClientData data[],
Tcl_Interp *interp, int result);
-static void InitFoundation(Tcl_Interp *interp);
+static int InitFoundation(Tcl_Interp *interp);
static void KillFoundation(ClientData clientData,
Tcl_Interp *interp);
static void MyDeleted(ClientData clientData);
@@ -129,12 +122,94 @@ static const DeclaredClassMethod objMethods[] = {
{NULL, 0, {0, NULL, NULL, NULL, NULL}}
};
-static char initScript[] =
- "package ifneeded TclOO " TCLOO_PATCHLEVEL " {# Already present, OK?};"
- "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;"; */
+/*
+ * Scripted parts of TclOO. First, the master script (cannot be outside this
+ * file).
+ */
+
+static const char *initScript =
+"package ifneeded TclOO " TCLOO_PATCHLEVEL " {# Already present, OK?};"
+"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;"; */
+
+/*
+ * The body of the constructor for oo::class.
+ */
+
+static const char *classConstructorBody =
+"set script [list ::oo::define [self] $definitionScript];"
+"lassign [::oo::UpCatch $script] msg opts;"
+"if {[dict get $opts -code] == 1} {"
+" dict set opts -errorline 0xDeadBeef"
+"};"
+"return -options $opts $msg;";
+
+/*
+ * The scripted part of the definitions of slots.
+ */
+
+static const char *slotScript =
+"::oo::define ::oo::Slot {\n"
+" method Get {} {error unimplemented}\n"
+" method Set list {error unimplemented}\n"
+" method -set args {\n"
+" uplevel 1 [list [namespace which my] Set $args]\n"
+" }\n"
+" method -append args {\n"
+" uplevel 1 [list [namespace which my] Set [list"
+" {*}[uplevel 1 [list [namespace which my] Get]] {*}$args]]\n"
+" }\n"
+" method -clear {} {uplevel 1 [list [namespace which my] Set {}]}\n"
+" forward --default-operation my -append\n"
+" method unknown {args} {\n"
+" set def --default-operation\n"
+" if {[llength $args] == 0} {\n"
+" return [uplevel 1 [list [namespace which my] $def]]\n"
+" } elseif {![string match -* [lindex $args 0]]} {\n"
+" return [uplevel 1 [list [namespace which my] $def {*}$args]]\n"
+" }\n"
+" next {*}$args\n"
+" }\n"
+" export -set -append -clear\n"
+" unexport unknown destroy\n"
+"}\n"
+"::oo::objdefine ::oo::define::superclass forward --default-operation my -set\n"
+"::oo::objdefine ::oo::define::mixin forward --default-operation my -set\n"
+"::oo::objdefine ::oo::objdefine::mixin forward --default-operation my -set\n";
+
+/*
+ * The body of the <cloned> method of oo::object.
+ */
+
+static const char *clonedBody =
+"foreach p [info procs [info object namespace $originObject]::*] {"
+" set args [info args $p];"
+" set idx -1;"
+" foreach a $args {"
+" lset args [incr idx] "
+" [if {[info default $p $a d]} {list $a $d} {list $a}]"
+" };"
+" set b [info body $p];"
+" set p [namespace tail $p];"
+" proc $p $args $b;"
+"};"
+"foreach v [info vars [info object namespace $originObject]::*] {"
+" upvar 0 $v vOrigin;"
+" namespace upvar [namespace current] [namespace tail $v] vNew;"
+" if {[info exists vOrigin]} {"
+" if {[array exists vOrigin]} {"
+" array set vNew [array get vOrigin];"
+" } else {"
+" set vNew $vOrigin;"
+" }"
+" }"
+"}";
+
+/*
+ * The actual definition of the variable holding the TclOO stub table.
+ */
MODULE_SCOPE const TclOOStubs tclOOStubs;
@@ -144,6 +219,20 @@ MODULE_SCOPE const TclOOStubs tclOOStubs;
#define GetFoundation(interp) \
((Foundation *)((Interp *)(interp))->objectFoundation)
+
+/*
+ * Macros to make inspecting into the guts of an object cleaner.
+ *
+ * The ocPtr parameter (only in these macros) is assumed to work fine with
+ * either an oPtr or a classPtr. Note that the roots oo::object and oo::class
+ * have _both_ their object and class flags tagged with ROOT_OBJECT and
+ * ROOT_CLASS respectively.
+ */
+
+#define Deleted(oPtr) (((Object *)(oPtr))->command == NULL)
+#define IsRootObject(ocPtr) ((ocPtr)->flags & ROOT_OBJECT)
+#define IsRootClass(ocPtr) ((ocPtr)->flags & ROOT_CLASS)
+#define IsRoot(ocPtr) ((ocPtr)->flags & (ROOT_OBJECT|ROOT_CLASS))
/*
* ----------------------------------------------------------------------
@@ -170,7 +259,9 @@ TclOOInit(
* Build the core of the OO system.
*/
- InitFoundation(interp);
+ if (InitFoundation(interp) != TCL_OK) {
+ return TCL_ERROR;
+ }
/*
* Run our initialization script and, if that works, declare the package
@@ -214,7 +305,7 @@ TclOOGetFoundation(
* ----------------------------------------------------------------------
*/
-static void
+static int
InitFoundation(
Tcl_Interp *interp)
{
@@ -245,17 +336,19 @@ InitFoundation(
DeletedHelpersNamespace);
fPtr->epoch = 0;
fPtr->tsdPtr = tsdPtr;
- fPtr->unknownMethodNameObj = Tcl_NewStringObj("unknown", -1);
- fPtr->constructorName = Tcl_NewStringObj("<constructor>", -1);
- fPtr->destructorName = Tcl_NewStringObj("<destructor>", -1);
+ TclNewLiteralStringObj(fPtr->unknownMethodNameObj, "unknown");
+ TclNewLiteralStringObj(fPtr->constructorName, "<constructor>");
+ TclNewLiteralStringObj(fPtr->destructorName, "<destructor>");
+ TclNewLiteralStringObj(fPtr->clonedName, "<cloned>");
Tcl_IncrRefCount(fPtr->unknownMethodNameObj);
Tcl_IncrRefCount(fPtr->constructorName);
Tcl_IncrRefCount(fPtr->destructorName);
+ Tcl_IncrRefCount(fPtr->clonedName);
Tcl_NRCreateCommand(interp, "::oo::UpCatch", TclOOUpcatchCmd,
TclOONRUpcatch, NULL, NULL);
Tcl_CreateObjCommand(interp, "::oo::UnknownDefinition",
TclOOUnknownDefinition, NULL, NULL);
- namePtr = Tcl_NewStringObj("::oo::UnknownDefinition", -1);
+ TclNewLiteralStringObj(namePtr, "::oo::UnknownDefinition");
Tcl_SetNamespaceUnknownHandler(interp, fPtr->defineNs, namePtr);
Tcl_SetNamespaceUnknownHandler(interp, fPtr->objdefNs, namePtr);
@@ -292,11 +385,13 @@ InitFoundation(
AllocObject(interp, "::oo::class", NULL));
fPtr->objectCls->thisPtr->selfCls = fPtr->classCls;
fPtr->objectCls->thisPtr->flags |= ROOT_OBJECT;
+ fPtr->objectCls->flags |= ROOT_OBJECT;
fPtr->objectCls->superclasses.num = 0;
ckfree(fPtr->objectCls->superclasses.list);
fPtr->objectCls->superclasses.list = NULL;
fPtr->classCls->thisPtr->selfCls = fPtr->classCls;
fPtr->classCls->thisPtr->flags |= ROOT_CLASS;
+ fPtr->classCls->flags |= ROOT_CLASS;
TclOOAddToInstances(fPtr->objectCls->thisPtr, fPtr->classCls);
TclOOAddToInstances(fPtr->classCls->thisPtr, fPtr->classCls);
AddRef(fPtr->objectCls->thisPtr);
@@ -314,6 +409,18 @@ InitFoundation(
}
/*
+ * Create the default <cloned> method implementation, used when 'oo::copy'
+ * is called to finish the copying of one object to another.
+ */
+
+ TclNewLiteralStringObj(argsPtr, "originObject");
+ Tcl_IncrRefCount(argsPtr);
+ bodyPtr = Tcl_NewStringObj(clonedBody, -1);
+ TclOONewProcMethod(interp, fPtr->objectCls, 0, fPtr->clonedName, argsPtr,
+ bodyPtr, NULL);
+ Tcl_DecrRefCount(argsPtr);
+
+ /*
* 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.
@@ -323,19 +430,13 @@ InitFoundation(
* that is confusing.
*/
- namePtr = Tcl_NewStringObj("new", -1);
+ TclNewLiteralStringObj(namePtr, "new");
Tcl_NewInstanceMethod(interp, (Tcl_Object) fPtr->classCls->thisPtr,
namePtr /* keeps ref */, 0 /* ==private */, NULL, NULL);
- argsPtr = Tcl_NewStringObj("{definitionScript {}}", -1);
+ TclNewLiteralStringObj(argsPtr, "{definitionScript {}}");
Tcl_IncrRefCount(argsPtr);
- bodyPtr = Tcl_NewStringObj(
- "set script [list ::oo::define [self] $definitionScript];"
- "lassign [::oo::UpCatch $script] msg opts\n"
- "if {[dict get $opts -code] == 1} {"
- " dict set opts -errorline 0xDeadBeef\n"
- "}\n"
- "return -options $opts $msg", -1);
+ bodyPtr = Tcl_NewStringObj(classConstructorBody, -1);
fPtr->classCls->constructorPtr = TclOONewProcMethod(interp,
fPtr->classCls, 0, NULL, argsPtr, bodyPtr, NULL);
Tcl_DecrRefCount(argsPtr);
@@ -357,6 +458,15 @@ InitFoundation(
NULL);
Tcl_CreateObjCommand(interp, "::oo::copy", TclOOCopyObjectCmd, NULL,NULL);
TclOOInitInfo(interp);
+
+ /*
+ * Now make the class of slots.
+ */
+
+ if (TclOODefineSlots(fPtr) != TCL_OK) {
+ return TCL_ERROR;
+ }
+ return Tcl_Eval(interp, slotScript);
}
/*
@@ -422,6 +532,7 @@ KillFoundation(
Tcl_DecrRefCount(fPtr->unknownMethodNameObj);
Tcl_DecrRefCount(fPtr->constructorName);
Tcl_DecrRefCount(fPtr->destructorName);
+ Tcl_DecrRefCount(fPtr->clonedName);
ckfree(fPtr);
}
@@ -669,8 +780,7 @@ ObjectRenamedTrace(
int flags) /* Why was the object deleted? */
{
Object *oPtr = clientData;
- Class *clsPtr;
- CallContext *contextPtr;
+ Foundation *fPtr = oPtr->fPtr;
/*
* If this is a rename and not a delete of the object, we just flush the
@@ -702,17 +812,20 @@ ObjectRenamedTrace(
*/
AddRef(oPtr);
+ AddRef(fPtr->classCls);
+ AddRef(fPtr->objectCls);
+ AddRef(fPtr->classCls->thisPtr);
+ AddRef(fPtr->objectCls->thisPtr);
oPtr->command = NULL;
- oPtr->flags |= OBJECT_DELETED;
- if (!(oPtr->flags & DESTRUCTOR_CALLED) && (!Tcl_InterpDeleted(interp)
- || (oPtr->flags & (ROOT_OBJECT|ROOT_CLASS)))) {
- contextPtr = TclOOGetCallContext(oPtr, NULL, DESTRUCTOR, NULL);
+ if (!(oPtr->flags & DESTRUCTOR_CALLED) && !Tcl_InterpDeleted(interp)) {
+ CallContext *contextPtr =
+ TclOOGetCallContext(oPtr, NULL, DESTRUCTOR, NULL);
+ int result;
+ Tcl_InterpState state;
+
oPtr->flags |= DESTRUCTOR_CALLED;
if (contextPtr != NULL) {
- int result;
- Tcl_InterpState state;
-
contextPtr->callPtr->flags |= DESTRUCTOR;
contextPtr->skip = 0;
state = Tcl_SaveInterpState(interp, TCL_OK);
@@ -731,25 +844,20 @@ ObjectRenamedTrace(
* and nuke the namespace (which triggers the final crushing of the object
* structure itself).
*
- * The class of classes needs some special care; if it is deleted (and
+ * The class of objects needs some special care; if it is deleted (and
* we're not killing the whole interpreter) we force the delete of the
- * class of objects now as well. Due to the incestuous nature of those two
+ * class of classes now as well. Due to the incestuous nature of those two
* classes, if one goes the other must too and yet the tangle can
* sometimes not go away automatically; we force it here. [Bug 2962664]
*/
- if (!Tcl_InterpDeleted(interp)) {
- if ((oPtr->flags & ROOT_OBJECT) && oPtr->fPtr->classCls != NULL) {
- Tcl_DeleteCommandFromToken(interp,
- oPtr->fPtr->classCls->thisPtr->command);
- } else if (oPtr->flags & ROOT_CLASS) {
- oPtr->fPtr->classCls = NULL;
- }
+ if (!Tcl_InterpDeleted(interp) && IsRootObject(oPtr)
+ && !Deleted(fPtr->classCls->thisPtr)) {
+ Tcl_DeleteCommandFromToken(interp, fPtr->classCls->thisPtr->command);
}
- clsPtr = oPtr->classPtr;
- if (clsPtr != NULL) {
- AddRef(clsPtr);
+ if (oPtr->classPtr != NULL) {
+ AddRef(oPtr->classPtr);
ReleaseClassContents(interp, oPtr);
}
@@ -761,9 +869,13 @@ ObjectRenamedTrace(
if (((Namespace *) oPtr->namespacePtr)->earlyDeleteProc != NULL) {
Tcl_DeleteNamespace(oPtr->namespacePtr);
}
- if (clsPtr) {
- DelRef(clsPtr);
+ if (oPtr->classPtr) {
+ DelRef(oPtr->classPtr);
}
+ DelRef(fPtr->classCls->thisPtr);
+ DelRef(fPtr->objectCls->thisPtr);
+ DelRef(fPtr->classCls);
+ DelRef(fPtr->objectCls);
DelRef(oPtr);
}
@@ -783,77 +895,128 @@ 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;
+ FOREACH_HASH_DECLS;
+ int i;
+ Class *clsPtr = oPtr->classPtr, *mixinSubclassPtr, *subclassPtr;
+ Object *instancePtr;
+ Foundation *fPtr = oPtr->fPtr;
/*
- * 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.
+ * Sanity check!
*/
- 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]);
- AddRef(list[i]->thisPtr);
+ if (!Deleted(oPtr)) {
+ if (IsRootClass(oPtr)) {
+ Tcl_Panic("deleting class structure for non-deleted %s",
+ "::oo::class");
+ } else if (IsRootObject(oPtr)) {
+ Tcl_Panic("deleting class structure for non-deleted %s",
+ "::oo::object");
+ } else {
+ Tcl_Panic("deleting class structure for non-deleted %s",
+ "general object");
+ }
}
- for (i=0 ; i<n ; i++) {
- if (!(list[i]->thisPtr->flags & OBJECT_DELETED)) {
- list[i]->thisPtr->flags |= OBJECT_DELETED;
- Tcl_DeleteCommandFromToken(interp, list[i]->thisPtr->command);
+
+ /*
+ * Lock a number of dependent objects until we've stopped putting our
+ * fingers in them.
+ */
+
+ FOREACH(mixinSubclassPtr, clsPtr->mixinSubs) {
+ if (mixinSubclassPtr != NULL) {
+ AddRef(mixinSubclassPtr);
+ AddRef(mixinSubclassPtr->thisPtr);
}
- DelRef(list[i]->thisPtr);
- DelRef(list[i]);
}
- if (list != NULL) {
- ckfree(list);
+ FOREACH(subclassPtr, clsPtr->subclasses) {
+ if (subclassPtr != NULL && !IsRoot(subclassPtr)) {
+ AddRef(subclassPtr);
+ AddRef(subclassPtr->thisPtr);
+ }
}
-
- 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]);
- AddRef(list[i]->thisPtr);
+ if (!IsRootClass(oPtr)) {
+ FOREACH(instancePtr, clsPtr->instances) {
+ if (instancePtr != NULL && !IsRoot(instancePtr)) {
+ AddRef(instancePtr);
+ }
+ }
}
- for (i=0 ; i<n ; i++) {
- if (!(list[i]->thisPtr->flags & OBJECT_DELETED)) {
- list[i]->thisPtr->flags |= OBJECT_DELETED;
- Tcl_DeleteCommandFromToken(interp, list[i]->thisPtr->command);
+
+ /*
+ * Squelch classes that this class has been mixed into.
+ */
+
+ FOREACH(mixinSubclassPtr, clsPtr->mixinSubs) {
+ if (mixinSubclassPtr == NULL) {
+ continue;
+ }
+ if (!Deleted(mixinSubclassPtr->thisPtr)) {
+ Tcl_DeleteCommandFromToken(interp,
+ mixinSubclassPtr->thisPtr->command);
}
- DelRef(list[i]->thisPtr);
- DelRef(list[i]);
+ DelRef(mixinSubclassPtr->thisPtr);
+ DelRef(mixinSubclassPtr);
}
- if (list != NULL) {
- ckfree(list);
+ if (clsPtr->mixinSubs.list != NULL) {
+ ckfree(clsPtr->mixinSubs.list);
+ clsPtr->mixinSubs.list = NULL;
+ clsPtr->mixinSubs.num = 0;
}
- 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]);
+ /*
+ * Squelch subclasses of this class.
+ */
+
+ FOREACH(subclassPtr, clsPtr->subclasses) {
+ if (subclassPtr == NULL || IsRoot(subclassPtr)) {
+ continue;
+ }
+ if (!Deleted(subclassPtr->thisPtr)) {
+ Tcl_DeleteCommandFromToken(interp, subclassPtr->thisPtr->command);
+ }
+ DelRef(subclassPtr->thisPtr);
+ DelRef(subclassPtr);
+ }
+ if (clsPtr->subclasses.list != NULL) {
+ ckfree(clsPtr->subclasses.list);
+ clsPtr->subclasses.list = NULL;
+ clsPtr->subclasses.num = 0;
}
- for (i=0 ; i<n ; i++) {
- if (!(insts[i]->flags & OBJECT_DELETED)) {
- insts[i]->flags |= OBJECT_DELETED;
- Tcl_DeleteCommandFromToken(interp, insts[i]->command);
+
+ /*
+ * Squelch instances of this class (includes objects we're mixed into).
+ */
+
+ if (!IsRootClass(oPtr)) {
+ FOREACH(instancePtr, clsPtr->instances) {
+ if (instancePtr == NULL || IsRoot(instancePtr)) {
+ continue;
+ }
+ if (!Deleted(instancePtr)) {
+ Tcl_DeleteCommandFromToken(interp, instancePtr->command);
+ }
+ DelRef(instancePtr);
}
- DelRef(insts[i]);
}
- if (insts != NULL) {
- ckfree(insts);
+ if (clsPtr->instances.list != NULL) {
+ ckfree(clsPtr->instances.list);
+ clsPtr->instances.list = NULL;
+ clsPtr->instances.num = 0;
+ }
+
+ /*
+ * Special: We delete these after everything else.
+ */
+
+ if (IsRootClass(oPtr) && !Deleted(fPtr->objectCls->thisPtr)) {
+ Tcl_DeleteCommandFromToken(interp, fPtr->objectCls->thisPtr->command);
}
+ /*
+ * Squelch method implementation chain caches.
+ */
+
if (clsPtr->constructorChainPtr) {
TclOODeleteChain(clsPtr->constructorChainPtr);
clsPtr->constructorChainPtr = NULL;
@@ -863,7 +1026,6 @@ ReleaseClassContents(
clsPtr->destructorChainPtr = NULL;
}
if (clsPtr->classChainCache) {
- FOREACH_HASH_DECLS;
CallChain *callPtr;
FOREACH_HASH_VALUE(callPtr, clsPtr->classChainCache) {
@@ -874,6 +1036,10 @@ ReleaseClassContents(
clsPtr->classChainCache = NULL;
}
+ /*
+ * Squelch our filter list.
+ */
+
if (clsPtr->filters.num) {
Tcl_Obj *filterObj;
@@ -884,9 +1050,11 @@ ReleaseClassContents(
clsPtr->filters.num = 0;
}
+ /*
+ * Squelch our metadata.
+ */
if (clsPtr->metadataPtr != NULL) {
- FOREACH_HASH_DECLS;
Tcl_ObjectMetadataType *metadataTypePtr;
ClientData value;
@@ -922,7 +1090,7 @@ ObjectNamespaceDeleted(
Class *clsPtr = oPtr->classPtr, *mixinPtr;
Method *mPtr;
Tcl_Obj *filterObj, *variableObj;
- int i, preserved = !(oPtr->flags & OBJECT_DELETED);
+ int i;
/*
* Instruct everyone to no longer use any allocated fields of the object.
@@ -931,27 +1099,19 @@ ObjectNamespaceDeleted(
* point into freed memory, allowing crashes.
*/
- oPtr->flags |= OBJECT_DELETED;
if (oPtr->command) {
Tcl_DeleteCommandFromToken(oPtr->fPtr->interp, oPtr->command);
}
if (oPtr->myCommand) {
Tcl_DeleteCommandFromToken(oPtr->fPtr->interp, oPtr->myCommand);
}
- if (preserved) {
- AddRef(oPtr);
- if (clsPtr != NULL) {
- AddRef(clsPtr);
- ReleaseClassContents(NULL, oPtr);
- }
- }
/*
* Splice the object out of its context. After this, we must *not* call
* methods on the object.
*/
- if (!(oPtr->flags & ROOT_OBJECT)) {
+ if (!IsRootObject(oPtr)) {
TclOORemoveFromInstances(oPtr, oPtr->selfCls);
}
@@ -1007,11 +1167,10 @@ ObjectNamespaceDeleted(
if (clsPtr != NULL) {
Class *superPtr;
+ Tcl_ObjectMetadataType *metadataTypePtr;
+ ClientData value;
if (clsPtr->metadataPtr != NULL) {
- Tcl_ObjectMetadataType *metadataTypePtr;
- ClientData value;
-
FOREACH_HASH(metadataTypePtr, value, clsPtr->metadataPtr) {
metadataTypePtr->deleteProc(value);
}
@@ -1028,7 +1187,7 @@ ObjectNamespaceDeleted(
clsPtr->filters.num = 0;
}
FOREACH(mixinPtr, clsPtr->mixins) {
- if (!(mixinPtr->thisPtr->flags & OBJECT_DELETED)) {
+ if (!Deleted(mixinPtr->thisPtr)) {
TclOORemoveFromMixinSubs(clsPtr, mixinPtr);
}
}
@@ -1037,7 +1196,7 @@ ObjectNamespaceDeleted(
clsPtr->mixins.num = 0;
}
FOREACH(superPtr, clsPtr->superclasses) {
- if (!(superPtr->thisPtr->flags & OBJECT_DELETED)) {
+ if (!Deleted(superPtr->thisPtr)) {
TclOORemoveFromSubclasses(clsPtr, superPtr);
}
}
@@ -1080,12 +1239,6 @@ ObjectNamespaceDeleted(
*/
DelRef(oPtr);
- if (preserved) {
- if (clsPtr) {
- DelRef(clsPtr);
- }
- DelRef(oPtr);
- }
}
/*
@@ -1116,12 +1269,16 @@ TclOORemoveFromInstances(
return;
removeInstance:
- clsPtr->instances.num--;
- if (i < clsPtr->instances.num) {
- clsPtr->instances.list[i] =
- clsPtr->instances.list[clsPtr->instances.num];
+ if (Deleted(clsPtr->thisPtr)) {
+ clsPtr->instances.list[i] = NULL;
+ } else {
+ 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;
}
- clsPtr->instances.list[clsPtr->instances.num] = NULL;
}
/*
@@ -1142,6 +1299,9 @@ TclOOAddToInstances(
* assumed that the class is not already
* present as an instance in the class. */
{
+ if (Deleted(clsPtr->thisPtr)) {
+ return;
+ }
if (clsPtr->instances.num >= clsPtr->instances.size) {
clsPtr->instances.size += ALLOC_CHUNK;
if (clsPtr->instances.size == ALLOC_CHUNK) {
@@ -1182,12 +1342,16 @@ TclOORemoveFromSubclasses(
return;
removeSubclass:
- superPtr->subclasses.num--;
- if (i < superPtr->subclasses.num) {
- superPtr->subclasses.list[i] =
- superPtr->subclasses.list[superPtr->subclasses.num];
+ if (Deleted(superPtr->thisPtr)) {
+ superPtr->subclasses.list[i] = NULL;
+ } else {
+ 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;
}
- superPtr->subclasses.list[superPtr->subclasses.num] = NULL;
}
/*
@@ -1208,6 +1372,9 @@ TclOOAddToSubclasses(
* is assumed that the class is not already
* present as a subclass in the superclass. */
{
+ if (Deleted(superPtr->thisPtr)) {
+ return;
+ }
if (superPtr->subclasses.num >= superPtr->subclasses.size) {
superPtr->subclasses.size += ALLOC_CHUNK;
if (superPtr->subclasses.size == ALLOC_CHUNK) {
@@ -1248,12 +1415,16 @@ TclOORemoveFromMixinSubs(
return;
removeSubclass:
- superPtr->mixinSubs.num--;
- if (i < superPtr->mixinSubs.num) {
- superPtr->mixinSubs.list[i] =
- superPtr->mixinSubs.list[superPtr->mixinSubs.num];
+ if (Deleted(superPtr->thisPtr)) {
+ superPtr->mixinSubs.list[i] = NULL;
+ } else {
+ 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;
}
- superPtr->mixinSubs.list[superPtr->mixinSubs.num] = NULL;
}
/*
@@ -1274,6 +1445,9 @@ TclOOAddToMixinSubs(
* is assumed that the class is not already
* present as a subclass in the superclass. */
{
+ if (Deleted(superPtr->thisPtr)) {
+ return;
+ }
if (superPtr->mixinSubs.num >= superPtr->mixinSubs.size) {
superPtr->mixinSubs.size += ALLOC_CHUNK;
if (superPtr->mixinSubs.size == ALLOC_CHUNK) {
@@ -1444,7 +1618,7 @@ Tcl_NewObjectInstance(
TclOOGetCallContext(oPtr, NULL, CONSTRUCTOR, NULL);
if (contextPtr != NULL) {
- int result, flags;
+ int result;
Tcl_InterpState state;
state = Tcl_SaveInterpState(interp, TCL_OK);
@@ -1452,7 +1626,6 @@ Tcl_NewObjectInstance(
contextPtr->skip = skip;
result = Tcl_NRCallObjProc(interp, TclOOInvokeContext, contextPtr,
objc, objv);
- flags = oPtr->flags;
/*
* It's an error if the object was whacked in the constructor.
@@ -1460,7 +1633,7 @@ Tcl_NewObjectInstance(
* errors by accident...) [Bug 2903011]
*/
- if (result != TCL_ERROR && (flags & OBJECT_DELETED)) {
+ if (result != TCL_ERROR && Deleted(oPtr)) {
Tcl_SetResult(interp, "object deleted in constructor",
TCL_STATIC);
Tcl_SetErrorCode(interp, "TCL", "OO", "STILLBORN", NULL);
@@ -1475,7 +1648,7 @@ Tcl_NewObjectInstance(
* bad. [Bug 2903011]
*/
- if (!(flags & OBJECT_DELETED)) {
+ if (!Deleted(oPtr)) {
Tcl_DeleteCommandFromToken(interp, oPtr->command);
}
return NULL;
@@ -1572,6 +1745,7 @@ TclNRNewObjectInstance(
* Fire off the constructors non-recursively.
*/
+ AddRef(oPtr);
TclNRAddCallback(interp, FinalizeAlloc, contextPtr, oPtr, state,
objectPtr);
TclPushTailcallPoint(interp);
@@ -1588,7 +1762,7 @@ FinalizeAlloc(
Object *oPtr = data[1];
Tcl_InterpState state = data[2];
Tcl_Object *objectPtr = data[3];
- int flags = oPtr->flags;
+ //int flags = oPtr->flags;
/*
* It's an error if the object was whacked in the constructor. Force this
@@ -1596,7 +1770,7 @@ FinalizeAlloc(
* [Bug 2903011]
*/
- if (result != TCL_ERROR && (flags & OBJECT_DELETED)) {
+ if (result != TCL_ERROR && Deleted(oPtr)) {
Tcl_SetResult(interp, "object deleted in constructor", TCL_STATIC);
Tcl_SetErrorCode(interp, "TCL", "OO", "STILLBORN", NULL);
result = TCL_ERROR;
@@ -1610,13 +1784,15 @@ FinalizeAlloc(
* 2903011]
*/
- if (!(flags & OBJECT_DELETED)) {
+ if (!Deleted(oPtr)) {
Tcl_DeleteCommandFromToken(interp, oPtr->command);
}
+ DelRef(oPtr);
return TCL_ERROR;
}
Tcl_RestoreInterpState(interp, state);
*objectPtr = (Tcl_Object) oPtr;
+ DelRef(oPtr);
return TCL_OK;
}
@@ -1643,20 +1819,15 @@ Tcl_CopyObjectInstance(
FOREACH_HASH_DECLS;
Method *mPtr;
Class *mixinPtr;
- Tcl_Obj *keyPtr, *filterObj, *variableObj;
- int i;
+ CallContext *contextPtr;
+ Tcl_Obj *keyPtr, *filterObj, *variableObj, *args[3];
+ int i, result;
/*
- * Sanity checks.
+ * Sanity check.
*/
- if (targetName == NULL && oPtr->classPtr != NULL) {
- Tcl_AppendResult(interp, "must supply a name when copying a class",
- NULL);
- Tcl_SetErrorCode(interp, "TCL", "OO", "NO_COPY_TARGET", NULL);
- return NULL;
- }
- if (oPtr->flags & ROOT_CLASS) {
+ if (IsRootClass(oPtr)) {
Tcl_AppendResult(interp, "may not clone the class of classes", NULL);
Tcl_SetErrorCode(interp, "TCL", "OO", "CLONING_CLASS", NULL);
return NULL;
@@ -1728,7 +1899,7 @@ Tcl_CopyObjectInstance(
*/
o2Ptr->flags = oPtr->flags & ~(
- OBJECT_DELETED | ROOT_OBJECT | FILTER_HANDLING);
+ OBJECT_DELETED | ROOT_OBJECT | ROOT_CLASS | FILTER_HANDLING);
/*
* Copy the object's metadata.
@@ -1879,6 +2050,26 @@ Tcl_CopyObjectInstance(
}
}
+ contextPtr = TclOOGetCallContext(o2Ptr, oPtr->fPtr->clonedName, 0, NULL);
+ if (contextPtr) {
+ args[0] = TclOOObjectName(interp, o2Ptr);
+ args[1] = oPtr->fPtr->clonedName;
+ args[2] = TclOOObjectName(interp, oPtr);
+ Tcl_IncrRefCount(args[0]);
+ Tcl_IncrRefCount(args[1]);
+ Tcl_IncrRefCount(args[2]);
+ result = Tcl_NRCallObjProc(interp, TclOOInvokeContext, contextPtr, 3,
+ args);
+ TclDecrRefCount(args[0]);
+ TclDecrRefCount(args[1]);
+ TclDecrRefCount(args[2]);
+ TclOODeleteContext(contextPtr);
+ if (result != TCL_OK) {
+ Tcl_DeleteCommandFromToken(interp, o2Ptr->command);
+ return NULL;
+ }
+ }
+
return (Tcl_Object) o2Ptr;
}
@@ -2254,9 +2445,15 @@ TclOOObjectCmdCore(
Tcl_Obj *methodNamePtr;
int result;
+ /*
+ * If we've no method name, throw this directly into the unknown
+ * processing.
+ */
+
if (objc < 2) {
- Tcl_WrongNumArgs(interp, 1, objv, "method ?arg ...?");
- return TCL_ERROR;
+ flags |= FORCE_UNKNOWN;
+ methodNamePtr = NULL;
+ goto noMapping;
}
/*
@@ -2710,7 +2907,7 @@ int
Tcl_ObjectDeleted(
Tcl_Object object)
{
- return (((Object *)object)->flags & OBJECT_DELETED) ? 1 : 0;
+ return Deleted(object) ? 1 : 0;
}
Tcl_Object
diff --git a/generic/tclOOBasic.c b/generic/tclOOBasic.c
index b286088..329f0a4 100644
--- a/generic/tclOOBasic.c
+++ b/generic/tclOOBasic.c
@@ -281,6 +281,7 @@ TclOO_Object_Destroy(
contextPtr->skip = 0;
TclNRAddCallback(interp, AfterNRDestructor, contextPtr,
NULL, NULL, NULL);
+ TclPushTailcallPoint(interp);
return TclOOInvokeContext(contextPtr, interp, 0, NULL);
}
}
@@ -434,8 +435,14 @@ TclOO_Object_Unknown(
const char **methodNames;
int numMethodNames, i, skip = Tcl_ObjectContextSkippedArgs(context);
+ /*
+ * If no method name, generate an error asking for a method name. (Only by
+ * overriding *this* method can an object handle the absence of a method
+ * name without an error).
+ */
+
if (objc < skip+1) {
- Tcl_WrongNumArgs(interp, skip, objv, "methodName ?arg ...?");
+ Tcl_WrongNumArgs(interp, skip, objv, "method ?arg ...?");
return TCL_ERROR;
}
diff --git a/generic/tclOOCall.c b/generic/tclOOCall.c
index 9c9f3c0..760bd7b 100644
--- a/generic/tclOOCall.c
+++ b/generic/tclOOCall.c
@@ -37,7 +37,7 @@ struct ChainBuilder {
#define DEFINITE_PROTECTED 0x100000
#define DEFINITE_PUBLIC 0x200000
#define KNOWN_STATE (DEFINITE_PROTECTED | DEFINITE_PUBLIC)
-#define SPECIAL (CONSTRUCTOR | DESTRUCTOR)
+#define SPECIAL (CONSTRUCTOR | DESTRUCTOR | FORCE_UNKNOWN)
/*
* Function declarations for things defined in this file.
@@ -997,6 +997,22 @@ TclOOGetCallContext(
cb.oPtr = oPtr;
/*
+ * If we're working with a forced use of unknown, do that now.
+ */
+
+ if (flags & FORCE_UNKNOWN) {
+ AddSimpleChainToCallContext(oPtr, oPtr->fPtr->unknownMethodNameObj,
+ &cb, NULL, 0, NULL);
+ callPtr->flags |= OO_UNKNOWN_METHOD;
+ callPtr->epoch = -1;
+ if (callPtr->numChain == 0) {
+ TclOODeleteChain(callPtr);
+ return NULL;
+ }
+ goto returnContext;
+ }
+
+ /*
* 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).
diff --git a/generic/tclOODefineCmds.c b/generic/tclOODefineCmds.c
index 72732da..926966b 100644
--- a/generic/tclOODefineCmds.c
+++ b/generic/tclOODefineCmds.c
@@ -17,6 +17,23 @@
#include "tclOOInt.h"
/*
+ * Some things that make it easier to declare a slot.
+ */
+
+struct DeclaredSlot {
+ const char *name;
+ const Tcl_MethodType getterType;
+ const Tcl_MethodType setterType;
+};
+
+#define SLOT(name,getter,setter) \
+ {"::oo::" name, \
+ {TCL_OO_METHOD_VERSION_CURRENT, "core method: " name " Getter", \
+ getter, NULL, NULL}, \
+ {TCL_OO_METHOD_VERSION_CURRENT, "core method: " name " Setter", \
+ setter, NULL, NULL}}
+
+/*
* Forward declarations.
*/
@@ -32,6 +49,63 @@ static inline void RecomputeClassCacheFlag(Object *oPtr);
static int RenameDeleteMethod(Tcl_Interp *interp, Object *oPtr,
int useClass, Tcl_Obj *const fromPtr,
Tcl_Obj *const toPtr);
+static int ClassFilterGet(ClientData clientData,
+ Tcl_Interp *interp, Tcl_ObjectContext context,
+ int objc, Tcl_Obj *const *objv);
+static int ClassFilterSet(ClientData clientData,
+ Tcl_Interp *interp, Tcl_ObjectContext context,
+ int objc, Tcl_Obj *const *objv);
+static int ClassMixinGet(ClientData clientData,
+ Tcl_Interp *interp, Tcl_ObjectContext context,
+ int objc, Tcl_Obj *const *objv);
+static int ClassMixinSet(ClientData clientData,
+ Tcl_Interp *interp, Tcl_ObjectContext context,
+ int objc, Tcl_Obj *const *objv);
+static int ClassSuperGet(ClientData clientData,
+ Tcl_Interp *interp, Tcl_ObjectContext context,
+ int objc, Tcl_Obj *const *objv);
+static int ClassSuperSet(ClientData clientData,
+ Tcl_Interp *interp, Tcl_ObjectContext context,
+ int objc, Tcl_Obj *const *objv);
+static int ClassVarsGet(ClientData clientData,
+ Tcl_Interp *interp, Tcl_ObjectContext context,
+ int objc, Tcl_Obj *const *objv);
+static int ClassVarsSet(ClientData clientData,
+ Tcl_Interp *interp, Tcl_ObjectContext context,
+ int objc, Tcl_Obj *const *objv);
+static int ObjFilterGet(ClientData clientData,
+ Tcl_Interp *interp, Tcl_ObjectContext context,
+ int objc, Tcl_Obj *const *objv);
+static int ObjFilterSet(ClientData clientData,
+ Tcl_Interp *interp, Tcl_ObjectContext context,
+ int objc, Tcl_Obj *const *objv);
+static int ObjMixinGet(ClientData clientData,
+ Tcl_Interp *interp, Tcl_ObjectContext context,
+ int objc, Tcl_Obj *const *objv);
+static int ObjMixinSet(ClientData clientData,
+ Tcl_Interp *interp, Tcl_ObjectContext context,
+ int objc, Tcl_Obj *const *objv);
+static int ObjVarsGet(ClientData clientData,
+ Tcl_Interp *interp, Tcl_ObjectContext context,
+ int objc, Tcl_Obj *const *objv);
+static int ObjVarsSet(ClientData clientData,
+ Tcl_Interp *interp, Tcl_ObjectContext context,
+ int objc, Tcl_Obj *const *objv);
+
+/*
+ * Now define the slots used in declarations.
+ */
+
+static const struct DeclaredSlot slots[] = {
+ SLOT("define::filter", ClassFilterGet, ClassFilterSet),
+ SLOT("define::mixin", ClassMixinGet, ClassMixinSet),
+ SLOT("define::superclass", ClassSuperGet, ClassSuperSet),
+ SLOT("define::variable", ClassVarsGet, ClassVarsSet),
+ SLOT("objdefine::filter", ObjFilterGet, ObjFilterSet),
+ SLOT("objdefine::mixin", ObjMixinGet, ObjMixinSet),
+ SLOT("objdefine::variable", ObjVarsGet, ObjVarsSet),
+ {NULL, {0, 0, 0, 0, 0}, {0, 0, 0, 0, 0}}
+};
/*
* ----------------------------------------------------------------------
@@ -1388,43 +1462,6 @@ TclOODefineExportObjCmd(
/*
* ----------------------------------------------------------------------
*
- * 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);
- Tcl_SetErrorCode(interp, "TCL", "OO", "MONKEY_BUSINESS", 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.
@@ -1656,84 +1693,484 @@ TclOODefineRenameMethodObjCmd(
/*
* ----------------------------------------------------------------------
*
- * TclOODefineSuperclassObjCmd --
- * Implementation of the "superclass" subcommand of the "oo::define"
- * command.
+ * TclOODefineUnexportObjCmd --
+ * Implementation of the "unexport" subcommand of the "oo::define" and
+ * "oo::objdefine" commands.
*
* ----------------------------------------------------------------------
*/
int
-TclOODefineSuperclassObjCmd(
+TclOODefineUnexportObjCmd(
ClientData clientData,
Tcl_Interp *interp,
int objc,
Tcl_Obj *const *objv)
{
+ int isInstanceUnexport = (clientData != NULL);
Object *oPtr;
- Class **superclasses, *superPtr;
- int i, j;
+ Method *mPtr;
+ Tcl_HashEntry *hPtr;
+ Class *clsPtr;
+ int i, isNew, changed = 0;
if (objc < 2) {
- Tcl_WrongNumArgs(interp, 1, objv, "className ?className ...?");
+ 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);
+ Tcl_SetErrorCode(interp, "TCL", "OO", "MONKEY_BUSINESS", 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 = 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 = ckalloc(sizeof(Method));
+ memset(mPtr, 0, sizeof(Method));
+ mPtr->refCount = 1;
+ mPtr->namePtr = objv[i];
+ Tcl_IncrRefCount(objv[i]);
+ Tcl_SetHashValue(hPtr, mPtr);
+ } else {
+ mPtr = Tcl_GetHashValue(hPtr);
+ }
+ if (isNew || mPtr->flags & PUBLIC_METHOD) {
+ mPtr->flags &= ~PUBLIC_METHOD;
+ changed = 1;
+ }
+ }
+
/*
- * Get the class to operate on.
+ * Bump the right epoch if we actually changed anything.
*/
- oPtr = (Object *) TclOOGetDefineCmdContext(interp);
+ if (changed) {
+ if (isInstanceUnexport) {
+ oPtr->epoch++;
+ } else {
+ BumpGlobalEpoch(interp, clsPtr);
+ }
+ }
+ return TCL_OK;
+}
+
+/*
+ * ----------------------------------------------------------------------
+ *
+ * Tcl_ClassSetConstructor, Tcl_ClassSetDestructor --
+ * How to install a constructor or destructor into a class; API to call
+ * from C.
+ *
+ * ----------------------------------------------------------------------
+ */
+
+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;
+
+ /*
+ * Remember to invalidate the cached constructor chain for this class.
+ * [Bug 2531577]
+ */
+
+ if (clsPtr->constructorChainPtr) {
+ TclOODeleteChain(clsPtr->constructorChainPtr);
+ clsPtr->constructorChainPtr = NULL;
+ }
+ 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;
+ if (clsPtr->destructorChainPtr) {
+ TclOODeleteChain(clsPtr->destructorChainPtr);
+ clsPtr->destructorChainPtr = NULL;
+ }
+ BumpGlobalEpoch(interp, clsPtr);
+ }
+}
+
+/*
+ * ----------------------------------------------------------------------
+ *
+ * TclOODefineSlots --
+ * Create the "::oo::Slot" class and its standard instances. Class
+ * definition is empty at the stage (added by scripting).
+ *
+ * ----------------------------------------------------------------------
+ */
+
+int
+TclOODefineSlots(
+ Foundation *fPtr)
+{
+ const struct DeclaredSlot *slotInfoPtr;
+ Tcl_Obj *getName = Tcl_NewStringObj("Get", -1);
+ Tcl_Obj *setName = Tcl_NewStringObj("Set", -1);
+ Class *slotCls;
+
+ slotCls = ((Object *) Tcl_NewObjectInstance(fPtr->interp, (Tcl_Class)
+ fPtr->classCls, "::oo::Slot", NULL, -1, NULL, 0))->classPtr;
+ if (slotCls == NULL) {
+ return TCL_ERROR;
+ }
+ Tcl_IncrRefCount(getName);
+ Tcl_IncrRefCount(setName);
+ for (slotInfoPtr = slots ; slotInfoPtr->name ; slotInfoPtr++) {
+ Tcl_Object slotObject = Tcl_NewObjectInstance(fPtr->interp,
+ (Tcl_Class) slotCls, slotInfoPtr->name, NULL,-1,NULL,0);
+
+ if (slotObject == NULL) {
+ continue;
+ }
+ Tcl_NewInstanceMethod(fPtr->interp, slotObject, getName, 0,
+ &slotInfoPtr->getterType, NULL);
+ Tcl_NewInstanceMethod(fPtr->interp, slotObject, setName, 0,
+ &slotInfoPtr->setterType, NULL);
+ }
+ Tcl_DecrRefCount(getName);
+ Tcl_DecrRefCount(setName);
+ return TCL_OK;
+}
+
+/*
+ * ----------------------------------------------------------------------
+ *
+ * ClassFilterGet, ClassFilterSet --
+ * Implementation of the "filter" slot accessors of the "oo::define"
+ * command.
+ *
+ * ----------------------------------------------------------------------
+ */
+
+static int
+ClassFilterGet(
+ ClientData clientData,
+ Tcl_Interp *interp,
+ Tcl_ObjectContext context,
+ int objc,
+ Tcl_Obj *const *objv)
+{
+ Object *oPtr = (Object *) TclOOGetDefineCmdContext(interp);
+ Tcl_Obj *resultObj, *filterObj;
+ int i;
+
+ if (Tcl_ObjectContextSkippedArgs(context) != objc) {
+ Tcl_WrongNumArgs(interp, Tcl_ObjectContextSkippedArgs(context), objv,
+ NULL);
+ return TCL_ERROR;
+ }
if (oPtr == NULL) {
return TCL_ERROR;
+ } else if (!oPtr->classPtr) {
+ Tcl_AppendResult(interp, "attempt to misuse API", NULL);
+ Tcl_SetErrorCode(interp, "TCL", "OO", "MONKEY_BUSINESS", NULL);
+ return TCL_ERROR;
}
- if (oPtr->classPtr == NULL) {
- Tcl_AppendResult(interp, "only classes may have superclasses defined",
+
+ resultObj = Tcl_NewObj();
+ FOREACH(filterObj, oPtr->classPtr->filters) {
+ Tcl_ListObjAppendElement(NULL, resultObj, filterObj);
+ }
+ Tcl_SetObjResult(interp, resultObj);
+ return TCL_OK;
+}
+
+static int
+ClassFilterSet(
+ ClientData clientData,
+ Tcl_Interp *interp,
+ Tcl_ObjectContext context,
+ int objc,
+ Tcl_Obj *const *objv)
+{
+ Object *oPtr = (Object *) TclOOGetDefineCmdContext(interp);
+ int filterc;
+ Tcl_Obj **filterv;
+
+ if (Tcl_ObjectContextSkippedArgs(context)+1 != objc) {
+ Tcl_WrongNumArgs(interp, Tcl_ObjectContextSkippedArgs(context), objv,
+ "filterList");
+ return TCL_ERROR;
+ }
+ objv += Tcl_ObjectContextSkippedArgs(context);
+
+ if (oPtr == NULL) {
+ return TCL_ERROR;
+ } else if (!oPtr->classPtr) {
+ Tcl_AppendResult(interp, "attempt to misuse API", NULL);
+ Tcl_SetErrorCode(interp, "TCL", "OO", "MONKEY_BUSINESS", NULL);
+ return TCL_ERROR;
+ } else if (Tcl_ListObjGetElements(interp, objv[0], &filterc,
+ &filterv) != TCL_OK) {
+ return TCL_ERROR;
+ }
+
+ TclOOClassSetFilters(interp, oPtr->classPtr, filterc, filterv);
+ return TCL_OK;
+}
+
+/*
+ * ----------------------------------------------------------------------
+ *
+ * ClassMixinGet, ClassMixinSet --
+ * Implementation of the "mixin" slot accessors of the "oo::define"
+ * command.
+ *
+ * ----------------------------------------------------------------------
+ */
+
+static int
+ClassMixinGet(
+ ClientData clientData,
+ Tcl_Interp *interp,
+ Tcl_ObjectContext context,
+ int objc,
+ Tcl_Obj *const *objv)
+{
+ Object *oPtr = (Object *) TclOOGetDefineCmdContext(interp);
+ Tcl_Obj *resultObj;
+ Class *mixinPtr;
+ int i;
+
+ if (Tcl_ObjectContextSkippedArgs(context) != objc) {
+ Tcl_WrongNumArgs(interp, Tcl_ObjectContextSkippedArgs(context), objv,
NULL);
- Tcl_SetErrorCode(interp, "TCL", "OO", "OBJECT_NOT_CLASS", NULL);
return TCL_ERROR;
}
- if (oPtr->flags & ROOT_OBJECT) {
+ if (oPtr == NULL) {
+ return TCL_ERROR;
+ } else if (!oPtr->classPtr) {
+ Tcl_AppendResult(interp, "attempt to misuse API", NULL);
+ Tcl_SetErrorCode(interp, "TCL", "OO", "MONKEY_BUSINESS", NULL);
+ return TCL_ERROR;
+ }
+
+ resultObj = Tcl_NewObj();
+ FOREACH(mixinPtr, oPtr->classPtr->mixins) {
+ Tcl_ListObjAppendElement(NULL, resultObj,
+ TclOOObjectName(interp, mixinPtr->thisPtr));
+ }
+ Tcl_SetObjResult(interp, resultObj);
+ return TCL_OK;
+
+}
+
+static int
+ClassMixinSet(
+ ClientData clientData,
+ Tcl_Interp *interp,
+ Tcl_ObjectContext context,
+ int objc,
+ Tcl_Obj *const *objv)
+{
+ Object *oPtr = (Object *) TclOOGetDefineCmdContext(interp);
+ int mixinc, i;
+ Tcl_Obj **mixinv;
+ Class **mixins;
+
+ if (Tcl_ObjectContextSkippedArgs(context)+1 != objc) {
+ Tcl_WrongNumArgs(interp, Tcl_ObjectContextSkippedArgs(context), objv,
+ "mixinList");
+ return TCL_ERROR;
+ }
+ objv += Tcl_ObjectContextSkippedArgs(context);
+
+ if (oPtr == NULL) {
+ return TCL_ERROR;
+ } else if (!oPtr->classPtr) {
+ Tcl_AppendResult(interp, "attempt to misuse API", NULL);
+ Tcl_SetErrorCode(interp, "TCL", "OO", "MONKEY_BUSINESS", NULL);
+ return TCL_ERROR;
+ } else if (Tcl_ListObjGetElements(interp, objv[0], &mixinc,
+ &mixinv) != TCL_OK) {
+ return TCL_ERROR;
+ }
+
+ mixins = TclStackAlloc(interp, sizeof(Class *) * mixinc);
+
+ for (i=0 ; i<mixinc ; i++) {
+ mixins[i] = GetClassInOuterContext(interp, mixinv[i],
+ "may only mix in classes");
+ if (mixins[i] == NULL) {
+ goto freeAndError;
+ }
+ if (TclOOIsReachable(oPtr->classPtr, mixins[i])) {
+ Tcl_AppendResult(interp, "may not mix a class into itself", NULL);
+ Tcl_SetErrorCode(interp, "TCL", "OO", "SELF_MIXIN", NULL);
+ goto freeAndError;
+ }
+ }
+
+ TclOOClassSetMixins(interp, oPtr->classPtr, mixinc, mixins);
+ TclStackFree(interp, mixins);
+ return TCL_OK;
+
+ freeAndError:
+ TclStackFree(interp, mixins);
+ return TCL_ERROR;
+}
+
+/*
+ * ----------------------------------------------------------------------
+ *
+ * ClassSuperGet, ClassSuperSet --
+ * Implementation of the "superclass" slot accessors of the "oo::define"
+ * command.
+ *
+ * ----------------------------------------------------------------------
+ */
+
+static int
+ClassSuperGet(
+ ClientData clientData,
+ Tcl_Interp *interp,
+ Tcl_ObjectContext context,
+ int objc,
+ Tcl_Obj *const *objv)
+{
+ Object *oPtr = (Object *) TclOOGetDefineCmdContext(interp);
+ Tcl_Obj *resultObj;
+ Class *superPtr;
+ int i;
+
+ if (Tcl_ObjectContextSkippedArgs(context) != objc) {
+ Tcl_WrongNumArgs(interp, Tcl_ObjectContextSkippedArgs(context), objv,
+ NULL);
+ return TCL_ERROR;
+ }
+ if (oPtr == NULL) {
+ return TCL_ERROR;
+ } else if (!oPtr->classPtr) {
+ Tcl_AppendResult(interp, "attempt to misuse API", NULL);
+ Tcl_SetErrorCode(interp, "TCL", "OO", "MONKEY_BUSINESS", NULL);
+ return TCL_ERROR;
+ }
+
+ resultObj = Tcl_NewObj();
+ FOREACH(superPtr, oPtr->classPtr->superclasses) {
+ Tcl_ListObjAppendElement(NULL, resultObj,
+ TclOOObjectName(interp, superPtr->thisPtr));
+ }
+ Tcl_SetObjResult(interp, resultObj);
+ return TCL_OK;
+}
+
+static int
+ClassSuperSet(
+ ClientData clientData,
+ Tcl_Interp *interp,
+ Tcl_ObjectContext context,
+ int objc,
+ Tcl_Obj *const *objv)
+{
+ Object *oPtr = (Object *) TclOOGetDefineCmdContext(interp);
+ int superc, i, j;
+ Tcl_Obj **superv;
+ Class **superclasses, *superPtr;
+
+ if (Tcl_ObjectContextSkippedArgs(context)+1 != objc) {
+ Tcl_WrongNumArgs(interp, Tcl_ObjectContextSkippedArgs(context), objv,
+ "superclassList");
+ return TCL_ERROR;
+ }
+ objv += Tcl_ObjectContextSkippedArgs(context);
+
+ if (oPtr == NULL) {
+ return TCL_ERROR;
+ } else if (!oPtr->classPtr) {
+ Tcl_AppendResult(interp, "attempt to misuse API", NULL);
+ Tcl_SetErrorCode(interp, "TCL", "OO", "MONKEY_BUSINESS", NULL);
+ return TCL_ERROR;
+ } else if (oPtr == oPtr->fPtr->objectCls->thisPtr) {
Tcl_AppendResult(interp,
"may not modify the superclass of the root object", NULL);
Tcl_SetErrorCode(interp, "TCL", "OO", "MONKEY_BUSINESS", NULL);
return TCL_ERROR;
+ } else if (Tcl_ListObjGetElements(interp, objv[0], &superc,
+ &superv) != TCL_OK) {
+ return TCL_ERROR;
}
/*
* Allocate some working space.
*/
- superclasses = ckalloc(sizeof(Class *) * (objc-1));
+ superclasses = (Class **) ckalloc(sizeof(Class *) * superc);
/*
* Parse the arguments to get the class to use as superclasses.
*/
- for (i=0 ; i<objc-1 ; i++) {
- Class *clsPtr = GetClassInOuterContext(interp, objv[i+1],
+ for (i=0 ; i<superc ; i++) {
+ superclasses[i] = GetClassInOuterContext(interp, superv[i],
"only a class can be a superclass");
-
- if (clsPtr == NULL) {
+ if (superclasses[i] == NULL) {
goto failedAfterAlloc;
}
for (j=0 ; j<i ; j++) {
- if (superclasses[j] == clsPtr) {
+ if (superclasses[j] == superclasses[i]) {
Tcl_AppendResult(interp,
"class should only be a direct superclass once",NULL);
Tcl_SetErrorCode(interp, "TCL", "OO", "REPETITIOUS", NULL);
goto failedAfterAlloc;
}
}
- if (TclOOIsReachable(oPtr->classPtr, clsPtr)) {
+ if (TclOOIsReachable(oPtr->classPtr, superclasses[i])) {
Tcl_AppendResult(interp,
"attempt to form circular dependency graph", NULL);
Tcl_SetErrorCode(interp, "TCL", "OO", "CIRCULARITY", NULL);
failedAfterAlloc:
- ckfree(superclasses);
+ ckfree((char *) superclasses);
return TCL_ERROR;
}
- superclasses[i] = clsPtr;
}
/*
@@ -1747,10 +2184,10 @@ TclOODefineSuperclassObjCmd(
FOREACH(superPtr, oPtr->classPtr->superclasses) {
TclOORemoveFromSubclasses(oPtr->classPtr, superPtr);
}
- ckfree(oPtr->classPtr->superclasses.list);
+ ckfree((char *) oPtr->classPtr->superclasses.list);
}
oPtr->classPtr->superclasses.list = superclasses;
- oPtr->classPtr->superclasses.num = objc-1;
+ oPtr->classPtr->superclasses.num = superc;
FOREACH(superPtr, oPtr->classPtr->superclasses) {
TclOOAddToSubclasses(oPtr->classPtr, superPtr);
}
@@ -1762,129 +2199,336 @@ TclOODefineSuperclassObjCmd(
/*
* ----------------------------------------------------------------------
*
- * TclOODefineUnexportObjCmd --
- * Implementation of the "unexport" subcommand of the "oo::define" and
- * "oo::objdefine" commands.
+ * ClassVarsGet, ClassVarsSet --
+ * Implementation of the "variable" slot accessors of the "oo::define"
+ * command.
*
* ----------------------------------------------------------------------
*/
-int
-TclOODefineUnexportObjCmd(
+static int
+ClassVarsGet(
ClientData clientData,
Tcl_Interp *interp,
+ Tcl_ObjectContext context,
int objc,
Tcl_Obj *const *objv)
{
- int isInstanceUnexport = (clientData != NULL);
- Object *oPtr;
- Method *mPtr;
- Tcl_HashEntry *hPtr;
- Class *clsPtr;
- int i, isNew, changed = 0;
+ Object *oPtr = (Object *) TclOOGetDefineCmdContext(interp);
+ Tcl_Obj *resultObj, *variableObj;
+ int i;
- if (objc < 2) {
- Tcl_WrongNumArgs(interp, 1, objv, "name ?name ...?");
+ if (Tcl_ObjectContextSkippedArgs(context) != objc) {
+ Tcl_WrongNumArgs(interp, Tcl_ObjectContextSkippedArgs(context), objv,
+ NULL);
return TCL_ERROR;
}
-
- oPtr = (Object *) TclOOGetDefineCmdContext(interp);
if (oPtr == NULL) {
return TCL_ERROR;
+ } else if (!oPtr->classPtr) {
+ Tcl_AppendResult(interp, "attempt to misuse API", NULL);
+ Tcl_SetErrorCode(interp, "TCL", "OO", "MONKEY_BUSINESS", NULL);
+ return TCL_ERROR;
}
- clsPtr = oPtr->classPtr;
- if (!isInstanceUnexport && !clsPtr) {
+
+ resultObj = Tcl_NewObj();
+ FOREACH(variableObj, oPtr->classPtr->variables) {
+ Tcl_ListObjAppendElement(NULL, resultObj, variableObj);
+ }
+ Tcl_SetObjResult(interp, resultObj);
+ return TCL_OK;
+}
+
+static int
+ClassVarsSet(
+ ClientData clientData,
+ Tcl_Interp *interp,
+ Tcl_ObjectContext context,
+ int objc,
+ Tcl_Obj *const *objv)
+{
+ Object *oPtr = (Object *) TclOOGetDefineCmdContext(interp);
+ int varc;
+ Tcl_Obj **varv, *variableObj;
+ int i;
+
+ if (Tcl_ObjectContextSkippedArgs(context)+1 != objc) {
+ Tcl_WrongNumArgs(interp, Tcl_ObjectContextSkippedArgs(context), objv,
+ "filterList");
+ return TCL_ERROR;
+ }
+ objv += Tcl_ObjectContextSkippedArgs(context);
+
+ if (oPtr == NULL) {
+ return TCL_ERROR;
+ } else if (!oPtr->classPtr) {
Tcl_AppendResult(interp, "attempt to misuse API", NULL);
Tcl_SetErrorCode(interp, "TCL", "OO", "MONKEY_BUSINESS", NULL);
return TCL_ERROR;
+ } else if (Tcl_ListObjGetElements(interp, objv[0], &varc,
+ &varv) != TCL_OK) {
+ 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.
- */
+ for (i=0 ; i<varc ; i++) {
+ const char *varName = Tcl_GetString(varv[i]);
- if (isInstanceUnexport) {
- if (!oPtr->methodsPtr) {
- oPtr->methodsPtr = 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 (strstr(varName, "::") != NULL) {
+ Tcl_AppendResult(interp, "invalid declared variable name \"",
+ varName, "\": must not contain namespace separators",
+ NULL);
+ Tcl_SetErrorCode(interp, "TCL", "OO", "BAD_DECLVAR", NULL);
+ return TCL_ERROR;
}
+ if (Tcl_StringMatch(varName, "*(*)")) {
+ Tcl_AppendResult(interp, "invalid declared variable name \"",
+ varName, "\": must not refer to an array element", NULL);
+ Tcl_SetErrorCode(interp, "TCL", "OO", "BAD_DECLVAR", NULL);
+ return TCL_ERROR;
+ }
+ }
- if (isNew) {
- mPtr = ckalloc(sizeof(Method));
- memset(mPtr, 0, sizeof(Method));
- mPtr->refCount = 1;
- mPtr->namePtr = objv[i];
- Tcl_IncrRefCount(objv[i]);
- Tcl_SetHashValue(hPtr, mPtr);
+ for (i=0 ; i<varc ; i++) {
+ Tcl_IncrRefCount(varv[i]);
+ }
+ FOREACH(variableObj, oPtr->classPtr->variables) {
+ Tcl_DecrRefCount(variableObj);
+ }
+ if (i != varc) {
+ if (varc == 0) {
+ ckfree((char *) oPtr->classPtr->variables.list);
+ } else if (i) {
+ oPtr->classPtr->variables.list = (Tcl_Obj **)
+ ckrealloc((char *) oPtr->classPtr->variables.list,
+ sizeof(Tcl_Obj *) * varc);
} else {
- mPtr = Tcl_GetHashValue(hPtr);
- }
- if (isNew || mPtr->flags & PUBLIC_METHOD) {
- mPtr->flags &= ~PUBLIC_METHOD;
- changed = 1;
+ oPtr->classPtr->variables.list = (Tcl_Obj **)
+ ckalloc(sizeof(Tcl_Obj *) * varc);
}
}
+ if (varc > 0) {
+ memcpy(oPtr->classPtr->variables.list, varv,
+ sizeof(Tcl_Obj *) * varc);
+ }
+ oPtr->classPtr->variables.num = varc;
+ return TCL_OK;
+}
+
+/*
+ * ----------------------------------------------------------------------
+ *
+ * ObjectFilterGet, ObjectFilterSet --
+ * Implementation of the "filter" slot accessors of the "oo::objdefine"
+ * command.
+ *
+ * ----------------------------------------------------------------------
+ */
- /*
- * Bump the right epoch if we actually changed anything.
- */
+static int
+ObjFilterGet(
+ ClientData clientData,
+ Tcl_Interp *interp,
+ Tcl_ObjectContext context,
+ int objc,
+ Tcl_Obj *const *objv)
+{
+ Object *oPtr = (Object *) TclOOGetDefineCmdContext(interp);
+ Tcl_Obj *resultObj, *filterObj;
+ int i;
- if (changed) {
- if (isInstanceUnexport) {
- oPtr->epoch++;
- } else {
- BumpGlobalEpoch(interp, clsPtr);
+ if (Tcl_ObjectContextSkippedArgs(context) != objc) {
+ Tcl_WrongNumArgs(interp, Tcl_ObjectContextSkippedArgs(context), objv,
+ NULL);
+ return TCL_ERROR;
+ } else if (oPtr == NULL) {
+ return TCL_ERROR;
+ }
+
+ resultObj = Tcl_NewObj();
+ FOREACH(filterObj, oPtr->filters) {
+ Tcl_ListObjAppendElement(NULL, resultObj, filterObj);
+ }
+ Tcl_SetObjResult(interp, resultObj);
+ return TCL_OK;
+}
+
+static int
+ObjFilterSet(
+ ClientData clientData,
+ Tcl_Interp *interp,
+ Tcl_ObjectContext context,
+ int objc,
+ Tcl_Obj *const *objv)
+{
+ Object *oPtr = (Object *) TclOOGetDefineCmdContext(interp);
+ int filterc;
+ Tcl_Obj **filterv;
+
+ if (Tcl_ObjectContextSkippedArgs(context)+1 != objc) {
+ Tcl_WrongNumArgs(interp, Tcl_ObjectContextSkippedArgs(context), objv,
+ "filterList");
+ return TCL_ERROR;
+ } else if (oPtr == NULL) {
+ return TCL_ERROR;
+ }
+ objv += Tcl_ObjectContextSkippedArgs(context);
+ if (Tcl_ListObjGetElements(interp, objv[0], &filterc,
+ &filterv) != TCL_OK) {
+ return TCL_ERROR;
+ }
+
+ TclOOObjectSetFilters(oPtr, filterc, filterv);
+ return TCL_OK;
+}
+
+/*
+ * ----------------------------------------------------------------------
+ *
+ * ObjectMixinGet, ObjectMixinSet --
+ * Implementation of the "mixin" slot accessors of the "oo::objdefine"
+ * command.
+ *
+ * ----------------------------------------------------------------------
+ */
+
+static int
+ObjMixinGet(
+ ClientData clientData,
+ Tcl_Interp *interp,
+ Tcl_ObjectContext context,
+ int objc,
+ Tcl_Obj *const *objv)
+{
+ Object *oPtr = (Object *) TclOOGetDefineCmdContext(interp);
+ Tcl_Obj *resultObj;
+ Class *mixinPtr;
+ int i;
+
+ if (Tcl_ObjectContextSkippedArgs(context) != objc) {
+ Tcl_WrongNumArgs(interp, Tcl_ObjectContextSkippedArgs(context), objv,
+ NULL);
+ return TCL_ERROR;
+ } else if (oPtr == NULL) {
+ return TCL_ERROR;
+ }
+
+ resultObj = Tcl_NewObj();
+ FOREACH(mixinPtr, oPtr->mixins) {
+ Tcl_ListObjAppendElement(NULL, resultObj,
+ TclOOObjectName(interp, mixinPtr->thisPtr));
+ }
+ Tcl_SetObjResult(interp, resultObj);
+ return TCL_OK;
+}
+
+static int
+ObjMixinSet(
+ ClientData clientData,
+ Tcl_Interp *interp,
+ Tcl_ObjectContext context,
+ int objc,
+ Tcl_Obj *const *objv)
+{
+ Object *oPtr = (Object *) TclOOGetDefineCmdContext(interp);
+ int mixinc;
+ Tcl_Obj **mixinv;
+ Class **mixins;
+ int i;
+
+ if (Tcl_ObjectContextSkippedArgs(context)+1 != objc) {
+ Tcl_WrongNumArgs(interp, Tcl_ObjectContextSkippedArgs(context), objv,
+ "mixinList");
+ return TCL_ERROR;
+ } else if (oPtr == NULL) {
+ return TCL_ERROR;
+ }
+ objv += Tcl_ObjectContextSkippedArgs(context);
+ if (Tcl_ListObjGetElements(interp, objv[0], &mixinc,
+ &mixinv) != TCL_OK) {
+ return TCL_ERROR;
+ }
+
+ mixins = TclStackAlloc(interp, sizeof(Class *) * mixinc);
+
+ for (i=0 ; i<mixinc ; i++) {
+ mixins[i] = GetClassInOuterContext(interp, mixinv[i],
+ "may only mix in classes");
+ if (mixins[i] == NULL) {
+ TclStackFree(interp, mixins);
+ return TCL_ERROR;
}
}
+
+ TclOOObjectSetMixins(oPtr, mixinc, mixins);
+ TclStackFree(interp, mixins);
return TCL_OK;
}
/*
* ----------------------------------------------------------------------
*
- * TclOODefineVariablesObjCmd --
- * Implementation of the "variable" subcommand of the "oo::define" and
- * "oo::objdefine" commands.
+ * ObjectVarsGet, ObjectVarsSet --
+ * Implementation of the "variable" slot accessors of the "oo::objdefine"
+ * command.
*
* ----------------------------------------------------------------------
*/
-int
-TclOODefineVariablesObjCmd(
+static int
+ObjVarsGet(
ClientData clientData,
Tcl_Interp *interp,
+ Tcl_ObjectContext context,
int objc,
Tcl_Obj *const *objv)
{
- int isInstanceVars = (clientData != NULL);
Object *oPtr = (Object *) TclOOGetDefineCmdContext(interp);
- Tcl_Obj *variableObj;
+ Tcl_Obj *resultObj, *variableObj;
int i;
- if (oPtr == NULL) {
+ if (Tcl_ObjectContextSkippedArgs(context) != objc) {
+ Tcl_WrongNumArgs(interp, Tcl_ObjectContextSkippedArgs(context), objv,
+ NULL);
+ return TCL_ERROR;
+ } else if (oPtr == NULL) {
return TCL_ERROR;
}
- if (!isInstanceVars && !oPtr->classPtr) {
- Tcl_AppendResult(interp, "attempt to misuse API", NULL);
- Tcl_SetErrorCode(interp, "TCL", "OO", "MONKEY_BUSINESS", NULL);
+
+ resultObj = Tcl_NewObj();
+ FOREACH(variableObj, oPtr->variables) {
+ Tcl_ListObjAppendElement(NULL, resultObj, variableObj);
+ }
+ Tcl_SetObjResult(interp, resultObj);
+ return TCL_OK;
+}
+
+static int
+ObjVarsSet(
+ ClientData clientData,
+ Tcl_Interp *interp,
+ Tcl_ObjectContext context,
+ int objc,
+ Tcl_Obj *const *objv)
+{
+ Object *oPtr = (Object *) TclOOGetDefineCmdContext(interp);
+ int varc, i;
+ Tcl_Obj **varv, *variableObj;
+
+ if (Tcl_ObjectContextSkippedArgs(context)+1 != objc) {
+ Tcl_WrongNumArgs(interp, Tcl_ObjectContextSkippedArgs(context), objv,
+ "variableList");
+ return TCL_ERROR;
+ } else if (oPtr == NULL) {
+ return TCL_ERROR;
+ }
+ objv += Tcl_ObjectContextSkippedArgs(context);
+ if (Tcl_ListObjGetElements(interp, objv[0], &varc,
+ &varv) != TCL_OK) {
return TCL_ERROR;
}
- for (i=1 ; i<objc ; i++) {
- const char *varName = Tcl_GetString(objv[i]);
+ for (i=0 ; i<varc ; i++) {
+ const char *varName = Tcl_GetString(varv[i]);
if (strstr(varName, "::") != NULL) {
Tcl_AppendResult(interp, "invalid declared variable name \"",
@@ -1900,96 +2544,30 @@ TclOODefineVariablesObjCmd(
return TCL_ERROR;
}
}
- for (i=1 ; i<objc ; i++) {
- Tcl_IncrRefCount(objv[i]);
+ for (i=0 ; i<varc ; i++) {
+ Tcl_IncrRefCount(varv[i]);
}
- if (!isInstanceVars) {
- FOREACH(variableObj, oPtr->classPtr->variables) {
- Tcl_DecrRefCount(variableObj);
- }
- if (i != objc-1) {
- if (objc == 1) {
- ckfree(oPtr->classPtr->variables.list);
- } else if (i) {
- oPtr->classPtr->variables.list =
- ckrealloc(oPtr->classPtr->variables.list,
- sizeof(Tcl_Obj *) * (objc-1));
- } else {
- oPtr->classPtr->variables.list =
- ckalloc(sizeof(Tcl_Obj *) * (objc-1));
- }
- }
- if (objc > 1) {
- memcpy(oPtr->classPtr->variables.list, objv+1,
- sizeof(Tcl_Obj *) * (objc-1));
- }
- oPtr->classPtr->variables.num = objc-1;
- } else {
- FOREACH(variableObj, oPtr->variables) {
- Tcl_DecrRefCount(variableObj);
- }
- if (i != objc-1) {
- if (objc == 1) {
- ckfree(oPtr->variables.list);
- } else if (i) {
- oPtr->variables.list = ckrealloc(oPtr->variables.list,
- sizeof(Tcl_Obj *) * (objc-1));
- } else {
- oPtr->variables.list =
- ckalloc(sizeof(Tcl_Obj *) * (objc-1));
- }
- }
- if (objc > 1) {
- memcpy(oPtr->variables.list, objv+1, sizeof(Tcl_Obj *)*(objc-1));
- }
- oPtr->variables.num = objc-1;
+ FOREACH(variableObj, oPtr->variables) {
+ Tcl_DecrRefCount(variableObj);
}
- 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;
-
- /*
- * Remember to invalidate the cached constructor chain for this class.
- * [Bug 2531577]
- */
-
- if (clsPtr->constructorChainPtr) {
- TclOODeleteChain(clsPtr->constructorChainPtr);
- clsPtr->constructorChainPtr = NULL;
+ if (i != varc) {
+ if (varc == 0) {
+ ckfree((char *) oPtr->variables.list);
+ } else if (i) {
+ oPtr->variables.list = (Tcl_Obj **)
+ ckrealloc((char *) oPtr->variables.list,
+ sizeof(Tcl_Obj *) * varc);
+ } else {
+ oPtr->variables.list = (Tcl_Obj **)
+ ckalloc(sizeof(Tcl_Obj *) * varc);
}
- 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;
- if (clsPtr->destructorChainPtr) {
- TclOODeleteChain(clsPtr->destructorChainPtr);
- clsPtr->destructorChainPtr = NULL;
- }
- BumpGlobalEpoch(interp, clsPtr);
+ if (varc > 0) {
+ memcpy(oPtr->variables.list, varv, sizeof(Tcl_Obj *)*varc);
}
+ oPtr->variables.num = varc;
+ return TCL_OK;
}
/*
diff --git a/generic/tclOOInt.h b/generic/tclOOInt.h
index b151183..2d6f324 100644
--- a/generic/tclOOInt.h
+++ b/generic/tclOOInt.h
@@ -214,6 +214,8 @@ typedef struct Object {
* class of classes, and should be treated
* specially during teardown (and in a few
* other spots). */
+#define FORCE_UNKNOWN 0x10000 /* States that we are *really* looking up the
+ * unknown method handler at that point. */
/*
* And the definition of a class. Note that every class also has an associated
@@ -318,6 +320,8 @@ typedef struct Foundation {
* constructor. */
Tcl_Obj *destructorName; /* Shared object containing the "name" of a
* destructor. */
+ Tcl_Obj *clonedName; /* Shared object containing the name of a
+ * "<cloned>" pseudo-constructor. */
} Foundation;
/*
@@ -426,30 +430,18 @@ MODULE_SCOPE int TclOODefineDestructorObjCmd(ClientData clientData,
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 TclOODefineVariablesObjCmd(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);
@@ -514,6 +506,7 @@ MODULE_SCOPE int TclNRNewObjectInstance(Tcl_Interp *interp,
const char *nsNameStr, int objc,
Tcl_Obj *const *objv, int skip,
Tcl_Object *objectPtr);
+MODULE_SCOPE int TclOODefineSlots(Foundation *fPtr);
MODULE_SCOPE void TclOODeleteChain(CallChain *callPtr);
MODULE_SCOPE void TclOODeleteChainCache(Tcl_HashTable *tablePtr);
MODULE_SCOPE void TclOODeleteContext(CallContext *contextPtr);
diff --git a/generic/tclStubInit.c b/generic/tclStubInit.c
index da899f4..32e9557 100644
--- a/generic/tclStubInit.c
+++ b/generic/tclStubInit.c
@@ -39,14 +39,21 @@
#undef Tcl_CreateHashEntry
#undef Tcl_Panic
#undef Tcl_FindExecutable
-#define TclpLocaltime_unix TclpLocaltime
-#define TclpGmtime_unix TclpGmtime
#ifdef __CYGWIN__
#define TclWinGetPlatformId winGetPlatformId
#define Tcl_WinUtfToTChar winUtfToTChar
#define Tcl_WinTCharToUtf winTCharToUtf
+#define TclWinGetTclInstance winGetTclInstance
+#define TclWinNToHS winNToHS
+#define TclWinSetSockOpt winSetSockOpt
+#define TclWinAddProcess winAddProcess
+#define TclpGetTZName pGetTZName
+#define TclWinNoBackslash winNoBackslash
+#define TclWinSetInterfaces (void (*) _ANSI_ARGS_((int))) doNothing
+#define TclWinFlushDirtyChannels doNothing
+#define TclWinResetInterfaces doNothing
static Tcl_Encoding winTCharEncoding;
@@ -58,6 +65,59 @@ TclWinGetPlatformId()
return 2; /* VER_PLATFORM_WIN32_NT */;
}
+static int TclWinGetTclInstance()
+{
+ Tcl_Panic("TclWinGetTclInstance not yet implemented for CYGWIN");
+ return 0;
+}
+
+static unsigned short
+TclWinNToHS(unsigned short ns)
+{
+ Tcl_Panic("TclWinNToHS not yet implemented for CYGWIN");
+ return (unsigned short) -1;
+}
+static int
+TclWinSetSockOpt(int s, int level, int optname,
+ const char *optval, int optlen)
+{
+ Tcl_Panic("TclWinSetSockOpt not yet implemented for CYGWIN");
+ return -1;
+}
+
+static void
+TclWinAddProcess(void *hProcess, unsigned long id)
+{
+ Tcl_Panic("TclWinAddProcess not yet implemented for CYGWIN");
+}
+
+static char *
+TclpGetTZName(int isdst)
+{
+ /* TODO: implementation */
+ Tcl_Panic("TclpGetTZName not yet implemented for CYGWIN");
+ return 0;
+}
+
+static char *
+TclWinNoBackslash(char *path)
+{
+ char *p;
+
+ for (p = path; *p != '\0'; p++) {
+ if (*p == '\\') {
+ *p = '/';
+ }
+ }
+ return path;
+}
+
+static void
+doNothing(void)
+{
+ /* dummy implementation, no need to do anything */
+}
+
static char *
Tcl_WinUtfToTChar(string, len, dsPtr)
CONST char *string;
@@ -65,20 +125,20 @@ Tcl_WinUtfToTChar(string, len, dsPtr)
Tcl_DString *dsPtr;
{
if (!winTCharEncoding) {
- winTCharEncoding = Tcl_GetEncoding(NULL, "unicode");
+ winTCharEncoding = Tcl_GetEncoding(0, "unicode");
}
return Tcl_UtfToExternalDString(winTCharEncoding,
string, len, dsPtr);
}
static char *
-Tcl_WinTCharToUtf(string, len, dsPtr)
- CONST char *string;
- int len;
- Tcl_DString *dsPtr;
+Tcl_WinTCharToUtf(
+ CONST char *string,
+ int len,
+ Tcl_DString *dsPtr)
{
if (!winTCharEncoding) {
- winTCharEncoding = Tcl_GetEncoding(NULL, "unicode");
+ winTCharEncoding = Tcl_GetEncoding(0, "unicode");
}
return Tcl_ExternalToUtfDString(winTCharEncoding,
string, len, dsPtr);
@@ -88,13 +148,36 @@ Tcl_WinTCharToUtf(string, len, dsPtr)
Tcl_Interp *, CONST char *, int, int, char *))) Tcl_WinUtfToTChar
#define Tcl_MacOSXOpenVersionedBundleResources (int (*) _ANSI_ARGS_(( \
Tcl_Interp *, CONST char *, CONST char *, int, int, char *))) Tcl_WinTCharToUtf
+#define TclMacOSXGetFileAttribute (int (*) _ANSI_ARGS_((Tcl_Interp *, \
+ int, Tcl_Obj *, Tcl_Obj **))) TclpCreateProcess
+#define TclMacOSXMatchType (int (*) _ANSI_ARGS_((Tcl_Interp *, CONST char *, \
+ CONST char *, Tcl_StatBuf *, Tcl_GlobTypeData *))) TclpMakeFile
+#define TclMacOSXNotifierAddRunLoopMode (void (*) _ANSI_ARGS_((CONST void *))) TclpOpenFile
+#define TclpLocaltime_unix (struct tm *(*) _ANSI_ARGS_((CONST time_t *))) TclGetAndDetachPids
+#define TclpGmtime_unix (struct tm *(*) _ANSI_ARGS_((CONST time_t *))) TclpCloseFile
#elif !defined(__WIN32__) /* UNIX and MAC */
+# define TclWinConvertError (void (*) _ANSI_ARGS_((unsigned int))) TclGetAndDetachPids
+# define TclWinConvertWSAError (void (*) _ANSI_ARGS_((unsigned int))) TclpCloseFile
# define TclWinGetPlatformId (int (*)()) TclpCreateTempFile
+# define TclWinGetTclInstance (int (*)()) TclpCreateProcess
+# define TclWinNToHS (unsigned short (*) _ANSI_ARGS_((unsigned short ns))) TclpMakeFile
+# define TclWinSetSockOpt (int (*) _ANSI_ARGS_((int, int, int, const char *, int))) TclpOpenFile
+# define TclWinAddProcess 0
+# define TclpGetTZName 0
+# define TclWinNoBackslash 0
+# define TclWinSetInterfaces 0
+# define TclWinFlushDirtyChannels 0
+# define TclWinResetInterfaces 0
+# define TclMacOSXGetFileAttribute 0 /* Only implemented in Tcl >= 8.5 */
+# define TclMacOSXMatchType 0 /* Only implemented in Tcl >= 8.5 */
+# define TclMacOSXNotifierAddRunLoopMode 0 /* Only implemented in Tcl >= 8.5 */
# ifndef MAC_OSX_TCL
# define Tcl_MacOSXOpenBundleResources 0
# define Tcl_MacOSXOpenVersionedBundleResources 0
# endif
+# define TclpLocaltime_unix TclpLocaltime
+# define TclpGmtime_unix TclpGmtime
#endif
/*
@@ -368,14 +451,14 @@ static const TclIntPlatStubs tclIntPlatStubs = {
TCL_STUB_MAGIC,
0,
#if !defined(__WIN32__) && !defined(MAC_OSX_TCL) /* UNIX */
- TclGetAndDetachPids, /* 0 */
- TclpCloseFile, /* 1 */
+ TclWinConvertError, /* 0 */
+ TclWinConvertWSAError, /* 1 */
TclpCreateCommandChannel, /* 2 */
TclpCreatePipe, /* 3 */
- TclpCreateProcess, /* 4 */
+ TclWinGetTclInstance, /* 4 */
0, /* 5 */
- TclpMakeFile, /* 6 */
- TclpOpenFile, /* 7 */
+ TclWinNToHS, /* 6 */
+ TclWinSetSockOpt, /* 7 */
TclUnixWaitForFile, /* 8 */
TclWinGetPlatformId, /* 9 */
TclpReaddir, /* 10 */
@@ -383,21 +466,23 @@ static const TclIntPlatStubs tclIntPlatStubs = {
TclpGmtime_unix, /* 12 */
TclpInetNtoa, /* 13 */
TclUnixCopyFile, /* 14 */
- 0, /* 15 */
+ TclMacOSXGetFileAttribute, /* 15 */
0, /* 16 */
0, /* 17 */
- 0, /* 18 */
- 0, /* 19 */
- 0, /* 20 */
+ TclMacOSXMatchType, /* 18 */
+ TclMacOSXNotifierAddRunLoopMode, /* 19 */
+ TclWinAddProcess, /* 20 */
0, /* 21 */
TclpCreateTempFile, /* 22 */
- 0, /* 23 */
- 0, /* 24 */
+ TclpGetTZName, /* 23 */
+ TclWinNoBackslash, /* 24 */
0, /* 25 */
- 0, /* 26 */
- 0, /* 27 */
- 0, /* 28 */
+ TclWinSetInterfaces, /* 26 */
+ TclWinFlushDirtyChannels, /* 27 */
+ TclWinResetInterfaces, /* 28 */
TclWinCPUID, /* 29 */
+ TclGetAndDetachPids, /* 30 */
+ TclpCloseFile, /* 31 */
#endif /* UNIX */
#ifdef __WIN32__ /* WIN */
TclWinConvertError, /* 0 */
@@ -432,14 +517,14 @@ static const TclIntPlatStubs tclIntPlatStubs = {
TclWinCPUID, /* 29 */
#endif /* WIN */
#ifdef MAC_OSX_TCL /* MACOSX */
- TclGetAndDetachPids, /* 0 */
- TclpCloseFile, /* 1 */
+ TclWinConvertError, /* 0 */
+ TclWinConvertWSAError, /* 1 */
TclpCreateCommandChannel, /* 2 */
TclpCreatePipe, /* 3 */
- TclpCreateProcess, /* 4 */
+ TclWinGetTclInstance, /* 4 */
0, /* 5 */
- TclpMakeFile, /* 6 */
- TclpOpenFile, /* 7 */
+ TclWinNToHS, /* 6 */
+ TclWinSetSockOpt, /* 7 */
TclUnixWaitForFile, /* 8 */
TclWinGetPlatformId, /* 9 */
TclpReaddir, /* 10 */
@@ -452,16 +537,18 @@ static const TclIntPlatStubs tclIntPlatStubs = {
TclMacOSXCopyFileAttributes, /* 17 */
TclMacOSXMatchType, /* 18 */
TclMacOSXNotifierAddRunLoopMode, /* 19 */
- 0, /* 20 */
+ TclWinAddProcess, /* 20 */
0, /* 21 */
TclpCreateTempFile, /* 22 */
- 0, /* 23 */
- 0, /* 24 */
+ TclpGetTZName, /* 23 */
+ TclWinNoBackslash, /* 24 */
0, /* 25 */
- 0, /* 26 */
- 0, /* 27 */
- 0, /* 28 */
+ TclWinSetInterfaces, /* 26 */
+ TclWinFlushDirtyChannels, /* 27 */
+ TclWinResetInterfaces, /* 28 */
TclWinCPUID, /* 29 */
+ TclGetAndDetachPids, /* 30 */
+ TclpCloseFile, /* 31 */
#endif /* MACOSX */
};
diff --git a/tests/oo.test b/tests/oo.test
index 67535c9..150bc97 100644
--- a/tests/oo.test
+++ b/tests/oo.test
@@ -131,6 +131,13 @@ test oo-1.4 {basic test of OO functionality} -body {
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.5.1 {basic test of OO functionality} -setup {
+ oo::object create aninstance
+} -returnCodes error -body {
+ aninstance
+} -cleanup {
+ rename aninstance {}
+} -result {wrong # args: should be "aninstance method ?arg ...?"}
test oo-1.6 {basic test of OO functionality} -setup {
oo::object create aninstance
} -body {
@@ -1672,6 +1679,53 @@ test oo-15.5 {OO: class cloning - Bug 3474460} -setup {
} -cleanup {
ArbitraryClass destroy
} -result {a b c}
+test oo-15.6 {OO: object cloning copies namespace contents} -setup {
+ oo::class create ArbitraryClass {export eval}
+} -body {
+ ArbitraryClass create a
+ a eval {proc foo x {
+ variable y
+ return [string repeat $x [incr y]]
+ }}
+ set result [list [a eval {foo 2}] [a eval {foo 3}]]
+ oo::copy a b
+ a eval {rename foo bar}
+ lappend result [b eval {foo 2}] [b eval {foo 3}] [a eval {bar 4}]
+} -cleanup {
+ ArbitraryClass destroy
+} -result {2 33 222 3333 444}
+test oo-15.7 {OO: classes can be cloned anonymously} -setup {
+ oo::class create ArbitraryClassA
+ oo::class create ArbitraryClassB {superclass ArbitraryClassA}
+} -body {
+ info object isa class [oo::copy ArbitraryClassB]
+} -cleanup {
+ ArbitraryClassA destroy
+} -result 1
+test oo-15.8 {OO: intercept object cloning} -setup {
+ oo::class create Foo
+ set result {}
+} -body {
+ oo::define Foo {
+ constructor {msg} {
+ variable v $msg
+ }
+ method <cloned> {from} {
+ next $from
+ lappend ::result cloned $from [self]
+ }
+ method check {} {
+ variable v
+ lappend ::result check [self] $v
+ }
+ }
+ Foo create foo ok
+ oo::copy foo bar
+ foo check
+ bar check
+} -cleanup {
+ Foo destroy
+} -result {cloned ::foo ::bar check ::foo ok check ::bar ok}
test oo-16.1 {OO: object introspection} -body {
info object
@@ -1767,10 +1821,10 @@ test oo-16.11 {OO: object introspection} -setup {
} -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]
+ list [lsort [info object methods bar -all]] [lsort [info object methods bar -all -private]]
} -cleanup {
foo destroy
-} -result {{boo destroy spong} {boo destroy eval spong unknown variable varname}}
+} -result {{boo destroy spong} {<cloned> boo destroy eval spong unknown variable varname}}
test oo-16.12 {OO: object introspection} -setup {
oo::object create foo
} -cleanup {
@@ -1851,11 +1905,11 @@ test oo-17.9 {OO: class introspection} -setup {
}
}
oo::define subfoo method boo {a {b c} args} {the body}
- list [info class methods subfoo -all] \
- [info class methods subfoo -all -private]
+ list [lsort [info class methods subfoo -all]] \
+ [lsort [info class methods subfoo -all -private]]
} -cleanup {
foo destroy
-} -result {{bar boo destroy} {bar boo destroy eval unknown variable varname}}
+} -result {{bar boo destroy} {<cloned> bar boo destroy eval unknown variable varname}}
test oo-17.10 {OO: class introspection} -setup {
oo::class create foo
} -cleanup {
@@ -2389,7 +2443,7 @@ test oo-22.1 {OO and info frame} -setup {
list [i level] [i frames] [dict get [c frame] object]
} -cleanup {
c destroy
-} -result {1 {{type source line * file * cmd {info frame 0} method frames class ::c level 0} {type source line * file * cmd {info frame 0} method frames object ::i level 0}} ::c}
+} -result {1 {{* cmd {info frame 0} method frames class ::c level 0} {* cmd {info frame 0} method frames object ::i level 0}} ::c}
test oo-22.2 {OO and info frame: Bug 3001438} -setup {
oo::class create c
} -body {
@@ -2460,6 +2514,16 @@ test oo-24.2 {unknown method method - Bug 1965063} -setup {
}
obj foo bar
} -result {unknown method "foo": must be destroy, dummy, dummy2 or unknown}
+test oo-24.3 {unknown method method - absent method name} -setup {
+ set o [oo::object new]
+} -cleanup {
+ $o destroy
+} -body {
+ oo::objdefine $o method unknown args {
+ return "unknown: >>$args<<"
+ }
+ list [$o] [$o foobar] [$o foo bar]
+} -result {{unknown: >><<} {unknown: >>foobar<<} {unknown: >>foo bar<<}}
# Probably need a better set of tests, but this is quite difficult to devise
test oo-25.1 {call chain caching} -setup {
@@ -2751,6 +2815,87 @@ test oo-27.13 {variables declaration: Bug 3185009: require refcount management}
} -cleanup {
foo destroy
} -result {0 7 1 7 {} 0 1 {can't read "x": no such variable}}
+test oo-27.14 {variables declaration - multiple use} -setup {
+ oo::class create master
+} -cleanup {
+ master destroy
+} -body {
+ oo::class create foo {
+ superclass master
+ variable x
+ variable y
+ method boo {} {
+ return [incr x],[incr y]
+ }
+ }
+ foo create bar
+ list [bar boo] [bar boo]
+} -result {1,1 2,2}
+test oo-27.15 {variables declaration - multiple use} -setup {
+ oo::class create master
+} -cleanup {
+ master destroy
+} -body {
+ oo::class create foo {
+ superclass master
+ variable
+ variable x y
+ method boo {} {
+ return [incr x],[incr y]
+ }
+ }
+ foo create bar
+ list [bar boo] [bar boo]
+} -result {1,1 2,2}
+test oo-27.16 {variables declaration - multiple use} -setup {
+ oo::class create master
+} -cleanup {
+ master destroy
+} -body {
+ oo::class create foo {
+ superclass master
+ variable x
+ variable -clear
+ variable y
+ method boo {} {
+ return [incr x],[incr y]
+ }
+ }
+ foo create bar
+ list [bar boo] [bar boo]
+} -result {1,1 1,2}
+test oo-27.17 {variables declaration - multiple use} -setup {
+ oo::class create master
+} -cleanup {
+ master destroy
+} -body {
+ oo::class create foo {
+ superclass master
+ variable x
+ variable -set y
+ method boo {} {
+ return [incr x],[incr y]
+ }
+ }
+ foo create bar
+ list [bar boo] [bar boo]
+} -result {1,1 1,2}
+test oo-27.18 {variables declaration - multiple use} -setup {
+ oo::class create master
+} -cleanup {
+ master destroy
+} -body {
+ oo::class create foo {
+ superclass master
+ variable x
+ variable -? y
+ method boo {} {
+ return [incr x],[incr y]
+ }
+ }
+ foo create bar
+ list [bar boo] [bar boo]
+} -returnCodes error -match glob -result {unknown method "-?": must be *}
# A feature that's not supported because the mechanism may change without
# warning, but is supposed to work...
@@ -2832,6 +2977,148 @@ test oo-31.2 {Bug 3111059: when objects and coroutines entangle} -setup {
} -cleanup {
cls destroy
} -result {0 {}}
+
+oo::class create SampleSlot {
+ superclass oo::Slot
+ constructor {} {
+ variable contents {a b c} ops {}
+ }
+ method contents {} {variable contents; return $contents}
+ method ops {} {variable ops; return $ops}
+ method Get {} {
+ variable contents
+ variable ops
+ lappend ops [info level] Get
+ return $contents
+ }
+ method Set {lst} {
+ variable contents $lst
+ variable ops
+ lappend ops [info level] Set $lst
+ return
+ }
+}
+
+test oo-32.1 {TIP 380: slots - class test} -setup {
+ SampleSlot create sampleSlot
+} -body {
+ list [info level] [sampleSlot contents] [sampleSlot ops]
+} -cleanup {
+ rename sampleSlot {}
+} -result {0 {a b c} {}}
+test oo-32.2 {TIP 380: slots - class test} -setup {
+ SampleSlot create sampleSlot
+} -body {
+ list [info level] [sampleSlot -clear] \
+ [sampleSlot contents] [sampleSlot ops]
+} -cleanup {
+ rename sampleSlot {}
+} -result {0 {} {} {1 Set {}}}
+test oo-32.3 {TIP 380: slots - class test} -setup {
+ SampleSlot create sampleSlot
+} -body {
+ list [info level] [sampleSlot -append g h i] \
+ [sampleSlot contents] [sampleSlot ops]
+} -cleanup {
+ rename sampleSlot {}
+} -result {0 {} {a b c g h i} {1 Get 1 Set {a b c g h i}}}
+test oo-32.4 {TIP 380: slots - class test} -setup {
+ SampleSlot create sampleSlot
+} -body {
+ list [info level] [sampleSlot -set d e f] \
+ [sampleSlot contents] [sampleSlot ops]
+} -cleanup {
+ rename sampleSlot {}
+} -result {0 {} {d e f} {1 Set {d e f}}}
+test oo-32.5 {TIP 380: slots - class test} -setup {
+ SampleSlot create sampleSlot
+} -body {
+ list [info level] [sampleSlot -set d e f] [sampleSlot -append g h i] \
+ [sampleSlot contents] [sampleSlot ops]
+} -cleanup {
+ rename sampleSlot {}
+} -result {0 {} {} {d e f g h i} {1 Set {d e f} 1 Get 1 Set {d e f g h i}}}
+
+test oo-33.1 {TIP 380: slots - defaulting} -setup {
+ set s [SampleSlot new]
+} -body {
+ list [$s x y] [$s contents]
+} -cleanup {
+ rename $s {}
+} -result {{} {a b c x y}}
+test oo-33.2 {TIP 380: slots - defaulting} -setup {
+ set s [SampleSlot new]
+} -body {
+ list [$s destroy; $s unknown] [$s contents]
+} -cleanup {
+ rename $s {}
+} -result {{} {a b c destroy unknown}}
+test oo-32.3 {TIP 380: slots - defaulting} -setup {
+ set s [SampleSlot new]
+} -body {
+ oo::objdefine $s forward --default-operation my -set
+ list [$s destroy; $s unknown] [$s contents] [$s ops]
+} -cleanup {
+ rename $s {}
+} -result {{} unknown {1 Set destroy 1 Set unknown}}
+test oo-33.4 {TIP 380: slots - errors} -setup {
+ set s [SampleSlot new]
+} -body {
+ # Method names beginning with "-" are special to slots
+ $s -grill q
+} -returnCodes error -cleanup {
+ rename $s {}
+} -result {unknown method "-grill": must be -append, -clear, -set, contents or ops}
+
+SampleSlot destroy
+
+test oo-34.1 {TIP 380: slots - presence} -setup {
+ set obj [oo::object new]
+ set result {}
+} -body {
+ oo::define oo::object {
+ ::lappend ::result [::info object class filter]
+ ::lappend ::result [::info object class mixin]
+ ::lappend ::result [::info object class superclass]
+ ::lappend ::result [::info object class variable]
+ }
+ oo::objdefine $obj {
+ ::lappend ::result [::info object class filter]
+ ::lappend ::result [::info object class mixin]
+ ::lappend ::result [::info object class variable]
+ }
+ return $result
+} -cleanup {
+ $obj destroy
+} -result {::oo::Slot ::oo::Slot ::oo::Slot ::oo::Slot ::oo::Slot ::oo::Slot ::oo::Slot}
+test oo-34.2 {TIP 380: slots - presence} {
+ lsort [info class instances oo::Slot]
+} {::oo::define::filter ::oo::define::mixin ::oo::define::superclass ::oo::define::variable ::oo::objdefine::filter ::oo::objdefine::mixin ::oo::objdefine::variable}
+proc getMethods obj {
+ list [lsort [info object methods $obj -all]] \
+ [lsort [info object methods $obj -private]]
+}
+test oo-34.3 {TIP 380: slots - presence} {
+ getMethods oo::define::filter
+} {{-append -clear -set} {Get Set}}
+test oo-34.4 {TIP 380: slots - presence} {
+ getMethods oo::define::mixin
+} {{-append -clear -set} {--default-operation Get Set}}
+test oo-34.5 {TIP 380: slots - presence} {
+ getMethods oo::define::superclass
+} {{-append -clear -set} {--default-operation Get Set}}
+test oo-34.6 {TIP 380: slots - presence} {
+ getMethods oo::define::variable
+} {{-append -clear -set} {Get Set}}
+test oo-34.7 {TIP 380: slots - presence} {
+ getMethods oo::objdefine::filter
+} {{-append -clear -set} {Get Set}}
+test oo-34.8 {TIP 380: slots - presence} {
+ getMethods oo::objdefine::mixin
+} {{-append -clear -set} {--default-operation Get Set}}
+test oo-34.9 {TIP 380: slots - presence} {
+ getMethods oo::objdefine::variable
+} {{-append -clear -set} {Get Set}}
cleanupTests
return
diff --git a/tests/string.test b/tests/string.test
index 85a7372..b3326ae 100644
--- a/tests/string.test
+++ b/tests/string.test
@@ -312,10 +312,10 @@ test string-6.4 {string is, too many args} {
} {1 {wrong # args: should be "string is class ?-strict? ?-failindex var? str"}}
test string-6.5 {string is, class check} {
list [catch {string is bogus str} msg] $msg
-} {1 {bad class "bogus": must be alnum, alpha, ascii, control, boolean, digit, double, false, graph, integer, list, lower, print, punct, space, true, upper, wideinteger, wordchar, or xdigit}}
+} {1 {bad class "bogus": must be alnum, alpha, ascii, control, boolean, digit, double, entier, false, graph, integer, list, lower, print, punct, space, true, upper, wideinteger, wordchar, or xdigit}}
test string-6.6 {string is, ambiguous class} {
list [catch {string is al str} msg] $msg
-} {1 {ambiguous class "al": must be alnum, alpha, ascii, control, boolean, digit, double, false, graph, integer, list, lower, print, punct, space, true, upper, wideinteger, wordchar, or xdigit}}
+} {1 {ambiguous class "al": must be alnum, alpha, ascii, control, boolean, digit, double, entier, false, graph, integer, list, lower, print, punct, space, true, upper, wideinteger, wordchar, or xdigit}}
test string-6.7 {string is alpha, all ok} {
string is alpha -strict -failindex var abc
} 1
@@ -592,7 +592,7 @@ test string-6.90 {string is integer, bad integers} {
foreach num $numbers {
lappend result [string is int -strict $num]
}
- set result
+ return $result
} {1 1 0 0 0 1 0 0}
test string-6.91 {string is double, bad doubles} {
set result ""
@@ -600,7 +600,7 @@ test string-6.91 {string is double, bad doubles} {
foreach num $numbers {
lappend result [string is double -strict $num]
}
- set result
+ return $result
} {1 1 0 0 0 1 0 0}
test string-6.92 {string is integer, 32-bit overflow} {
# Bug 718878
@@ -664,7 +664,7 @@ test string-6.107 {string is integer, bad integers} {
foreach num $numbers {
lappend result [string is wideinteger -strict $num]
}
- set result
+ return $result
} {1 1 0 0 0 1 0 0}
test string-6.108 {string is double, Bug 1382287} {
set x 2turtledoves
@@ -674,6 +674,78 @@ test string-6.108 {string is double, Bug 1382287} {
test string-6.109 {string is double, Bug 1360532} {
string is double 1\u00a0
} 0
+test string-6.110 {string is entier, true} {
+ string is entier +1234567890
+} 1
+test string-6.111 {string is entier, true on type} {
+ string is entier [expr wide(50.0)]
+} 1
+test string-6.112 {string is entier, true} {
+ string is entier [list -10]
+} 1
+test string-6.113 {string is entier, true as hex} {
+ string is entier 0xabcdef
+} 1
+test string-6.114 {string is entier, true as octal} {
+ string is entier 0123456
+} 1
+test string-6.115 {string is entier, true with whitespace} {
+ string is entier " \n1234\v"
+} 1
+test string-6.116 {string is entier, false} {
+ list [string is entier -fail var 123abc] $var
+} {0 3}
+test string-6.117 {string is entier, false} {
+ list [string is entier -fail var 123123123123123123123123123123123123123123123123123123123123123123123123123123123123abc] $var
+} {0 84}
+test string-6.118 {string is entier, false} {
+ list [string is entier -fail var [expr double(1)]] $var
+} {0 1}
+test string-6.119 {string is entier, false} {
+ list [string is entier -fail var " "] $var
+} {0 0}
+test string-6.120 {string is entier, false on bad octal} {
+ list [string is entier -fail var 0o36963] $var
+} {0 4}
+test string-6.121.1 {string is entier, false on bad octal} {
+ list [string is entier -fail var 0o36963] $var
+} {0 4}
+test string-6.122 {string is entier, false on bad hex} {
+ list [string is entier -fail var 0X345XYZ] $var
+} {0 5}
+test string-6.123 {string is entier, bad integers} {
+ # SF bug #634856
+ set result ""
+ set numbers [list 1 +1 ++1 +-1 -+1 -1 --1 "- +1"]
+ foreach num $numbers {
+ lappend result [string is entier -strict $num]
+ }
+ return $result
+} {1 1 0 0 0 1 0 0}
+test string-6.124 {string is entier, true} {
+ string is entier +1234567890123456789012345678901234567890
+} 1
+test string-6.125 {string is entier, true} {
+ string is entier [list -10000000000000000000000000000000000000000000000000000000000000000000000000000000000000]
+} 1
+test string-6.126 {string is entier, true as hex} {
+ string is entier 0xabcdefabcdefabcdefabcdefabcdefabcdefabcdefabcdefabcdefabcdefabcdefabcdefabcdefabcdef
+} 1
+test string-6.127 {string is entier, true as octal} {
+ string is entier 0123456112341234561234565623456123456123456123456123456123456123456123456123456123456
+} 1
+test string-6.128 {string is entier, true with whitespace} {
+ string is entier " \n12340000000000000000000000000000000000000000000000000000000000000000000000000000000000000\v"
+} 1
+test string-6.129 {string is entier, false on bad octal} {
+ list [string is entier -fail var 0o1234561123412345612345656234561234561234561234561234561234561234561234561234561234536963] $var
+} {0 87}
+test string-6.130.1 {string is entier, false on bad octal} {
+ list [string is entier -fail var 0o1234561123412345612345656234561234561234561234561234561234561234561234561234561234536963] $var
+} {0 87}
+test string-6.131 {string is entier, false on bad hex} {
+ list [string is entier -fail var 0X12345611234123456123456562345612345612345612345612345612345612345612345612345612345345XYZ] $var
+} {0 88}
catch {rename largest_int {}}
diff --git a/unix/Makefile.in b/unix/Makefile.in
index 0a22a58..81185b4 100644
--- a/unix/Makefile.in
+++ b/unix/Makefile.in
@@ -1541,6 +1541,10 @@ tclMacOSXFCmd.o: $(MAC_OSX_DIR)/tclMacOSXFCmd.c
tclMacOSXNotify.o: $(MAC_OSX_DIR)/tclMacOSXNotify.c
$(CC) -c $(CC_SWITCHES) $(MAC_OSX_DIR)/tclMacOSXNotify.c
+# The following is a CYGWIN only source:
+tclWinError.o: $(TOP_DIR)/win/tclWinError.c
+ $(CC) -c $(CC_SWITCHES) $(TOP_DIR)/win/tclWinError.c
+
# DTrace support
$(TCL_OBJS) $(STUB_LIB_OBJS) $(TCLSH_OBJS) $(TCLTEST_OBJS) $(XTTEST_OBJS): @DTRACE_HDR@
diff --git a/unix/configure b/unix/configure
index 72d5d73..e737bd5 100755
--- a/unix/configure
+++ b/unix/configure
@@ -7057,7 +7057,7 @@ fi
SHLIB_CFLAGS=""
SHLIB_LD='${CC} -shared'
SHLIB_SUFFIX=".dll"
- DL_OBJS="tclLoadDl.o"
+ DL_OBJS="tclLoadDl.o tclWinError.o"
DL_LIBS="-ldl"
CC_SEARCH_FLAGS=""
LD_SEARCH_FLAGS=""
diff --git a/unix/tcl.m4 b/unix/tcl.m4
index 39f8ca1..f6e002e 100644
--- a/unix/tcl.m4
+++ b/unix/tcl.m4
@@ -1224,7 +1224,7 @@ AC_DEFUN([SC_CONFIG_CFLAGS], [
SHLIB_CFLAGS=""
SHLIB_LD='${CC} -shared'
SHLIB_SUFFIX=".dll"
- DL_OBJS="tclLoadDl.o"
+ DL_OBJS="tclLoadDl.o tclWinError.o"
DL_LIBS="-ldl"
CC_SEARCH_FLAGS=""
LD_SEARCH_FLAGS=""
diff --git a/win/tclWinError.c b/win/tclWinError.c
index 4fee02b..1b59dbe 100644
--- a/win/tclWinError.c
+++ b/win/tclWinError.c
@@ -12,11 +12,19 @@
#include "tclInt.h"
+#ifndef WSAEWOULDBLOCK
+# define WSAEWOULDBLOCK 10035L
+#endif
+
+#ifndef __WIN32__
+# define DWORD unsigned int
+#endif
+
/*
* The following table contains the mapping from Win32 errors to errno errors.
*/
-static char errorTable[] = {
+static const unsigned char errorTable[] = {
0,
EINVAL, /* ERROR_INVALID_FUNCTION 1 */
ENOENT, /* ERROR_FILE_NOT_FOUND 2 */
@@ -284,18 +292,16 @@ static char errorTable[] = {
EINVAL, /* 264 */
EINVAL, /* 265 */
EINVAL, /* 266 */
- ENOTDIR, /* ERROR_DIRECTORY 267 */
+ ENOTDIR /* ERROR_DIRECTORY 267 */
};
-static const unsigned int tableLen = sizeof(errorTable);
-
/*
* The following table contains the mapping from WinSock errors to
* errno errors.
*/
-static int wsaErrorTable[] = {
- EWOULDBLOCK, /* WSAEWOULDBLOCK */
+static const unsigned char wsaErrorTable[] = {
+ EAGAIN, /* WSAEWOULDBLOCK */
EINPROGRESS, /* WSAEINPROGRESS */
EALREADY, /* WSAEALREADY */
ENOTSOCK, /* WSAENOTSOCK */
@@ -331,7 +337,7 @@ static int wsaErrorTable[] = {
EUSERS, /* WSAEUSERS */
EDQUOT, /* WSAEDQUOT */
ESTALE, /* WSAESTALE */
- EREMOTE, /* WSAEREMOTE */
+ EREMOTE /* WSAEREMOTE */
};
/*
@@ -352,9 +358,9 @@ static int wsaErrorTable[] = {
void
TclWinConvertError(
- unsigned long errCode) /* Win32 error code. */
+ DWORD errCode) /* Win32 error code. */
{
- if (errCode >= tableLen) {
+ if (errCode >= sizeof(errorTable)/sizeof(errorTable[0])) {
Tcl_SetErrno(EINVAL);
} else {
Tcl_SetErrno(errorTable[errCode]);
@@ -379,12 +385,13 @@ TclWinConvertError(
void
TclWinConvertWSAError(
- unsigned long errCode) /* Win32 error code. */
+ DWORD errCode) /* Win32 error code. */
{
- if ((errCode >= WSAEWOULDBLOCK) && (errCode <= WSAEREMOTE)) {
- Tcl_SetErrno(wsaErrorTable[errCode - WSAEWOULDBLOCK]);
- } else {
+ errCode -= WSAEWOULDBLOCK;
+ if (errCode >= sizeof(wsaErrorTable)/sizeof(wsaErrorTable[0])) {
Tcl_SetErrno(EINVAL);
+ } else {
+ Tcl_SetErrno(wsaErrorTable[errCode]);
}
}
diff --git a/win/tclWinPort.h b/win/tclWinPort.h
index e3c5a49..db46a4a 100644
--- a/win/tclWinPort.h
+++ b/win/tclWinPort.h
@@ -226,9 +226,9 @@ typedef DWORD_PTR * PDWORD_PTR;
#ifndef EOTHER
# define EOTHER 131 /* Other error */
#endif
-/* workaround for mingw-w64 bug 3407992 */
-#undef EOVERFLOW
-#define EOVERFLOW 132 /* File too big */
+#ifndef EOVERFLOW
+# define EOVERFLOW 132 /* File too big */
+#endif
#ifndef EOWNERDEAD
# define EOWNERDEAD 133 /* Owner dead */
#endif
@@ -255,20 +255,28 @@ typedef DWORD_PTR * PDWORD_PTR;
#endif
-#undef ESOCKTNOSUPPORT
-#define ESOCKTNOSUPPORT WSAESOCKTNOSUPPORT /* Socket type not supported */
-#undef ESHUTDOWN
-#define ESHUTDOWN WSAESHUTDOWN /* Can't send after socket shutdown */
-#undef ETOOMANYREFS
-#define ETOOMANYREFS WSAETOOMANYREFS /* Too many references: can't splice */
-#undef EHOSTDOWN
-#define EHOSTDOWN WSAEHOSTDOWN /* Host is down */
-#undef EUSERS
-#define EUSERS WSAEUSERS /* Too many users (for UFS) */
-#undef EDQUOT
-#define EDQUOT WSAEDQUOT /* Disc quota exceeded */
-#undef ESTALE
-#define ESTALE WSAESTALE /* Stale NFS file handle */
+/* Visual Studio doesn't have these, so just choose some high numbers */
+#ifndef ESOCKTNOSUPPORT
+# define ESOCKTNOSUPPORT 240 /* Socket type not supported */
+#endif
+#ifndef ESHUTDOWN
+# define ESHUTDOWN 241 /* Can't send after socket shutdown */
+#endif
+#ifndef ETOOMANYREFS
+# define ETOOMANYREFS 242 /* Too many references: can't splice */
+#endif
+#ifndef EHOSTDOWN
+# define EHOSTDOWN 243 /* Host is down */
+#endif
+#ifndef EUSERS
+# define EUSERS 244 /* Too many users (for UFS) */
+#endif
+#ifndef EDQUOT
+# define EDQUOT 245 /* Disc quota exceeded */
+#endif
+#ifndef ESTALE
+# define ESTALE 246 /* Stale NFS file handle */
+#endif
/*
* Signals not known to the standard ANSI signal.h. These are used
diff --git a/win/tclWinSerial.c b/win/tclWinSerial.c
index 0941d4a..58a9eb4 100644
--- a/win/tclWinSerial.c
+++ b/win/tclWinSerial.c
@@ -1036,7 +1036,7 @@ SerialOutputProc(
* the channel is in non-blocking mode.
*/
- errno = EWOULDBLOCK;
+ errno = EAGAIN;
goto error1;
}
diff --git a/win/tclWinSock.c b/win/tclWinSock.c
index 0c1a270..60cc313 100644
--- a/win/tclWinSock.c
+++ b/win/tclWinSock.c
@@ -1195,7 +1195,7 @@ CreateSocket(
if (connect(sock, addrPtr->ai_addr, addrPtr->ai_addrlen)
== SOCKET_ERROR) {
TclWinConvertWSAError((DWORD) WSAGetLastError());
- if (Tcl_GetErrno() != EWOULDBLOCK) {
+ if (Tcl_GetErrno() != EAGAIN) {
goto looperror;
}
@@ -1389,7 +1389,7 @@ WaitForSocketEvent(
} else if (infoPtr->readyEvents & events) {
break;
} else if (infoPtr->flags & SOCKET_ASYNC) {
- *errorCodePtr = EWOULDBLOCK;
+ *errorCodePtr = EAGAIN;
result = 0;
break;
}
@@ -1913,7 +1913,7 @@ TcpOutputProc(
if (error == WSAEWOULDBLOCK) {
infoPtr->readyEvents &= ~(FD_WRITE);
if (infoPtr->flags & SOCKET_ASYNC) {
- *errorCodePtr = EWOULDBLOCK;
+ *errorCodePtr = EAGAIN;
bytesWritten = -1;
break;
}
generated by cgit v0.12 at 2024-11-05 16:46:50 (GMT)