Tcl Source Code

2012-03-27  Donal K. Fellows  <[email protected]>

	IMPLEMENTATION OF TIP#395.

	* generic/tclCmdMZ.c (StringIsCmd): Implementation of the [string is
	entier] check. Code by Jos Decoster.

2012-03-27  Jan Nijtmans  <[email protected]>

	* 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  <[email protected]>

	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  <[email protected]>

	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  <[email protected]>

	* 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  <[email protected]>

	* 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  <[email protected]>

	* 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 <[email protected]>

	* library/tzdata/America/Atikokan: Update to tzdata2012b.
	* library/tzdata/America/Blanc-Sablon
	* library/tzdata/America/Dawson_Creek
	* library/tzdata/America/Edmonton

	by getaddrinfo() for all three arguments to socket() instead of
	only using ai_family. Try to keep the most meaningful error while
	iterating over the result list, because using the last error can
	be misleading.

2012-03-15  Jan Nijtmans  <[email protected]>

	* 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
	* win/tclWinFile.c
	* win/tclWinPort.h

2012-03-12  Jan Nijtmans  <[email protected]>

	* win/tclWinFile.c: [Bug 3388350]: mingw64 compiler warnings

2012-03-11  Donal K. Fellows  <[email protected]>

	* doc/*.n, doc/*.3: A number of small spelling and wording fixes.

2012-03-08  Donal K. Fellows  <[email protected]>

The \fBoo::copy\fR command creates a copy of an object or class. It takes the
name of the object or class to be copied, \fIsourceObject\fR, and optionally
the name of the object or class to create, \fItargetObject\fR, which will be
resolved relative to the current namespace if not an absolute qualified name.
If \fItargetObject\fR is omitted, a new name is chosen. The copied object will
be of the same class as the source object, and will have all its per-object
methods copied. If it is a class, it will also have all the class methods in
the class copied, but it will not have any of its instances copied.
.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
then demonstrates that the copied object is indeed a copy.
.PP
.CS
oo::object create src

.
This arranges for each of the named methods, \fIname\fR, to be exported
(i.e. usable outside an instance through the instance object's command) by the
class being defined. Note that the methods themselves may be actually defined
by a superclass; subclass exports override superclass visibility, and may in
turn be overridden by instances.
.TP
\fBfilter\fR ?\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.
.VS
By default, this slot works by appending.
.VE
.TP
\fBforward\fI name cmdName \fR?\fIarg ...\fR?
.
This creates or updates a forwarded method called \fIname\fR. The method is
defined be forwarded to the command called \fIcmdName\fR, with additional
arguments, \fIarg\fR etc., added before those arguments specified by the
caller of the method. The \fIcmdName\fR will always be resolved using the

be \fIargList\fR, and the body of the method will be \fIbodyScript\fR. When
the body of the method is evaluated, the current namespace of the method will
be a namespace that is unique to the current object. The method will be
exported if \fIname\fR starts with a lower-case letter, and non-exported
otherwise; this behavior can be overridden via \fBexport\fR and
\fBunexport\fR.
.TP
\fBmixin\fR ?\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.

.VS
By default, this slot works by replacement.
.VE
.TP
\fBrenamemethod\fI fromName toName\fR
.
This renames the method called \fIfromName\fR in a class to \fItoName\fR. The
method must have previously existed in the class, and \fItoName\fR must not
previously refer to a method in that class. Does not affect the superclasses
of the class, nor does it affect the subclasses or instances of the class

supported values of \fIsubcommand\fR). It follows the same general pattern of
argument handling as the \fBoo::define\fR and \fBoo::objdefine\fR commands,
and
.QW "\fBoo::define \fIcls \fBself \fIsubcommand ...\fR"
operates identically to
.QW "\fBoo::objdefine \fIcls subcommand ...\fR" .
.TP
\fBsuperclass\fI ?\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, 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?
.
This arranges for each of the named methods, \fIname\fR, to be not exported
(i.e. not usable outside the instance through the instance object's command,
but instead just through the \fBmy\fR command visible in each object's
context) by the class being defined. Note that the methods themselves may be
actually defined by a superclass; subclass unexports override superclass
visibility, and may be overridden by instance unexports.
.TP
\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, constructor and destructor declared by the class

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. By default, this slot works by appending.
.VE
.SS "CONFIGURING OBJECTS"
.PP
The following commands are supported in the \fIdefScript\fR for
\fBoo::objdefine\fR, each of which may also be used in the \fIsubcommand\fR
form:
.TP

\fBexport\fI name \fR?\fIname ...\fR?
.
This arranges for each of the named methods, \fIname\fR, to be exported
(i.e. usable outside the object through the object's command) by the object
being defined. Note that the methods themselves may be actually defined by a
class or superclass; object exports override class visibility.
.TP
\fBfilter\fR ?\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. 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?
.
This creates or updates a forwarded object method called \fIname\fR. The
method is defined be forwarded to the command called \fIcmdName\fR, with
additional arguments, \fIarg\fR etc., added before those arguments specified
by the caller of the method. Forwarded methods should be deleted using the
\fBmethod\fR subcommand. The method will be exported if \fIname\fR starts with
a lower-case letter, and non-exported otherwise.
.TP
\fBmethod\fI name argList bodyScript\fR
.
This creates, updates or deletes an object method. The name of the method is
\fIname\fR, the formal arguments to the method (defined using the same format
as for the Tcl \fBproc\fR command) will be \fIargList\fR, and the body of the
method will be \fIbodyScript\fR. When the body of the method is evaluated, the
current namespace of the method will be a namespace that is unique to the
object. The method will be exported if \fIname\fR starts with a lower-case
letter, and non-exported otherwise.
.TP
\fBmixin\fR ?\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.
.VS
By default, this slot works by replacement.
.VE
.TP
\fBrenamemethod\fI fromName toName\fR
.
This renames the method called \fIfromName\fR in an object to \fItoName\fR.
The method must have previously existed in the object, and \fItoName\fR must
not previously refer to a method in that object. Does not affect the classes
that the object is an instance of. Does not change the export status of the
method; if it was exported before, it will be afterwards.
.TP
\fBunexport\fI name \fR?\fIname ...\fR?
.
This arranges for each of the named methods, \fIname\fR, to be not exported
(i.e. not usable outside the object through the object's command, but instead
just through the \fBmy\fR command visible in the object's context) by the
object being defined. Note that the methods themselves may be actually defined
by a class; instance unexports override class visibility.
.TP
\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
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
\fBoo::objdefine\fR commands (they work in the same way), as well as
illustrating four of the subcommands of them.
.PP
.CS

}
o bar                \fI\(-> prints "hello world"\fR
o foo                \fI\(-> error "unknown method foo"\fR
o Foo Bar            \fI\(-> error "unknown method Foo"\fR
\fBoo::objdefine\fR o \fBrenamemethod\fR bar lollipop
o lollipop           \fI\(-> prints "hello world"\fR
.CE
.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, slot

.\" Local variables:
.\" mode: nroff
.\" fill-column: 78
.\" End:

.TP
\fIobj \fBeval\fR ?\fIarg ...\fR?
.
This method concatenates the arguments, \fIarg\fR, as if with \fBconcat\fR,
and then evaluates the resulting script in the namespace that is uniquely
associated with \fIobj\fR, returning the result of the evaluation.
.TP
\fIobj \fBunknown ?\fImethodName\fR? ?\fIarg ...\fR?
.
This method is called when an attempt to invoke the method \fImethodName\fR on
object \fIobj\fR fails. The arguments that the user supplied to the method are
given as \fIarg\fR 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?
.
This method arranges for each variable called \fIvarName\fR to be linked from
the object \fIobj\fR's unique namespace into the caller's context. Thus, if it
is invoked from inside a procedure then the namespace variable in the object
is linked to the local variable in the procedure. Each \fIvarName\fR argument
must not have any namespace separators in it. The result is the empty string.
.TP
\fIobj \fBvarname \fIvarName\fR
.
This method returns the globally qualified name of the variable \fIvarName\fR
in the unique namespace for the object \fIobj\fR.
.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.
.PP
.CS
set obj [\fBoo::object\fR new]
$obj foo             \fI\(-> error "unknown method foo"\fR

.IP \fBdigit\fR 12
Any Unicode digit character.  Note that this includes characters
outside of the [0\-9] range.
.IP \fBdouble\fR 12
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.
.IP \fBgraph\fR 12
Any Unicode printing character, except space.
.IP \fBinteger\fR 12
Any of the valid string formats for a 32-bit integer value in Tcl,

 * sprintf(...,"%" TCL_LL_MODIFIER "d",...).
 */

#if !defined(TCL_WIDE_INT_TYPE)&&!defined(TCL_WIDE_INT_IS_LONG)
#   if defined(__WIN32__)
#      define TCL_WIDE_INT_TYPE __int64
#      ifdef __BORLANDC__

#         define TCL_LL_MODIFIER	"L"
#      else /* __BORLANDC__ */







#         define TCL_LL_MODIFIER	"I64"
#      endif /* __BORLANDC__ */
#   elif defined(__GNUC__)
#      define TCL_WIDE_INT_TYPE long long
#      define TCL_LL_MODIFIER	"ll"





#   else /* ! __WIN32__ && ! __GNUC__ */
/*
 * Don't know what platform it is and configure hasn't discovered what is
 * going on for us. Try to guess...
 */
#      ifdef NO_LIMITS_H
#	  error please define either TCL_WIDE_INT_TYPE or TCL_WIDE_INT_IS_LONG

#   define TCL_WIDE_INT_TYPE	long
#endif /* TCL_WIDE_INT_IS_LONG */

typedef TCL_WIDE_INT_TYPE		Tcl_WideInt;
typedef unsigned TCL_WIDE_INT_TYPE	Tcl_WideUInt;

#ifdef TCL_WIDE_INT_IS_LONG

#   define Tcl_WideAsLong(val)		((long)(val))
#   define Tcl_LongAsWide(val)		((long)(val))
#   define Tcl_WideAsDouble(val)	((double)((long)(val)))
#   define Tcl_DoubleAsWide(val)	((long)((double)(val)))
#   ifndef TCL_LL_MODIFIER
#      define TCL_LL_MODIFIER		"l"
#   endif /* !TCL_LL_MODIFIER */
#else /* TCL_WIDE_INT_IS_LONG */
/*
 * The next short section of defines are only done when not running on Windows
 * or some other strange platform.
 */
#   ifndef TCL_LL_MODIFIER



















#      define TCL_LL_MODIFIER		"ll"
#   endif /* !TCL_LL_MODIFIER */
#   define Tcl_WideAsLong(val)		((long)((Tcl_WideInt)(val)))
#   define Tcl_LongAsWide(val)		((Tcl_WideInt)((long)(val)))
#   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

/*
 *----------------------------------------------------------------------------
 * Data structures defined opaquely in this module. The definitions below just
 * provide dummy types. A few fields are made visible in Tcl_Interp
 * structures, namely those used for returning a string result from commands.
 * Direct access to the result field is discouraged in Tcl 8.0. The

	 * For Windows, there are no user ids associated with a file, so we
	 * always return 1.
	 *
	 * TODO: use GetSecurityInfo to get the real owner of the file and
	 * test for equivalence to the current user.
	 */

#if defined(__WIN32__) || defined(__CYGWIN__)
	value = 1;
#else
	value = (geteuid() == buf.st_uid);
#endif
    }
    Tcl_SetObjResult(interp, Tcl_NewBooleanObj(value));
    return TCL_OK;

 *
 * See the file "license.terms" for information on usage and redistribution of
 * this file, and for a DISCLAIMER OF ALL WARRANTIES.
 */

#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);
static int		SwitchPostProc(ClientData data[], Tcl_Interp *interp,
			    int result);
static int		TryPostBody(ClientData data[], Tcl_Interp *interp,
			    int result);

{
    const char *string1, *end, *stop;
    Tcl_UniChar ch;
    int (*chcomp)(int) = NULL;	/* The UniChar comparison function. */
    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",	"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_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
    };
    enum isOptions {
	OPT_STRICT, OPT_FAILIDX
    };

    }
    case STR_IS_GRAPH:
	chcomp = Tcl_UniCharIsGraph;
	break;
    case STR_IS_INT:
	if (TCL_OK == TclGetIntFromObj(NULL, objPtr, &i)) {
	    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;
	}

	/*
	 * Prevent copying or renaming a file onto itself. On Windows since
	 * 8.5 we do get an inode number, however the unsigned short field is
	 * insufficient to accept the Win32 API file id so it is truncated to
	 * 16 bits and we get collisions. See bug #2015723.
	 */

#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)) {
		result = TCL_OK;
		goto done;
	    }
	}

# of this file, and for a DISCLAIMER OF ALL WARRANTIES.

library tcl

# Define the unsupported generic interfaces.

interface tclInt


# Declare each of the functions in the unsupported internal Tcl
# interface.  These interfaces are allowed to changed between versions.
# Use at your own risk.  Note that the position of functions should not
# be changed between versions to avoid gratuitous incompatibilities.

# Replaced by Tcl_FSAccess in 8.4:

#}
# variant of Tcl_UtfNCmp that takes n as bytes, not chars
declare 169 {
    int TclpUtfNcmp2(const char *s1, const char *s2, unsigned long n)
}
declare 170 {
    int TclCheckInterpTraces(Tcl_Interp *interp, const char *command,
	    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 objc, Tcl_Obj *const objv[])
}
declare 172 {
    int TclInThreadExit(void)
}

# added for 8.4.2

#    Tcl_Obj *TclNewListObjDirect(int objc, Tcl_Obj **objv)
# }
#declare 181 {
#    Tcl_Obj *TclDbNewListObjDirect(int objc, Tcl_Obj **objv,
#	    const char *file, int line)
#}

# TclpGmtime and TclpLocaltime promoted to the generic interface from unix

declare 182 {
     struct tm *TclpLocaltime(const time_t *clock)
}
declare 183 {
     struct tm *TclpGmtime(const time_t *clock)
}

	    Tcl_Channel outChan, Tcl_WideInt toRead, Tcl_Obj *cmdPtr)
}

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)
}

##############################################################################

# Define the platform specific internal Tcl interface. These functions are
# only available on the designated platform.

interface tclIntPlat

################################
# Windows specific functions

declare 0 win {
    void TclWinConvertError(DWORD errCode)
}
declare 1 win {
    void TclWinConvertWSAError(DWORD errCode)
}
declare 2 win {
    struct servent *TclWinGetServByName(const char *nm,
	    const char *proto)
}
declare 3 win {
    int TclWinGetSockOpt(SOCKET s, int level, int optname,

declare 18 win {
    TclFile TclpMakeFile(Tcl_Channel channel, int direction)
}
declare 19 win {
    TclFile TclpOpenFile(const char *fname, int mode)
}
declare 20 win {
    void TclWinAddProcess(HANDLE hProcess, DWORD id)
}

# removed permanently for 8.4
#declare 21 win {
#    void TclpAsyncMark(Tcl_AsyncHandler async)
#}

# Added in 8.1:
declare 22 win {
    TclFile TclpCreateTempFile(const char *contents)
}
declare 23 win {
    char *TclpGetTZName(int isdst)
}
declare 24 win {
    char *TclWinNoBackslash(char *path)
}
# replaced by generic TclGetPlatform
#declare 25 win {
#    TclPlatformType *TclWinGetPlatform(void)
#}
declare 26 win {
    void TclWinSetInterfaces(int wide)
}

}

################################
# Unix specific functions

# Pipe channel functions

# On non-cygwin, this is actually a reference to TclGetAndDetachPids
declare 0 unix {
    void TclWinConvertError(unsigned int errCode)
}
# On non-cygwin, this is actually a reference to TclpCloseFile
declare 1 unix {
    void TclWinConvertWSAError(unsigned int errCode)
}
declare 2 unix {
    Tcl_Channel TclpCreateCommandChannel(TclFile readFile,
	    TclFile writeFile, TclFile errorFile, int numPids, Tcl_Pid *pidPtr)
}
declare 3 unix {
    int TclpCreatePipe(TclFile *readPipe, TclFile *writePipe)
}
# On non-cygwin, this is actually a reference to TclpCreateProcess
declare 4 unix {
    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 {

    unsigned short TclWinNToHS(unsigned short ns)
}
# On non-cygwin, this is actually a reference to TclpOpenFile
declare 7 unix {
    int TclWinSetSockOpt(int s, int level, int optname,
	    const char *optval, int optlen)
}
declare 8 unix {
    int TclUnixWaitForFile(int fd, int mask, int timeout)
}

# Added in 8.1:

# On non-cygwin, this is actually a reference to TclpCreateTempFile
declare 9 unix {
    int TclWinGetPlatformId(void)
}

# Added in 8.4:

declare 10 unix {
    Tcl_DirEntry *TclpReaddir(DIR *dir)
}
# Slots 11 and 12 are forwarders for functions that were promoted to
# 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)
}
declare 13 unix {
    char *TclpInetNtoa(struct in_addr addr)
}

# Added in 8.5:

declare 14 unix {
    int TclUnixCopyFile(const char *src, const char *dst,
	    const Tcl_StatBuf *statBufPtr, int dontCopyAtts)
}








################################
# Mac OS X specific functions

#On cygwin, TclpCreateProcess is here
declare 15 {unix macosx} {
    int TclMacOSXGetFileAttribute(Tcl_Interp *interp, int objIndex,
	    Tcl_Obj *fileName, Tcl_Obj **attributePtrPtr)
}
declare 16 macosx {
    int TclMacOSXSetFileAttribute(Tcl_Interp *interp, int objIndex,
	    Tcl_Obj *fileName, Tcl_Obj *attributePtr)
}
declare 17 macosx {
    int TclMacOSXCopyFileAttributes(const char *src, const char *dst,
	    const Tcl_StatBuf *statBufPtr)
}
#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)
}
#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:
# mode: tcl
# End:

#   ifdef USE_TCL_STUBS
#      define TCL_STORAGE_CLASS
#   else
#      define TCL_STORAGE_CLASS DLLIMPORT
#   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
 * in the generic/tclInt.decls script.
 */

/* !BEGIN!: Do not edit below this line. */

/*
 * Exported function declarations:
 */

#if !defined(__WIN32__) && !defined(MAC_OSX_TCL) /* UNIX */
/* 0 */
EXTERN void		TclWinConvertError(unsigned int errCode);

/* 1 */
EXTERN void		TclWinConvertWSAError(unsigned int errCode);
/* 2 */
EXTERN Tcl_Channel	TclpCreateCommandChannel(TclFile readFile,
				TclFile writeFile, TclFile errorFile,
				int numPids, Tcl_Pid *pidPtr);
/* 3 */
EXTERN int		TclpCreatePipe(TclFile *readPipe, TclFile *writePipe);
/* 4 */
EXTERN int		TclWinGetTclInstance(void);



/* Slot 5 is reserved */
/* 6 */
EXTERN unsigned short	TclWinNToHS(unsigned short ns);
/* 7 */
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 */
EXTERN int		TclWinGetPlatformId(void);
/* 10 */
EXTERN Tcl_DirEntry *	TclpReaddir(DIR *dir);
/* 11 */
EXTERN struct tm *	TclpLocaltime_unix(const time_t *clock);
/* 12 */
EXTERN struct tm *	TclpGmtime_unix(const time_t *clock);
/* 13 */
EXTERN char *		TclpInetNtoa(struct in_addr addr);
/* 14 */
EXTERN int		TclUnixCopyFile(const char *src, const char *dst,
				const Tcl_StatBuf *statBufPtr,
				int dontCopyAtts);
/* 15 */
EXTERN int		TclMacOSXGetFileAttribute(Tcl_Interp *interp,
				int objIndex, Tcl_Obj *fileName,
				Tcl_Obj **attributePtrPtr);
/* Slot 16 is reserved */
/* Slot 17 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);
/* 23 */
EXTERN char *		TclpGetTZName(int isdst);
/* 24 */
EXTERN char *		TclWinNoBackslash(char *path);
/* Slot 25 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(DWORD errCode);
/* 1 */
EXTERN void		TclWinConvertWSAError(DWORD errCode);
/* 2 */
EXTERN struct servent *	 TclWinGetServByName(const char *nm,
				const char *proto);
/* 3 */
EXTERN int		TclWinGetSockOpt(SOCKET s, int level, int optname,
				char FAR *optval, int FAR *optlen);
/* 4 */

/* Slot 16 is reserved */
/* Slot 17 is reserved */
/* 18 */
EXTERN TclFile		TclpMakeFile(Tcl_Channel channel, int direction);
/* 19 */
EXTERN TclFile		TclpOpenFile(const char *fname, int mode);
/* 20 */
EXTERN void		TclWinAddProcess(HANDLE hProcess, DWORD id);
/* Slot 21 is reserved */
/* 22 */
EXTERN TclFile		TclpCreateTempFile(const char *contents);
/* 23 */
EXTERN char *		TclpGetTZName(int isdst);
/* 24 */
EXTERN char *		TclWinNoBackslash(char *path);
/* Slot 25 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);
#endif /* WIN */
#ifdef MAC_OSX_TCL /* MACOSX */
/* 0 */
EXTERN void		TclWinConvertError(unsigned int errCode);

/* 1 */
EXTERN void		TclWinConvertWSAError(unsigned int errCode);
/* 2 */
EXTERN Tcl_Channel	TclpCreateCommandChannel(TclFile readFile,
				TclFile writeFile, TclFile errorFile,
				int numPids, Tcl_Pid *pidPtr);
/* 3 */
EXTERN int		TclpCreatePipe(TclFile *readPipe, TclFile *writePipe);
/* 4 */
EXTERN int		TclWinGetTclInstance(void);



/* Slot 5 is reserved */
/* 6 */
EXTERN unsigned short	TclWinNToHS(unsigned short ns);
/* 7 */
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 */
EXTERN int		TclWinGetPlatformId(void);
/* 10 */
EXTERN Tcl_DirEntry *	TclpReaddir(DIR *dir);
/* 11 */

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);
/* 23 */
EXTERN char *		TclpGetTZName(int isdst);
/* 24 */
EXTERN char *		TclWinNoBackslash(char *path);
/* Slot 25 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 {
    int magic;
    const struct TclIntPlatStubHooks *hooks;

#if !defined(__WIN32__) && !defined(MAC_OSX_TCL) /* UNIX */
    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 (*tclWinGetTclInstance) (void); /* 4 */
    void (*reserved5)(void);
    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 */
    struct tm * (*tclpLocaltime_unix) (const time_t *clock); /* 11 */
    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 */
    int (*tclMacOSXGetFileAttribute) (Tcl_Interp *interp, int objIndex, Tcl_Obj *fileName, Tcl_Obj **attributePtrPtr); /* 15 */
    void (*reserved16)(void);
    void (*reserved17)(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 */
    char * (*tclpGetTZName) (int isdst); /* 23 */
    char * (*tclWinNoBackslash) (char *path); /* 24 */
    void (*reserved25)(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) (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 */
    void (*reserved5)(void);
    u_short (*tclWinNToHS) (u_short ns); /* 6 */
    int (*tclWinSetSockOpt) (SOCKET s, int level, int optname, const char FAR *optval, int optlen); /* 7 */
    unsigned long (*tclpGetPid) (Tcl_Pid pid); /* 8 */
    int (*tclWinGetPlatformId) (void); /* 9 */
    void (*reserved10)(void);
    void (*tclGetAndDetachPids) (Tcl_Interp *interp, Tcl_Channel chan); /* 11 */
    int (*tclpCloseFile) (TclFile file); /* 12 */
    Tcl_Channel (*tclpCreateCommandChannel) (TclFile readFile, TclFile writeFile, TclFile errorFile, int numPids, Tcl_Pid *pidPtr); /* 13 */
    int (*tclpCreatePipe) (TclFile *readPipe, TclFile *writePipe); /* 14 */
    int (*tclpCreateProcess) (Tcl_Interp *interp, int argc, const char **argv, TclFile inputFile, TclFile outputFile, TclFile errorFile, Tcl_Pid *pidPtr); /* 15 */
    void (*reserved16)(void);
    void (*reserved17)(void);
    TclFile (*tclpMakeFile) (Tcl_Channel channel, int direction); /* 18 */
    TclFile (*tclpOpenFile) (const char *fname, int mode); /* 19 */
    void (*tclWinAddProcess) (HANDLE hProcess, DWORD id); /* 20 */
    void (*reserved21)(void);
    TclFile (*tclpCreateTempFile) (const char *contents); /* 22 */
    char * (*tclpGetTZName) (int isdst); /* 23 */
    char * (*tclWinNoBackslash) (char *path); /* 24 */
    void (*reserved25)(void);
    void (*tclWinSetInterfaces) (int wide); /* 26 */
    void (*tclWinFlushDirtyChannels) (void); /* 27 */
    void (*tclWinResetInterfaces) (void); /* 28 */
    int (*tclWinCPUID) (unsigned int index, unsigned int *regs); /* 29 */
#endif /* WIN */
#ifdef MAC_OSX_TCL /* MACOSX */
    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 (*tclWinGetTclInstance) (void); /* 4 */
    void (*reserved5)(void);
    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 */
    struct tm * (*tclpLocaltime_unix) (const time_t *clock); /* 11 */
    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 */
    int (*tclMacOSXGetFileAttribute) (Tcl_Interp *interp, int objIndex, Tcl_Obj *fileName, Tcl_Obj **attributePtrPtr); /* 15 */
    int (*tclMacOSXSetFileAttribute) (Tcl_Interp *interp, int objIndex, Tcl_Obj *fileName, Tcl_Obj *attributePtr); /* 16 */
    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 (*tclWinAddProcess) (void *hProcess, unsigned long id); /* 20 */
    void (*reserved21)(void);
    TclFile (*tclpCreateTempFile) (const char *contents); /* 22 */
    char * (*tclpGetTZName) (int isdst); /* 23 */
    char * (*tclWinNoBackslash) (char *path); /* 24 */
    void (*reserved25)(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;

#ifdef __cplusplus
extern "C" {
#endif
extern const TclIntPlatStubs *tclIntPlatStubsPtr;
#ifdef __cplusplus
}
#endif

#if defined(USE_TCL_STUBS)

/*
 * Inline function declarations:
 */

#if !defined(__WIN32__) && !defined(MAC_OSX_TCL) /* UNIX */
#define TclWinConvertError \
	(tclIntPlatStubsPtr->tclWinConvertError) /* 0 */
#define TclWinConvertWSAError \
	(tclIntPlatStubsPtr->tclWinConvertWSAError) /* 1 */
#define TclpCreateCommandChannel \
	(tclIntPlatStubsPtr->tclpCreateCommandChannel) /* 2 */
#define TclpCreatePipe \
	(tclIntPlatStubsPtr->tclpCreatePipe) /* 3 */
#define TclWinGetTclInstance \
	(tclIntPlatStubsPtr->tclWinGetTclInstance) /* 4 */
/* Slot 5 is reserved */
#define TclWinNToHS \
	(tclIntPlatStubsPtr->tclWinNToHS) /* 6 */
#define TclWinSetSockOpt \
	(tclIntPlatStubsPtr->tclWinSetSockOpt) /* 7 */
#define TclUnixWaitForFile \
	(tclIntPlatStubsPtr->tclUnixWaitForFile) /* 8 */
#define TclWinGetPlatformId \
	(tclIntPlatStubsPtr->tclWinGetPlatformId) /* 9 */
#define TclpReaddir \
	(tclIntPlatStubsPtr->tclpReaddir) /* 10 */
#define TclpLocaltime_unix \
	(tclIntPlatStubsPtr->tclpLocaltime_unix) /* 11 */
#define TclpGmtime_unix \
	(tclIntPlatStubsPtr->tclpGmtime_unix) /* 12 */
#define TclpInetNtoa \
	(tclIntPlatStubsPtr->tclpInetNtoa) /* 13 */
#define TclUnixCopyFile \
	(tclIntPlatStubsPtr->tclUnixCopyFile) /* 14 */
#define TclMacOSXGetFileAttribute \
	(tclIntPlatStubsPtr->tclMacOSXGetFileAttribute) /* 15 */
/* Slot 16 is reserved */
/* Slot 17 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 */
#define TclpGetTZName \
	(tclIntPlatStubsPtr->tclpGetTZName) /* 23 */
#define TclWinNoBackslash \
	(tclIntPlatStubsPtr->tclWinNoBackslash) /* 24 */
/* Slot 25 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 \
	(tclIntPlatStubsPtr->tclWinConvertError) /* 0 */
#define TclWinConvertWSAError \
	(tclIntPlatStubsPtr->tclWinConvertWSAError) /* 1 */
#define TclWinGetServByName \

	(tclIntPlatStubsPtr->tclWinFlushDirtyChannels) /* 27 */
#define TclWinResetInterfaces \
	(tclIntPlatStubsPtr->tclWinResetInterfaces) /* 28 */
#define TclWinCPUID \
	(tclIntPlatStubsPtr->tclWinCPUID) /* 29 */
#endif /* WIN */
#ifdef MAC_OSX_TCL /* MACOSX */
#define TclWinConvertError \
	(tclIntPlatStubsPtr->tclWinConvertError) /* 0 */
#define TclWinConvertWSAError \
	(tclIntPlatStubsPtr->tclWinConvertWSAError) /* 1 */
#define TclpCreateCommandChannel \
	(tclIntPlatStubsPtr->tclpCreateCommandChannel) /* 2 */
#define TclpCreatePipe \
	(tclIntPlatStubsPtr->tclpCreatePipe) /* 3 */
#define TclWinGetTclInstance \
	(tclIntPlatStubsPtr->tclWinGetTclInstance) /* 4 */
/* Slot 5 is reserved */
#define TclWinNToHS \
	(tclIntPlatStubsPtr->tclWinNToHS) /* 6 */
#define TclWinSetSockOpt \
	(tclIntPlatStubsPtr->tclWinSetSockOpt) /* 7 */
#define TclUnixWaitForFile \
	(tclIntPlatStubsPtr->tclUnixWaitForFile) /* 8 */
#define TclWinGetPlatformId \
	(tclIntPlatStubsPtr->tclWinGetPlatformId) /* 9 */
#define TclpReaddir \
	(tclIntPlatStubsPtr->tclpReaddir) /* 10 */
#define TclpLocaltime_unix \

	(tclIntPlatStubsPtr->tclMacOSXSetFileAttribute) /* 16 */
#define TclMacOSXCopyFileAttributes \
	(tclIntPlatStubsPtr->tclMacOSXCopyFileAttributes) /* 17 */
#define TclMacOSXMatchType \
	(tclIntPlatStubsPtr->tclMacOSXMatchType) /* 18 */
#define TclMacOSXNotifierAddRunLoopMode \
	(tclIntPlatStubsPtr->tclMacOSXNotifierAddRunLoopMode) /* 19 */
#define TclWinAddProcess \
	(tclIntPlatStubsPtr->tclWinAddProcess) /* 20 */
/* Slot 21 is reserved */
#define TclpCreateTempFile \
	(tclIntPlatStubsPtr->tclpCreateTempFile) /* 22 */
#define TclpGetTZName \
	(tclIntPlatStubsPtr->tclpGetTZName) /* 23 */
#define TclWinNoBackslash \
	(tclIntPlatStubsPtr->tclWinNoBackslash) /* 24 */
/* Slot 25 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) */

/* !END!: Do not edit above this line. */

#undef TCL_STORAGE_CLASS
#define TCL_STORAGE_CLASS DLLIMPORT
#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 */

    Tcl_ObjCmdProc *objProc;
    int flag;
} defineCmds[] = {
    {"constructor", TclOODefineConstructorObjCmd, 0},
    {"deletemethod", TclOODefineDeleteMethodObjCmd, 0},
    {"destructor", TclOODefineDestructorObjCmd, 0},
    {"export", TclOODefineExportObjCmd, 0},

    {"forward", TclOODefineForwardObjCmd, 0},
    {"method", TclOODefineMethodObjCmd, 0},

    {"renamemethod", TclOODefineRenameMethodObjCmd, 0},
    {"self", TclOODefineSelfObjCmd, 0},

    {"unexport", TclOODefineUnexportObjCmd, 0},

    {NULL, NULL, 0}
}, objdefCmds[] = {
    {"class", TclOODefineClassObjCmd, 1},
    {"deletemethod", TclOODefineDeleteMethodObjCmd, 1},
    {"export", TclOODefineExportObjCmd, 1},

    {"forward", TclOODefineForwardObjCmd, 1},
    {"method", TclOODefineMethodObjCmd, 1},

    {"renamemethod", TclOODefineRenameMethodObjCmd, 1},
    {"unexport", TclOODefineUnexportObjCmd, 1},

    {NULL, NULL, 0}
};

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

static void		DeletedHelpersNamespace(ClientData clientData);
static int		FinalizeAlloc(ClientData data[],
			    Tcl_Interp *interp, int result);
static int		FinalizeNext(ClientData data[],
			    Tcl_Interp *interp, int result);
static int		FinalizeObjectCall(ClientData data[],
			    Tcl_Interp *interp, int result);
static int		InitFoundation(Tcl_Interp *interp);
static void		KillFoundation(ClientData clientData,
			    Tcl_Interp *interp);
static void		MyDeleted(ClientData clientData);
static void		ObjectNamespaceDeleted(ClientData clientData);
static void		ObjectRenamedTrace(ClientData clientData,
			    Tcl_Interp *interp, const char *oldName,
			    const char *newName, int flags);

}, clsMethods[] = {
    DCM("create", 1,	TclOO_Class_Create),
    DCM("new", 1,	TclOO_Class_New),
    DCM("createWithNamespace", 0, TclOO_Class_CreateNs),
    {NULL, 0, {0, NULL, NULL, NULL, NULL}}
};

/*
 * 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;

/*
 * Convenience macro for getting the foundation from an interpreter.
 */

#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))

/*
 * ----------------------------------------------------------------------
 *
 * TclOOInit --
 *
 *	Called to initialise the OO system within an interpreter.

TclOOInit(
    Tcl_Interp *interp)		/* The interpreter to install into. */
{
    /*
     * Build the core of the OO system.
     */

    if (InitFoundation(interp) != TCL_OK) {
	return TCL_ERROR;
    }

    /*
     * Run our initialization script and, if that works, declare the package
     * to be fully provided.
     */

    if (Tcl_Eval(interp, initScript) != TCL_OK) {

 *	Set up the core of the OO core class system. This is a structure
 *	holding references to the magical bits that need to be known about in
 *	other places, plus the oo::object and oo::class classes.
 *
 * ----------------------------------------------------------------------
 */

static int
InitFoundation(
    Tcl_Interp *interp)
{
    static Tcl_ThreadDataKey tsdKey;
    ThreadLocalData *tsdPtr =
	    Tcl_GetThreadData(&tsdKey, sizeof(ThreadLocalData));
    Foundation *fPtr = ckalloc(sizeof(Foundation));

	    DeletedDefineNamespace);
    fPtr->objdefNs = Tcl_CreateNamespace(interp, "::oo::objdefine", fPtr,
	    DeletedObjdefNamespace);
    fPtr->helpersNs = Tcl_CreateNamespace(interp, "::oo::Helpers", fPtr,
	    DeletedHelpersNamespace);
    fPtr->epoch = 0;
    fPtr->tsdPtr = tsdPtr;
    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);
    TclNewLiteralStringObj(namePtr, "::oo::UnknownDefinition");
    Tcl_SetNamespaceUnknownHandler(interp, fPtr->defineNs, namePtr);
    Tcl_SetNamespaceUnknownHandler(interp, fPtr->objdefNs, namePtr);

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

    fPtr->objectCls = AllocClass(interp,
	    AllocObject(interp, "::oo::object", NULL));
    fPtr->classCls = AllocClass(interp,
	    AllocObject(interp, "::oo::class", NULL));
    fPtr->objectCls->thisPtr->selfCls = fPtr->classCls;
    fPtr->objectCls->thisPtr->flags |= ROOT_OBJECT;
    fPtr->objectCls->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);
    AddRef(fPtr->objectCls);

    /*
     * Basic method declarations for the core classes.
     */

    for (i=0 ; objMethods[i].name ; i++) {
	TclOONewBasicMethod(interp, fPtr->objectCls, &objMethods[i]);
    }
    for (i=0 ; clsMethods[i].name ; i++) {
	TclOONewBasicMethod(interp, fPtr->classCls, &clsMethods[i]);
    }

    /*
     * 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.
     *
     * The 0xDeadBeef is a special signal to the errorInfo logger that is used
     * by constructors that stops it from generating extra error information
     * that is confusing.
     */

    TclNewLiteralStringObj(namePtr, "new");
    Tcl_NewInstanceMethod(interp, (Tcl_Object) fPtr->classCls->thisPtr,
	    namePtr /* keeps ref */, 0 /* ==private */, NULL, NULL);

    TclNewLiteralStringObj(argsPtr, "{definitionScript {}}");
    Tcl_IncrRefCount(argsPtr);
    bodyPtr = Tcl_NewStringObj(classConstructorBody, -1);






    fPtr->classCls->constructorPtr = TclOONewProcMethod(interp,
	    fPtr->classCls, 0, NULL, argsPtr, bodyPtr, NULL);
    Tcl_DecrRefCount(argsPtr);

    /*
     * Create non-object commands and plug ourselves into the Tcl [info]
     * ensemble.

	    NULL);
    Tcl_CreateObjCommand(interp, "::oo::define", TclOODefineObjCmd, NULL,
	    NULL);
    Tcl_CreateObjCommand(interp, "::oo::objdefine", TclOOObjDefObjCmd, NULL,
	    NULL);
    Tcl_CreateObjCommand(interp, "::oo::copy", TclOOCopyObjectCmd, NULL,NULL);
    TclOOInitInfo(interp);

    /*
     * Now make the class of slots.
     */

    if (TclOODefineSlots(fPtr) != TCL_OK) {
	return TCL_ERROR;
    }
    return Tcl_Eval(interp, slotScript);
}

/*
 * ----------------------------------------------------------------------
 *
 * DeletedDefineNamespace, DeletedObjdefNamespace, DeletedHelpersNamespace --
 *

    Foundation *fPtr = GetFoundation(interp);

    DelRef(fPtr->objectCls->thisPtr);
    DelRef(fPtr->objectCls);
    Tcl_DecrRefCount(fPtr->unknownMethodNameObj);
    Tcl_DecrRefCount(fPtr->constructorName);
    Tcl_DecrRefCount(fPtr->destructorName);
    Tcl_DecrRefCount(fPtr->clonedName);
    ckfree(fPtr);
}

/*
 * ----------------------------------------------------------------------
 *
 * AllocObject --

    ClientData clientData,	/* The object being deleted. */
    Tcl_Interp *interp,		/* The interpreter containing the object. */
    const char *oldName,	/* What the object was (last) called. */
    const char *newName,	/* Always NULL. */
    int flags)			/* Why was the object deleted? */
{
    Object *oPtr = clientData;
    Foundation *fPtr = oPtr->fPtr;


    /*
     * If this is a rename and not a delete of the object, we just flush the
     * cache of the object name.
     */

    if (flags & TCL_TRACE_RENAME) {

     * We also do not run destructors on the core class objects when the
     * interpreter is being deleted; their incestuous nature causes problems
     * in that case when the destructor is partially deleted before the uses
     * of it have gone. [Bug 2949397]
     */

    AddRef(oPtr);
    AddRef(fPtr->classCls);
    AddRef(fPtr->objectCls);
    AddRef(fPtr->classCls->thisPtr);
    AddRef(fPtr->objectCls->thisPtr);
    oPtr->command = 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) {
	    contextPtr->callPtr->flags |= DESTRUCTOR;
	    contextPtr->skip = 0;
	    state = Tcl_SaveInterpState(interp, TCL_OK);
	    result = Tcl_NRCallObjProc(interp, TclOOInvokeContext,
		    contextPtr, 0, NULL);
	    if (result != TCL_OK) {
		Tcl_BackgroundError(interp);
	    }
	    Tcl_RestoreInterpState(interp, state);
	    TclOODeleteContext(contextPtr);
	}
    }

    /*
     * OK, the destructor's been run. Time to splat the class data (if any)
     * and nuke the namespace (which triggers the final crushing of the object
     * structure itself).
     *
     * 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 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) && IsRootObject(oPtr)
	    && !Deleted(fPtr->classCls->thisPtr)) {
	Tcl_DeleteCommandFromToken(interp, fPtr->classCls->thisPtr->command);



    }

    if (oPtr->classPtr != NULL) {
	AddRef(oPtr->classPtr);


	ReleaseClassContents(interp, oPtr);
    }

    /*
     * The namespace is only deleted if it hasn't already been deleted. [Bug
     * 2950259]
     */

    if (((Namespace *) oPtr->namespacePtr)->earlyDeleteProc != NULL) {
	Tcl_DeleteNamespace(oPtr->namespacePtr);
    }
    if (oPtr->classPtr) {
	DelRef(oPtr->classPtr);
    }
    DelRef(fPtr->classCls->thisPtr);
    DelRef(fPtr->objectCls->thisPtr);
    DelRef(fPtr->classCls);
    DelRef(fPtr->objectCls);
    DelRef(oPtr);
}

/*
 * ----------------------------------------------------------------------
 *
 * ReleaseClassContents --
 *
 *	Tear down the special class data structure, including deleting all
 *	dependent classes and objects.
 *
 * ----------------------------------------------------------------------
 */

static void
ReleaseClassContents(
    Tcl_Interp *interp,		/* The interpreter containing the class. */
    Object *oPtr)		/* The object representing the class. */
{
    FOREACH_HASH_DECLS;
    int i;
    Class *clsPtr = oPtr->classPtr, *mixinSubclassPtr, *subclassPtr;
    Object *instancePtr;
    Foundation *fPtr = oPtr->fPtr;

    /*
     * Sanity check!
     */

    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");
	}
    }

    /*
     * 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);
	}
    }
    FOREACH(subclassPtr, clsPtr->subclasses) {
	if (subclassPtr != NULL && !IsRoot(subclassPtr)) {
	    AddRef(subclassPtr);
	    AddRef(subclassPtr->thisPtr);
	}
    }
    if (!IsRootClass(oPtr)) {
	FOREACH(instancePtr, clsPtr->instances) {
	    if (instancePtr != NULL && !IsRoot(instancePtr)) {
		AddRef(instancePtr);
	    }
	}
    }

    /*
     * 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(mixinSubclassPtr->thisPtr);
	DelRef(mixinSubclassPtr);
    }
    if (clsPtr->mixinSubs.list != NULL) {
	ckfree(clsPtr->mixinSubs.list);
	clsPtr->mixinSubs.list = NULL;
	clsPtr->mixinSubs.num = 0;
    }

    /*
     * 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;
    }

    /*
     * 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);
	}
    }
    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;
    }
    if (clsPtr->destructorChainPtr) {
	TclOODeleteChain(clsPtr->destructorChainPtr);
	clsPtr->destructorChainPtr = NULL;
    }
    if (clsPtr->classChainCache) {

	CallChain *callPtr;

	FOREACH_HASH_VALUE(callPtr, clsPtr->classChainCache) {
	    TclOODeleteChain(callPtr);
	}
	Tcl_DeleteHashTable(clsPtr->classChainCache);
	ckfree(clsPtr->classChainCache);
	clsPtr->classChainCache = NULL;
    }

    /*
     * Squelch our filter list.
     */

    if (clsPtr->filters.num) {
	Tcl_Obj *filterObj;

	FOREACH(filterObj, clsPtr->filters) {
	    Tcl_DecrRefCount(filterObj);
	}
	ckfree(clsPtr->filters.list);
	clsPtr->filters.num = 0;
    }

    /*
     * Squelch our metadata.
     */

    if (clsPtr->metadataPtr != NULL) {

	Tcl_ObjectMetadataType *metadataTypePtr;
	ClientData value;

	FOREACH_HASH(metadataTypePtr, value, clsPtr->metadataPtr) {
	    metadataTypePtr->deleteProc(value);
	}
	Tcl_DeleteHashTable(clsPtr->metadataPtr);

				 * being deleted. */
{
    Object *oPtr = clientData;
    FOREACH_HASH_DECLS;
    Class *clsPtr = oPtr->classPtr, *mixinPtr;
    Method *mPtr;
    Tcl_Obj *filterObj, *variableObj;
    int i;

    /*
     * Instruct everyone to no longer use any allocated fields of the object.
     * Also delete the commands that refer to the object at this point (if
     * they still exist) because otherwise their references to the object
     * point into freed memory, allowing crashes.
     */


    if (oPtr->command) {
	Tcl_DeleteCommandFromToken(oPtr->fPtr->interp, oPtr->command);
    }
    if (oPtr->myCommand) {
	Tcl_DeleteCommandFromToken(oPtr->fPtr->interp, oPtr->myCommand);







    }

    /*
     * Splice the object out of its context. After this, we must *not* call
     * methods on the object.
     */

    if (!IsRootObject(oPtr)) {
	TclOORemoveFromInstances(oPtr, oPtr->selfCls);
    }

    FOREACH(mixinPtr, oPtr->mixins) {
	TclOORemoveFromInstances(oPtr, mixinPtr);
    }
    if (i) {

	Tcl_DeleteHashTable(oPtr->metadataPtr);
	ckfree(oPtr->metadataPtr);
	oPtr->metadataPtr = NULL;
    }

    if (clsPtr != NULL) {
	Class *superPtr;


	Tcl_ObjectMetadataType *metadataTypePtr;
	ClientData value;

	if (clsPtr->metadataPtr != NULL) {
	    FOREACH_HASH(metadataTypePtr, value, clsPtr->metadataPtr) {
		metadataTypePtr->deleteProc(value);
	    }
	    Tcl_DeleteHashTable(clsPtr->metadataPtr);
	    ckfree(clsPtr->metadataPtr);
	    clsPtr->metadataPtr = NULL;
	}

	FOREACH(filterObj, clsPtr->filters) {
	    Tcl_DecrRefCount(filterObj);
	}
	if (i) {
	    ckfree(clsPtr->filters.list);
	    clsPtr->filters.num = 0;
	}
	FOREACH(mixinPtr, clsPtr->mixins) {
	    if (!Deleted(mixinPtr->thisPtr)) {
		TclOORemoveFromMixinSubs(clsPtr, mixinPtr);
	    }
	}
	if (i) {
	    ckfree(clsPtr->mixins.list);
	    clsPtr->mixins.num = 0;
	}
	FOREACH(superPtr, clsPtr->superclasses) {
	    if (!Deleted(superPtr->thisPtr)) {
		TclOORemoveFromSubclasses(clsPtr, superPtr);
	    }
	}
	if (i) {
	    ckfree(clsPtr->superclasses.list);
	    clsPtr->superclasses.num = 0;
	}

    }

    /*
     * Delete the object structure itself.
     */

    DelRef(oPtr);






}

/*
 * ----------------------------------------------------------------------
 *
 * TclOORemoveFromInstances --
 *

	if (oPtr == instPtr) {
	    goto removeInstance;
	}
    }
    return;

  removeInstance:
    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;
    }
}

/*
 * ----------------------------------------------------------------------
 *
 * TclOOAddToInstances --
 *
 *	Utility function to add an object to the list of instances within a
 *	class.
 *
 * ----------------------------------------------------------------------
 */

void
TclOOAddToInstances(
    Object *oPtr,		/* The instance to add. */
    Class *clsPtr)		/* The class to add the instance to. It is
				 * assumed that the class is not already
				 * present as an instance in the class. */
{
    if (Deleted(clsPtr->thisPtr)) {
	return;
    }
    if (clsPtr->instances.num >= clsPtr->instances.size) {
	clsPtr->instances.size += ALLOC_CHUNK;
	if (clsPtr->instances.size == ALLOC_CHUNK) {
	    clsPtr->instances.list = ckalloc(sizeof(Object *) * ALLOC_CHUNK);
	} else {
	    clsPtr->instances.list = ckrealloc(clsPtr->instances.list,
		    sizeof(Object *) * clsPtr->instances.size);

	if (subPtr == subclsPtr) {
	    goto removeSubclass;
	}
    }
    return;

  removeSubclass:
    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;
    }
}

/*
 * ----------------------------------------------------------------------
 *
 * TclOOAddToSubclasses --
 *
 *	Utility function to add a class to the list of subclasses within
 *	another class.
 *
 * ----------------------------------------------------------------------
 */

void
TclOOAddToSubclasses(
    Class *subPtr,		/* The subclass to add. */
    Class *superPtr)		/* The superclass to add the subclass to. It
				 * is assumed that the class is not already
				 * present as a subclass in the superclass. */
{
    if (Deleted(superPtr->thisPtr)) {
	return;
    }
    if (superPtr->subclasses.num >= superPtr->subclasses.size) {
	superPtr->subclasses.size += ALLOC_CHUNK;
	if (superPtr->subclasses.size == ALLOC_CHUNK) {
	    superPtr->subclasses.list = ckalloc(sizeof(Class*) * ALLOC_CHUNK);
	} else {
	    superPtr->subclasses.list = ckrealloc(superPtr->subclasses.list,
		    sizeof(Class *) * superPtr->subclasses.size);

	if (subPtr == subclsPtr) {
	    goto removeSubclass;
	}
    }
    return;

  removeSubclass:
    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;
    }
}

/*
 * ----------------------------------------------------------------------
 *
 * TclOOAddToMixinSubs --
 *
 *	Utility function to add a class to the list of mixinSubs within
 *	another class.
 *
 * ----------------------------------------------------------------------
 */

void
TclOOAddToMixinSubs(
    Class *subPtr,		/* The subclass to add. */
    Class *superPtr)		/* The superclass to add the subclass to. It
				 * is assumed that the class is not already
				 * present as a subclass in the superclass. */
{
    if (Deleted(superPtr->thisPtr)) {
	return;
    }
    if (superPtr->mixinSubs.num >= superPtr->mixinSubs.size) {
	superPtr->mixinSubs.size += ALLOC_CHUNK;
	if (superPtr->mixinSubs.size == ALLOC_CHUNK) {
	    superPtr->mixinSubs.list = ckalloc(sizeof(Class *) * ALLOC_CHUNK);
	} else {
	    superPtr->mixinSubs.list = ckrealloc(superPtr->mixinSubs.list,
		    sizeof(Class *) * superPtr->mixinSubs.size);

     */

    if (objc >= 0) {
	CallContext *contextPtr =
		TclOOGetCallContext(oPtr, NULL, CONSTRUCTOR, NULL);

	if (contextPtr != NULL) {
	    int result;
	    Tcl_InterpState state;

	    state = Tcl_SaveInterpState(interp, TCL_OK);
	    contextPtr->callPtr->flags |= CONSTRUCTOR;
	    contextPtr->skip = skip;
	    result = Tcl_NRCallObjProc(interp, TclOOInvokeContext, contextPtr,
		    objc, objv);


	    /*
	     * It's an error if the object was whacked in the constructor.
	     * Force this if it isn't already an error (don't want to lose
	     * errors by accident...) [Bug 2903011]
	     */

	    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;
	    }
	    TclOODeleteContext(contextPtr);
	    if (result != TCL_OK) {
		Tcl_DiscardInterpState(state);

		/*
		 * Take care to not delete a deleted object; that would be
		 * bad. [Bug 2903011]
		 */

		if (!Deleted(oPtr)) {
		    Tcl_DeleteCommandFromToken(interp, oPtr->command);
		}
		return NULL;
	    }
	    Tcl_RestoreInterpState(interp, state);
	}
    }

    contextPtr->callPtr->flags |= CONSTRUCTOR;
    contextPtr->skip = skip;

    /*
     * Fire off the constructors non-recursively.
     */

    AddRef(oPtr);
    TclNRAddCallback(interp, FinalizeAlloc, contextPtr, oPtr, state,
	    objectPtr);
    TclPushTailcallPoint(interp);
    return TclOOInvokeContext(contextPtr, interp, objc, objv);
}

static int
FinalizeAlloc(
    ClientData data[],
    Tcl_Interp *interp,
    int result)
{
    CallContext *contextPtr = data[0];
    Object *oPtr = data[1];
    Tcl_InterpState state = data[2];
    Tcl_Object *objectPtr = data[3];
    //int flags = oPtr->flags;

    /*
     * It's an error if the object was whacked in the constructor. Force this
     * if it isn't already an error (don't want to lose errors by accident...)
     * [Bug 2903011]
     */

    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;
    }
    TclOODeleteContext(contextPtr);
    if (result != TCL_OK) {
	Tcl_DiscardInterpState(state);

	/*
	 * Take care to not delete a deleted object; that would be bad. [Bug
	 * 2903011]
	 */

	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;
}

/*
 * ----------------------------------------------------------------------
 *
 * Tcl_CopyObjectInstance --

    const char *targetName,
    const char *targetNamespaceName)
{
    Object *oPtr = (Object *) sourceObject, *o2Ptr;
    FOREACH_HASH_DECLS;
    Method *mPtr;
    Class *mixinPtr;
    CallContext *contextPtr;
    Tcl_Obj *keyPtr, *filterObj, *variableObj, *args[3];
    int i, result;

    /*
     * Sanity check.
     */







    if (IsRootClass(oPtr)) {
	Tcl_AppendResult(interp, "may not clone the class of classes", NULL);
	Tcl_SetErrorCode(interp, "TCL", "OO", "CLONING_CLASS", NULL);
	return NULL;
    }

    /*
     * Build the instance. Note that this does not run any constructors.

     * Copy the object's flags to the new object, clearing those that must be
     * kept object-local. The duplicate is never deleted at this point, nor is
     * it the root of the object system or in the midst of processing a filter
     * call.
     */

    o2Ptr->flags = oPtr->flags & ~(
	    OBJECT_DELETED | ROOT_OBJECT | ROOT_CLASS | FILTER_HANDLING);

    /*
     * Copy the object's metadata.
     */

    if (oPtr->metadataPtr != NULL) {
	Tcl_ObjectMetadataType *metadataTypePtr;

		if (duplicate != NULL) {
		    Tcl_ClassSetMetadata((Tcl_Class) cls2Ptr, metadataTypePtr,
			    duplicate);
		}
	    }
	}
    }

    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;
}

/*
 * ----------------------------------------------------------------------
 *

				 * filters and the object's methods (which is
				 * the normal case). */
{
    CallContext *contextPtr;
    Tcl_Obj *methodNamePtr;
    int result;

    /*
     * If we've no method name, throw this directly into the unknown
     * processing.
     */

    if (objc < 2) {
	flags |= FORCE_UNKNOWN;
	methodNamePtr = NULL;

	goto noMapping;
    }

    /*
     * Give plugged in code a chance to remap the method name.
     */

    methodNamePtr = objv[1];

    return (Tcl_Class) ((Object *)object)->classPtr;
}

int
Tcl_ObjectDeleted(
    Tcl_Object object)
{
    return Deleted(object) ? 1 : 0;
}

Tcl_Object
Tcl_GetClassAsObject(
    Tcl_Class clazz)
{
    return (Tcl_Object) ((Class *)clazz)->thisPtr;

	oPtr->flags |= DESTRUCTOR_CALLED;
	contextPtr = TclOOGetCallContext(oPtr, NULL, DESTRUCTOR, NULL);
	if (contextPtr != NULL) {
	    contextPtr->callPtr->flags |= DESTRUCTOR;
	    contextPtr->skip = 0;
	    TclNRAddCallback(interp, AfterNRDestructor, contextPtr,
		    NULL, NULL, NULL);
	    TclPushTailcallPoint(interp);
	    return TclOOInvokeContext(contextPtr, interp, 0, NULL);
	}
    }
    if (oPtr->command) {
	Tcl_DeleteCommandFromToken(interp, oPtr->command);
    }
    return TCL_OK;

    Tcl_Obj *const *objv)	/* The actual arguments. */
{
    CallContext *contextPtr = (CallContext *) context;
    Object *oPtr = contextPtr->oPtr;
    const char **methodNames;
    int numMethodNames, i, skip = Tcl_ObjectContextSkippedArgs(context);

    /*
     * If 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, "method ?arg ...?");
	return TCL_ERROR;
    }

    /*
     * Get the list of methods that we want to know about.
     */

/*
 * Extra flags used for call chain management.
 */

#define DEFINITE_PROTECTED 0x100000
#define DEFINITE_PUBLIC    0x200000
#define KNOWN_STATE	   (DEFINITE_PROTECTED | DEFINITE_PUBLIC)
#define SPECIAL		   (CONSTRUCTOR | DESTRUCTOR | FORCE_UNKNOWN)

/*
 * Function declarations for things defined in this file.
 */

static void		AddClassFiltersToCallContext(Object *const oPtr,
			    Class *clsPtr, struct ChainBuilder *const cbPtr,

    callPtr = ckalloc(sizeof(CallChain));
    InitCallChain(callPtr, oPtr, flags);

    cb.callChainPtr = callPtr;
    cb.filterLength = 0;
    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).
     */

#ifdef HAVE_CONFIG_H
#include "config.h"
#endif
#include "tclInt.h"
#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.
 */

static inline void	BumpGlobalEpoch(Tcl_Interp *interp, Class *classPtr);
static Tcl_Command	FindCommand(Tcl_Interp *interp, Tcl_Obj *stringObj,
			    Tcl_Namespace *const namespacePtr);
static inline Class *	GetClassInOuterContext(Tcl_Interp *interp,
			    Tcl_Obj *className, const char *errMsg);
static inline int	InitDefineContext(Tcl_Interp *interp,
			    Tcl_Namespace *namespacePtr, Object *oPtr,
			    int objc, Tcl_Obj *const objv[]);
static inline void	RecomputeClassCacheFlag(Object *oPtr);
static int		RenameDeleteMethod(Tcl_Interp *interp, Object *oPtr,
			    int useClass, Tcl_Obj *const fromPtr,
			    Tcl_Obj *const toPtr);
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}}
};

/*
 * ----------------------------------------------------------------------
 *
 * BumpGlobalEpoch --
 *	Utility that ensures that call chains that are invalid will get thrown
 *	away at an appropriate time. Note that exactly which epoch gets

    }
    return TCL_OK;
}

/*
 * ----------------------------------------------------------------------
 *





































 * TclOODefineForwardObjCmd --
 *	Implementation of the "forward" subcommand of the "oo::define" and
 *	"oo::objdefine" commands.
 *
 * ----------------------------------------------------------------------
 */

    }
    return TCL_OK;
}

/*
 * ----------------------------------------------------------------------
 *










































































































 * TclOODefineUnexportObjCmd --
 *	Implementation of the "unexport" subcommand of the "oo::define" and
 *	"oo::objdefine" commands.
 *
 * ----------------------------------------------------------------------
 */

    }
    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 (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;
    }

    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);
	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(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 = (Class **) ckalloc(sizeof(Class *) * superc);

    /*
     * Parse the arguments to get the class to use as superclasses.
     */

    for (i=0 ; i<superc ; i++) {
	superclasses[i] = GetClassInOuterContext(interp, superv[i],
		"only a class can be a superclass");
	if (superclasses[i] == NULL) {
	    goto failedAfterAlloc;
	}
	for (j=0 ; j<i ; j++) {
	    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, superclasses[i])) {
	    Tcl_AppendResult(interp,
		    "attempt to form circular dependency graph", NULL);
	    Tcl_SetErrorCode(interp, "TCL", "OO", "CIRCULARITY", NULL);
	failedAfterAlloc:
	    ckfree((char *) superclasses);
	    return TCL_ERROR;
	}
    }

    /*
     * Install the list of superclasses into the class. Note that this also
     * involves splicing the class out of the superclasses' subclass list that
     * it used to be a member of and splicing it into the new superclasses'
     * subclass list.
     */

    if (oPtr->classPtr->superclasses.num != 0) {
	FOREACH(superPtr, oPtr->classPtr->superclasses) {
	    TclOORemoveFromSubclasses(oPtr->classPtr, superPtr);
	}
	ckfree((char *) oPtr->classPtr->superclasses.list);
    }
    oPtr->classPtr->superclasses.list = superclasses;
    oPtr->classPtr->superclasses.num = superc;
    FOREACH(superPtr, oPtr->classPtr->superclasses) {
	TclOOAddToSubclasses(oPtr->classPtr, superPtr);
    }
    BumpGlobalEpoch(interp, oPtr->classPtr);

    return TCL_OK;
}

/*
 * ----------------------------------------------------------------------
 *
 * ClassVarsGet, ClassVarsSet --
 *	Implementation of the "variable" slot accessors of the "oo::define"
 *	command.
 *
 * ----------------------------------------------------------------------
 */

static int
ClassVarsGet(
    ClientData clientData,
    Tcl_Interp *interp,
    Tcl_ObjectContext context,
    int objc,
    Tcl_Obj *const *objv)
{
    Object *oPtr = (Object *) TclOOGetDefineCmdContext(interp);
    Tcl_Obj *resultObj, *variableObj;
    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(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=0 ; i<varc ; i++) {
	const char *varName = Tcl_GetString(varv[i]);

	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;
	}
    }

    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 {
	    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.
 *
 * ----------------------------------------------------------------------
 */

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 (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;
}

/*
 * ----------------------------------------------------------------------
 *
 * ObjectVarsGet, ObjectVarsSet --
 *	Implementation of the "variable" slot accessors of the "oo::objdefine"
 *	command.
 *
 * ----------------------------------------------------------------------
 */

static int
ObjVarsGet(
    ClientData clientData,
    Tcl_Interp *interp,
    Tcl_ObjectContext context,
    int objc,
    Tcl_Obj *const *objv)
{
    Object *oPtr = (Object *) TclOOGetDefineCmdContext(interp);
    Tcl_Obj *resultObj, *variableObj;
    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(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=0 ; i<varc ; i++) {
	const char *varName = Tcl_GetString(varv[i]);

	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;
	}
    }
    for (i=0 ; i<varc ; i++) {
	Tcl_IncrRefCount(varv[i]);
    }

    FOREACH(variableObj, oPtr->variables) {
	Tcl_DecrRefCount(variableObj);
    }
    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);
	}
    }
    if (varc > 0) {
	memcpy(oPtr->variables.list, varv, sizeof(Tcl_Obj *)*varc);
    }
    oPtr->variables.num = varc;
    return TCL_OK;
}

/*
 * Local Variables:
 * mode: c
 * c-basic-offset: 4
 * fill-column: 78
 * End:
 */

				 * instance of the class, and has had nothing
				 * added that changes the dispatch chain (i.e.
				 * no methods, mixins, or filters. */
#define ROOT_CLASS 0x8000	/* Flag to say that this object is the root
				 * 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
 * object, through which it is manipulated.
 */

typedef struct Class {

    Tcl_Obj *unknownMethodNameObj;
				/* Shared object containing the name of the
				 * unknown method handler method. */
    Tcl_Obj *constructorName;	/* Shared object containing the "name" of a
				 * constructor. */
    Tcl_Obj *destructorName;	/* Shared object containing the "name" of a
				 * destructor. */
    Tcl_Obj *clonedName;	/* Shared object containing the name of a
				 * "<cloned>" pseudo-constructor. */
} Foundation;

/*
 * A call context structure is built when a method is called. They contain the
 * chain of method implementations that are to be invoked by a particular
 * call, and the process of calling walks the chain, with the [next] command
 * proceeding to the next entry in the chain.

			    Tcl_Obj *const *objv);
MODULE_SCOPE int	TclOODefineDestructorObjCmd(ClientData clientData,
			    Tcl_Interp *interp, int objc,
			    Tcl_Obj *const *objv);
MODULE_SCOPE int	TclOODefineExportObjCmd(ClientData clientData,
			    Tcl_Interp *interp, int objc,
			    Tcl_Obj *const *objv);



MODULE_SCOPE int	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	TclOODefineRenameMethodObjCmd(ClientData clientData,
			    Tcl_Interp *interp, int objc,
			    Tcl_Obj *const *objv);



MODULE_SCOPE int	TclOODefineUnexportObjCmd(ClientData clientData,
			    Tcl_Interp *interp, int objc,
			    Tcl_Obj *const *objv);



MODULE_SCOPE int	TclOODefineClassObjCmd(ClientData clientData,
			    Tcl_Interp *interp, int objc,
			    Tcl_Obj *const *objv);
MODULE_SCOPE int	TclOODefineSelfObjCmd(ClientData clientData,
			    Tcl_Interp *interp, int objc,
			    Tcl_Obj *const *objv);
MODULE_SCOPE int	TclOOUnknownDefinition(ClientData clientData,

MODULE_SCOPE void	TclOOAddToMixinSubs(Class *subPtr, Class *mixinPtr);
MODULE_SCOPE void	TclOOAddToSubclasses(Class *subPtr, Class *superPtr);
MODULE_SCOPE int	TclNRNewObjectInstance(Tcl_Interp *interp,
			    Tcl_Class cls, const char *nameStr,
			    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);
MODULE_SCOPE void	TclOODelMethodRef(Method *method);
MODULE_SCOPE CallContext *TclOOGetCallContext(Object *oPtr,
			    Tcl_Obj *methodNameObj, int flags,
			    Tcl_Obj *cacheInThisObj);

#undef Tcl_NewStringObj
#undef Tcl_DumpActiveMemory
#undef Tcl_ValidateAllMemory
#undef Tcl_FindHashEntry
#undef Tcl_CreateHashEntry
#undef Tcl_Panic
#undef Tcl_FindExecutable



#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;

static int
TclWinGetPlatformId()
{
    /* Don't bother to determine the real platform on cygwin,
     * because VER_PLATFORM_WIN32_NT is the only supported platform */
    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;
    int len;
    Tcl_DString *dsPtr;
{
    if (!winTCharEncoding) {
	winTCharEncoding = Tcl_GetEncoding(0, "unicode");
    }
    return Tcl_UtfToExternalDString(winTCharEncoding,
	    string, len, dsPtr);
}

static char *
Tcl_WinTCharToUtf(
    CONST char *string,
    int len,
    Tcl_DString *dsPtr)
{
    if (!winTCharEncoding) {
	winTCharEncoding = Tcl_GetEncoding(0, "unicode");
    }
    return Tcl_ExternalToUtfDString(winTCharEncoding,
	    string, len, dsPtr);
}

#define Tcl_MacOSXOpenBundleResources (int (*) _ANSI_ARGS_(( \
		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

/*
 * WARNING: The contents of this file is automatically generated by the
 * tools/genStubs.tcl script. Any modifications to the function declarations
 * below should be made in the generic/tcl.decls script.
 */

    TclSetSlaveCancelFlags, /* 250 */
};

static const TclIntPlatStubs tclIntPlatStubs = {
    TCL_STUB_MAGIC,
    0,
#if !defined(__WIN32__) && !defined(MAC_OSX_TCL) /* UNIX */
    TclWinConvertError, /* 0 */
    TclWinConvertWSAError, /* 1 */
    TclpCreateCommandChannel, /* 2 */
    TclpCreatePipe, /* 3 */
    TclWinGetTclInstance, /* 4 */
    0, /* 5 */
    TclWinNToHS, /* 6 */
    TclWinSetSockOpt, /* 7 */
    TclUnixWaitForFile, /* 8 */
    TclWinGetPlatformId, /* 9 */
    TclpReaddir, /* 10 */
    TclpLocaltime_unix, /* 11 */
    TclpGmtime_unix, /* 12 */
    TclpInetNtoa, /* 13 */
    TclUnixCopyFile, /* 14 */
    TclMacOSXGetFileAttribute, /* 15 */
    0, /* 16 */
    0, /* 17 */
    TclMacOSXMatchType, /* 18 */
    TclMacOSXNotifierAddRunLoopMode, /* 19 */
    TclWinAddProcess, /* 20 */
    0, /* 21 */
    TclpCreateTempFile, /* 22 */
    TclpGetTZName, /* 23 */
    TclWinNoBackslash, /* 24 */
    0, /* 25 */
    TclWinSetInterfaces, /* 26 */
    TclWinFlushDirtyChannels, /* 27 */
    TclWinResetInterfaces, /* 28 */
    TclWinCPUID, /* 29 */
    TclGetAndDetachPids, /* 30 */
    TclpCloseFile, /* 31 */
#endif /* UNIX */
#ifdef __WIN32__ /* WIN */
    TclWinConvertError, /* 0 */
    TclWinConvertWSAError, /* 1 */
    TclWinGetServByName, /* 2 */
    TclWinGetSockOpt, /* 3 */
    TclWinGetTclInstance, /* 4 */

    0, /* 25 */
    TclWinSetInterfaces, /* 26 */
    TclWinFlushDirtyChannels, /* 27 */
    TclWinResetInterfaces, /* 28 */
    TclWinCPUID, /* 29 */
#endif /* WIN */
#ifdef MAC_OSX_TCL /* MACOSX */
    TclWinConvertError, /* 0 */
    TclWinConvertWSAError, /* 1 */
    TclpCreateCommandChannel, /* 2 */
    TclpCreatePipe, /* 3 */
    TclWinGetTclInstance, /* 4 */
    0, /* 5 */
    TclWinNToHS, /* 6 */
    TclWinSetSockOpt, /* 7 */
    TclUnixWaitForFile, /* 8 */
    TclWinGetPlatformId, /* 9 */
    TclpReaddir, /* 10 */
    TclpLocaltime_unix, /* 11 */
    TclpGmtime_unix, /* 12 */
    TclpInetNtoa, /* 13 */
    TclUnixCopyFile, /* 14 */
    TclMacOSXGetFileAttribute, /* 15 */
    TclMacOSXSetFileAttribute, /* 16 */
    TclMacOSXCopyFileAttributes, /* 17 */
    TclMacOSXMatchType, /* 18 */
    TclMacOSXNotifierAddRunLoopMode, /* 19 */
    TclWinAddProcess, /* 20 */
    0, /* 21 */
    TclpCreateTempFile, /* 22 */
    TclpGetTZName, /* 23 */
    TclWinNoBackslash, /* 24 */
    0, /* 25 */
    TclWinSetInterfaces, /* 26 */
    TclWinFlushDirtyChannels, /* 27 */
    TclWinResetInterfaces, /* 28 */
    TclWinCPUID, /* 29 */
    TclGetAndDetachPids, /* 30 */
    TclpCloseFile, /* 31 */
#endif /* MACOSX */
};

static const TclPlatStubs tclPlatStubs = {
    TCL_STUB_MAGIC,
    0,
#if !defined(__WIN32__) && !defined(MAC_OSX_TCL) /* UNIX */

\"oo::define oo::object method missingArgs\""
test oo-1.4 {basic test of OO functionality} -body {
    oo::object create {}
} -returnCodes 1 -result {object name must not be empty}
test oo-1.5 {basic test of OO functionality} -body {
    oo::object doesnotexist
} -returnCodes 1 -result {unknown method "doesnotexist": must be create, destroy or new}
test oo-1.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 {
    oo::objdefine aninstance unexport destroy
    aninstance doesnotexist
} -cleanup {
    rename aninstance {}

	variable a b c
    }
    oo::copy Foo Bar
    info class variable Bar
} -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
} -returnCodes 1 -result "wrong \# args: should be \"info object subcommand ?arg ...?\""
test oo-16.2 {OO: object introspection} -body {
    info object class NOTANOBJECT
} -returnCodes 1 -result {NOTANOBJECT does not refer to an object}

} -result {a b c}
test oo-16.11 {OO: object introspection} -setup {
    oo::class create foo
    foo create bar
} -body {
    oo::define foo method spong {} {...}
    oo::objdefine bar method boo {a {b c} args} {the body}
    list [lsort [info object methods bar -all]] [lsort [info object methods bar -all -private]]
} -cleanup {
    foo destroy
} -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 {
    rename foo {}
} -body {
    oo::objdefine foo unexport {*}[info object methods foo -all]
    info object methods foo -all

    oo::define foo {
	method bar {a {b c} args} {the body}
	self {
	    method bad {} {...}
	}
    }
    oo::define subfoo method boo {a {b c} args} {the body}
    list [lsort [info class methods subfoo -all]] \
	[lsort [info class methods subfoo -all -private]]
} -cleanup {
    foo destroy
} -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 {
    rename foo {}
} -body {
    oo::define foo unexport {*}[info class methods foo -all]
    info class methods foo -all

	method level {} {
	    expr {[next] - [info frame]}
	}
    }
    list [i level] [i frames] [dict get [c frame] object]
} -cleanup {
    c destroy
} -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 {
    oo::define c method test {{x 1}} {
	if {$x} {my test 0}
	lsort {q w e r t y u i o p}; # Overwrite the Tcl stack
	info frame 0

    cls create obj
    oo::objdefine obj {
	method dummy2 {} {}
	method unknown args {next {*}$args}
    }
    obj foo bar
} -result {unknown method "foo": must be destroy, dummy, dummy2 or unknown}
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 {
    oo::class create cls {
	method ab {} {return ok}
    }
    set result {}

	method get {} {return $x}
    }
    list [foo exists] [foo set 7] [foo exists] [foo get] [foo unset] \
	[foo exists] [catch {foo get} msg] $msg
} -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...
test oo-28.1 {scripted extensions to oo::define} -setup {
    interp create foo
    foo eval {oo::class create cls {export eval}}
} -cleanup {

	    rename coro {}
	}
    }
    list [leaktest {[cls new] destroy}] [info class instances cls]
} -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

# Local Variables:
# mode: tcl
# End:

    list [catch {string is alpha -failin str} msg] $msg
} {1 {wrong # args: should be "string is alpha ?-strict? ?-failindex var? str"}}
test string-6.4 {string is, too many args} {
    list [catch {string is alpha -failin var -strict str more} msg] $msg
} {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, 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, 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
test string-6.8 {string is, error in var} {
    list [string is alpha -failindex var abc5def] $var
} {0 3}
test string-6.9 {string is, var shouldn't get set} {

test string-6.90 {string is integer, 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 int -strict $num]
    }
    return $result
} {1 1 0 0 0 1 0 0}
test string-6.91 {string is double, bad doubles} {
    set result ""
    set numbers [list 1.0 +1.0 ++1.0 +-1.0 -+1.0 -1.0 --1.0 "- +1.0"]
    foreach num $numbers {
	lappend result [string is double -strict $num]
    }
    return $result
} {1 1 0 0 0 1 0 0}
test string-6.92 {string is integer, 32-bit overflow} {
    # Bug 718878
    set x 0x100000000
    list [string is integer -failindex var $x] $var
} {0 -1}
test string-6.93 {string is integer, 32-bit overflow} {

test string-6.107 {string is integer, 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 wideinteger -strict $num]
    }
    return $result
} {1 1 0 0 0 1 0 0}
test string-6.108 {string is double, Bug 1382287} {
    set x 2turtledoves
    string is double $x
    string is double $x
} 0
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 {}}

test string-7.1 {string last, too few args} {
    list [catch {string last a} msg] $msg
} {1 {wrong # args: should be "string last needleString haystackString ?startIndex?"}}
test string-7.2 {string last, bad args} {

tclMacOSXFCmd.o: $(MAC_OSX_DIR)/tclMacOSXFCmd.c
	$(CC) -c $(CC_SWITCHES) $(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@

$(DTRACE_HDR): $(DTRACE_SRC)
	$(DTRACE) -h $(DTRACE_SWITCHES) -o $@ -s $(DTRACE_SRC)

	    CC_SEARCH_FLAGS=""
	    LD_SEARCH_FLAGS=""
	    ;;
	CYGWIN_*)
	    SHLIB_CFLAGS=""
	    SHLIB_LD='${CC} -shared'
	    SHLIB_SUFFIX=".dll"
	    DL_OBJS="tclLoadDl.o tclWinError.o"
	    DL_LIBS="-ldl"
	    CC_SEARCH_FLAGS=""
	    LD_SEARCH_FLAGS=""
	    TCL_NEEDS_EXP_FILE=1
	    TCL_EXPORT_FILE_SUFFIX='${VERSION}\$\{DBGX\}.dll.a'
	    TCL_SHLIB_LD_EXTRAS='-Wl,--out-implib,[email protected]'
	    ;;

	    CC_SEARCH_FLAGS=""
	    LD_SEARCH_FLAGS=""
	    ;;
	CYGWIN_*)
	    SHLIB_CFLAGS=""
	    SHLIB_LD='${CC} -shared'
	    SHLIB_SUFFIX=".dll"
	    DL_OBJS="tclLoadDl.o tclWinError.o"
	    DL_LIBS="-ldl"
	    CC_SEARCH_FLAGS=""
	    LD_SEARCH_FLAGS=""
	    TCL_NEEDS_EXP_FILE=1
	    TCL_EXPORT_FILE_SUFFIX='${VERSION}\$\{DBGX\}.dll.a'
	    TCL_SHLIB_LD_EXTRAS='-Wl,--out-implib,$[@].a'
	    ;;

 *
 * See the file "license.terms" for information on usage and redistribution of
 * this file, and for a DISCLAIMER OF ALL WARRANTIES.
 */

#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 const unsigned char errorTable[] = {
    0,
    EINVAL,	/* ERROR_INVALID_FUNCTION	1 */
    ENOENT,	/* ERROR_FILE_NOT_FOUND		2 */
    ENOENT,	/* ERROR_PATH_NOT_FOUND		3 */
    EMFILE,	/* ERROR_TOO_MANY_OPEN_FILES	4 */
    EACCES,	/* ERROR_ACCESS_DENIED		5 */
    EBADF,	/* ERROR_INVALID_HANDLE		6 */

    EINVAL,	/* 260 */
    EINVAL,	/* 261 */
    EINVAL,	/* 262 */
    EINVAL,	/* 263 */
    EINVAL,	/* 264 */
    EINVAL,	/* 265 */
    EINVAL,	/* 266 */
    ENOTDIR	/* ERROR_DIRECTORY		267 */
};



/*
 * The following table contains the mapping from WinSock errors to
 * errno errors.
 */

static const unsigned char wsaErrorTable[] = {
    EAGAIN,		/* WSAEWOULDBLOCK */
    EINPROGRESS,	/* WSAEINPROGRESS */
    EALREADY,		/* WSAEALREADY */
    ENOTSOCK,		/* WSAENOTSOCK */
    EDESTADDRREQ,	/* WSAEDESTADDRREQ */
    EMSGSIZE,		/* WSAEMSGSIZE */
    EPROTOTYPE,		/* WSAEPROTOTYPE */
    ENOPROTOOPT,	/* WSAENOPROTOOPT */

    EHOSTDOWN,		/* WSAEHOSTDOWN */
    EHOSTUNREACH,	/* WSAEHOSTUNREACH */
    ENOTEMPTY,		/* WSAENOTEMPTY */
    EAGAIN,		/* WSAEPROCLIM */
    EUSERS,		/* WSAEUSERS */
    EDQUOT,		/* WSAEDQUOT */
    ESTALE,		/* WSAESTALE */
    EREMOTE		/* WSAEREMOTE */
};

/*
 *----------------------------------------------------------------------
 *
 * TclWinConvertError --
 *
 *	This routine converts a Win32 error into an errno value.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	Sets the errno global variable.
 *
 *----------------------------------------------------------------------
 */

void
TclWinConvertError(
    DWORD errCode)		/* Win32 error code. */
{
    if (errCode >= sizeof(errorTable)/sizeof(errorTable[0])) {
	Tcl_SetErrno(EINVAL);
    } else {
	Tcl_SetErrno(errorTable[errCode]);
    }
}

/*

 *	Sets the errno global variable.
 *
 *----------------------------------------------------------------------
 */

void
TclWinConvertWSAError(
    DWORD errCode)		/* Win32 error code. */
{
    errCode -= WSAEWOULDBLOCK;
    if (errCode >= sizeof(wsaErrorTable)/sizeof(wsaErrorTable[0])) {
	Tcl_SetErrno(EINVAL);
    } else {
	Tcl_SetErrno(wsaErrorTable[errCode]);
    }
}

/*
 * Local Variables:
 * mode: c
 * c-basic-offset: 4
 * fill-column: 78
 * tab-width: 8
 * End:
 */

#endif
#ifndef EOPNOTSUPP
#   define EOPNOTSUPP	130	/* Operation not supported on socket */
#endif
#ifndef EOTHER
#   define EOTHER	131	/* Other error */
#endif

#ifndef EOVERFLOW
#   define EOVERFLOW	132	/* File too big */
#endif
#ifndef EOWNERDEAD
#   define EOWNERDEAD	133	/* Owner dead */
#endif
#ifndef EPROTO
#   define EPROTO	134	/* Protocol error */
#endif
#ifndef EPROTONOSUPPORT

#   define ETXTBSY	139	/* Text file or pseudo-device busy */
#endif
#ifndef EWOULDBLOCK
#   define EWOULDBLOCK	140	/* Operation would block */
#endif


/* 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
 * by Tcl_WaitPid() and generic/tclPosixStr.c
 */

#ifndef SIGTRAP

    timeout = (infoPtr->flags & SERIAL_ASYNC) ? 0 : INFINITE;
    if (WaitForSingleObject(infoPtr->evWritable, timeout) == WAIT_TIMEOUT) {
	/*
	 * The writer thread is blocked waiting for a write to complete and
	 * the channel is in non-blocking mode.
	 */

	errno = EAGAIN;
	goto error1;
    }

    /*
     * Check for a background error on the last write.
     */

		/*
		 * Attempt to connect to the remote socket.
		 */

		if (connect(sock, addrPtr->ai_addr, addrPtr->ai_addrlen)
		    == SOCKET_ERROR) {
		    TclWinConvertWSAError((DWORD) WSAGetLastError());
		    if (Tcl_GetErrno() != EAGAIN) {
			goto looperror;
		    }

		    /*
		     * The connection is progressing in the background.
		     */

	if (infoPtr->lastError) {
	    *errorCodePtr = infoPtr->lastError;
	    result = 0;
	    break;
	} else if (infoPtr->readyEvents & events) {
	    break;
	} else if (infoPtr->flags & SOCKET_ASYNC) {
	    *errorCodePtr = EAGAIN;
	    result = 0;
	    break;
	}

	/*
	 * Wait until something happens.
	 */

	 * send fails with WSAEWOULDBLOCK.
	 */

	error = WSAGetLastError();
	if (error == WSAEWOULDBLOCK) {
	    infoPtr->readyEvents &= ~(FD_WRITE);
	    if (infoPtr->flags & SOCKET_ASYNC) {
		*errorCodePtr = EAGAIN;
		bytesWritten = -1;
		break;
	    }
	} else {
	    TclWinConvertWSAError(error);
	    *errorCodePtr = Tcl_GetErrno();
	    bytesWritten = -1;