merge core-8-branch

an error when they include tclPort.h.

.github/ISSUE_TEMPLATE.md

@@ -0,0 +1,3 @@
+Important Note
+==========
+Please do not file issues with Tcl on Github. They are unlikely to be noticed in a timely fashion. Tcl issues are hosted in the [tcl fossil repository on core.tcl.tk](https://core.tcl.tk/tcl/tktnew); please post them there.

.github/PULL_REQUEST_TEMPLATE.md

@@ -0,0 +1,3 @@
+Important Note
+==========
+Please do not file pull requests with Tcl on Github. They are unlikely to be noticed in a timely fashion. Tcl issues (including patches) are hosted in the [tcl fossil repository on core.tcl.tk](https://core.tcl.tk/tcl/tktnew); please post them there.

doc/Method.3

@@ -9,18 +9,18 @@
 .BS
 '\" Note:  do not modify the .SH NAME line immediately below!
 .SH NAME
-Tcl_ClassSetConstructor, Tcl_ClassSetDestructor, Tcl_MethodDeclarerClass, Tcl_MethodDeclarerObject, Tcl_MethodIsPublic, Tcl_MethodIsType, Tcl_MethodName, Tcl_NewInstanceMethod, Tcl_NewMethod, Tcl_ObjectContextInvokeNext, Tcl_ObjectContextIsFiltering, Tcl_ObjectContextMethod, Tcl_ObjectContextObject, Tcl_ObjectContextSkippedArgs \- manipulate methods and method-call contexts
+Tcl_ClassSetConstructor, Tcl_ClassSetDestructor, Tcl_MethodDeclarerClass, Tcl_MethodDeclarerObject, Tcl_MethodIsPublic, Tcl_MethodIsPrivate, Tcl_MethodIsType, Tcl_MethodName, Tcl_NewInstanceMethod, Tcl_NewMethod, Tcl_ObjectContextInvokeNext, Tcl_ObjectContextIsFiltering, Tcl_ObjectContextMethod, Tcl_ObjectContextObject, Tcl_ObjectContextSkippedArgs \- manipulate methods and method-call contexts
 .SH SYNOPSIS
 .nf
 \fB#include <tclOO.h>\fR
 .sp
 Tcl_Method
-\fBTcl_NewMethod\fR(\fIinterp, class, nameObj, isPublic,
-              methodTypePtr, clientData\fR)
+\fBTcl_NewMethod\fR(\fIinterp, class, nameObj, flags, methodTypePtr,
+              clientData\fR)
 .sp
 Tcl_Method
-\fBTcl_NewInstanceMethod\fR(\fIinterp, object, nameObj, isPublic,
-                      methodTypePtr, clientData\fR)
+\fBTcl_NewInstanceMethod\fR(\fIinterp, object, nameObj, flags, methodTypePtr,
+                      clientData\fR)
 .sp
 \fBTcl_ClassSetConstructor\fR(\fIinterp, class, method\fR)
 .sp
@@ -35,8 +35,13 @@ Tcl_Object
 Tcl_Obj *
 \fBTcl_MethodName\fR(\fImethod\fR)
 .sp
+.VS TIP500
 int
 \fBTcl_MethodIsPublic\fR(\fImethod\fR)
+.VE TIP500
+.sp
+int
+\fBTcl_MethodIsPrivate\fR(\fImethod\fR)
 .sp
 int
 \fBTcl_MethodIsType\fR(\fImethod, methodTypePtr, clientDataPtr\fR)
@@ -66,10 +71,15 @@ The class to create the method in.
 .AP Tcl_Obj *nameObj in
 The name of the method to create. Should not be NULL unless creating
 constructors or destructors.
-.AP int isPublic in
-A flag saying what the visibility of the method is. The only supported public
-values of this flag are 0 for a non-exported method, and 1 for an exported
-method.
+.AP int flags in
+A flag saying (currently) what the visibility of the method is. The supported
+public values of this flag are \fBTCL_OO_METHOD_PUBLIC\fR (which is fixed at 1
+for backward compatibility) for an exported method,
+\fBTCL_OO_METHOD_UNEXPORTED\fR (which is fixed at 0 for backward
+compatibility) for a non-exported method,
+.VS TIP500
+and \fBTCL_OO_METHOD_PRIVATE\fR for a private method.
+.VE TIP500
 .AP Tcl_MethodType *methodTypePtr in
 A description of the type of the method to create, or the type of method to
 compare against.
@@ -105,8 +115,12 @@ Given a method, the entity that declared it can be found using
 attached to (or NULL if the method is not attached to any class) and
 \fBTcl_MethodDeclarerObject\fR which returns the object that the method is
 attached to (or NULL if the method is not attached to an object). The name of
-the method can be retrieved with \fBTcl_MethodName\fR and whether the method
-is exported is retrieved with \fBTcl_MethodIsPublic\fR. The type of the method
+the method can be retrieved with \fBTcl_MethodName\fR, whether the method
+is exported is retrieved with \fBTcl_MethodIsPublic\fR,
+.VS TIP500
+and whether the method is private is retrieved with \fBTcl_MethodIsPrivate\fR.
+.VE TIP500
+The type of the method
 can also be introspected upon to a limited degree; the function
 \fBTcl_MethodIsType\fR returns whether a method is of a particular type,
 assigning the per-method \fIclientData\fR to the variable pointed to by
@@ -117,8 +131,12 @@ Methods are created by \fBTcl_NewMethod\fR and \fBTcl_NewInstanceMethod\fR,
 which
 create a method attached to a class or an object respectively. In both cases,
 the \fInameObj\fR argument gives the name of the method to create, the
-\fIisPublic\fR argument states whether the method should be exported
-initially, the \fImethodTypePtr\fR argument describes the implementation of
+\fIflags\fR argument states whether the method should be exported
+initially
+.VS TIP500
+or be marked as a private method,
+.VE TIP500
+the \fImethodTypePtr\fR argument describes the implementation of
 the method (see the \fBMETHOD TYPES\fR section below) and the \fIclientData\fR
 argument gives some implementation-specific data that is passed on to the
 implementation of the method when it is called.

doc/NRE.3

@@ -1,6 +1,6 @@
 .\"
 .\" Copyright (c) 2008 by Kevin B. Kenny.
-.\" Copyright (c) 2018 by Nathan Coulter. 
+.\" Copyright (c) 2018 by Nathan Coulter.
 .\"
 '\" See the file "license.terms" for information on usage and redistribution
 '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES.

doc/Panic.3

@@ -7,7 +7,7 @@
 .BS
 '\"  Note:  do not modify the .SH NAME line immediately below!
 .SH NAME
-Tcl_Panic, Tcl_PanicVA, Tcl_SetPanicProc \- report fatal error and abort
+Tcl_Panic, Tcl_PanicVA, Tcl_SetPanicProc, Tcl_ConsolePanic \- report fatal error and abort
 .SH SYNOPSIS
 .nf
 \fB#include <tcl.h>\fR
@@ -21,6 +21,9 @@ void
 void
 \fBTcl_SetPanicProc\fR(\fIpanicProc\fR)
 .sp
+void
+\fBTcl_ConsolePanic\fR(\fIformat\fR, \fIarg\fR, \fIarg\fR, \fI...\fR)
+.sp
 .SH ARGUMENTS
 .AS Tcl_PanicProc *panicProc
 .AP "const char*" format in
@@ -54,6 +57,14 @@ message is sent to the debugger in stead. If the windows executable
 does not have a stderr channel (e.g. \fBwish.exe\fR), then a
 system dialog box is used to display the panic message.
 .PP
+If your application doesn't use \fBTcl_Main\fR or \fBTk_Main\fR
+and you want to implicitly use the stderr channel of your
+application's C runtime (in stead of the stderr channel of the
+C runtime used by Tcl), you can call \fBTcl_SetPanicProc\fR
+with \fBTcl_ConsolePanic\fR as its argument. On platforms which
+only have one C runtime (almost all platforms except Windows)
+\fBTcl_ConsolePanic\fR is equivalent to NULL.
+.PP
 \fBTcl_SetPanicProc\fR may be used to modify the behavior of
 \fBTcl_Panic\fR.  The \fIpanicProc\fR argument should match the
 type \fBTcl_PanicProc\fR:

doc/SaveResult.3

@@ -1,6 +1,7 @@
 '\"
 '\" Copyright (c) 1997 by Sun Microsystems, Inc.
 '\" Contributions from Don Porter, NIST, 2004. (not subject to US copyright)
+'\" Copyright (c) 2018 Nathan Coulter. 
 '\"
 '\" See the file "license.terms" for information on usage and redistribution
 '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES.
@@ -9,7 +10,9 @@
 .so man.macros
 .BS
 .SH NAME
-Tcl_SaveInterpState, Tcl_RestoreInterpState, Tcl_DiscardInterpState, Tcl_SaveResult, Tcl_RestoreResult, Tcl_DiscardResult \- save and restore an interpreter's state
+Tcl_SaveInterpState, Tcl_RestoreInterpState, Tcl_DiscardInterpState,
+Tcl_SaveResult, Tcl_RestoreResult, Tcl_DiscardResult \- Save and restore the
+state of an an interpreter.
 .SH SYNOPSIS
 .nf
 \fB#include <tcl.h>\fR
@@ -30,91 +33,53 @@ int
 .SH ARGUMENTS
 .AS Tcl_InterpState savedPtr
 .AP Tcl_Interp *interp in
-Interpreter for which state should be saved.
+The interpreter for the operation.
 .AP int status in
-Return code value to save as part of interpreter state.
+The return code for the state.
 .AP Tcl_InterpState state in
-Saved state token to be restored or discarded.
+A token for saved state.
 .AP Tcl_SavedResult *savedPtr in
-Pointer to location where interpreter result should be saved or restored.
+A pointer to storage for saved state.
 .BE
 .SH DESCRIPTION
 .PP
-These routines allows a C procedure to take a snapshot of the current
-state of an interpreter so that it can be restored after a call
-to \fBTcl_Eval\fR or some other routine that modifies the interpreter
-state.  There are two triplets of routines meant to work together.
+These routines save the state of an interpreter before a call to a routine such
+as \fBTcl_Eval\fR, and restore the state afterwards.
 .PP
-The first triplet stores the snapshot of interpreter state in
-an opaque token returned by \fBTcl_SaveInterpState\fR.  That token
-value may then be passed back to one of \fBTcl_RestoreInterpState\fR
-or \fBTcl_DiscardInterpState\fR, depending on whether the interp
-state is to be restored.  So long as one of the latter two routines
-is called, Tcl will take care of memory management.
+\fBTcl_SaveInterpState\fR saves the parts of \fIinterp\fR that comprise the
+result of a script, including the resulting value, the return code passed as
+\fIstatus\fR, and any options such as \fB\-errorinfo\fR and \fB\-errorcode\fR.
+It returns a token for the saved state.  The interpreter result is not reset
+and no interpreter state is changed.
 .PP
-The second triplet stores the snapshot of only the interpreter
-result (not its complete state) in memory allocated by the caller.
-These routines are passed a pointer to \fBTcl_SavedResult\fR
-that is used to store enough information to restore the interpreter result.
-\fBTcl_SavedResult\fR can be allocated on the stack of the calling
-procedure.  These routines do not save the state of any error
-information in the interpreter (e.g. the \fB\-errorcode\fR or
-\fB\-errorinfo\fR return options, when an error is in progress).
+\fBTcl_RestoreInterpState\fR restores the state indicated by \fIstate\fR and
+returns the \fIstatus\fR originally passed in the corresponding call to
+\fBTcl_SaveInterpState\fR.
 .PP
-Because the routines \fBTcl_SaveInterpState\fR,
-\fBTcl_RestoreInterpState\fR, and \fBTcl_DiscardInterpState\fR perform
-a superset of the functions provided by the other routines,
-any new code should only make use of the more powerful routines.
-The older, weaker routines \fBTcl_SaveResult\fR, \fBTcl_RestoreResult\fR,
-and \fBTcl_DiscardResult\fR continue to exist only for the sake
-of existing programs that may already be using them.
+If a saved state is not restored, \fBTcl_DiscardInterpState\fR must be called
+to release it.  A token used to discard or restore state must not be used
+again.
 .PP
-\fBTcl_SaveInterpState\fR takes a snapshot of those portions of
-interpreter state that make up the full result of script evaluation.
-This include the interpreter result, the return code (passed in
-as the \fIstatus\fR argument, and any return options, including
-\fB\-errorinfo\fR and \fB\-errorcode\fR when an error is in progress.
-This snapshot is returned as an opaque token of type \fBTcl_InterpState\fR.
-The call to \fBTcl_SaveInterpState\fR does not itself change the
-state of the interpreter.  Unlike \fBTcl_SaveResult\fR, it does
-not reset the interpreter.
+\fBTcl_SaveResult\fR, \fBTcl_RestoreResult\fR, and \fBTcl_DiscardResult\fR are
+deprecated.  Instead use \fBTcl_SaveInterpState\fR,
+\fBTcl_RestoreInterpState\fR, and \fBTcl_DiscardInterpState\fR, which are more
+capable.
 .PP
-\fBTcl_RestoreInterpState\fR accepts a \fBTcl_InterpState\fR token
-previously returned by \fBTcl_SaveInterpState\fR and restores the
-state of the interp to the state held in that snapshot.  The return
-value of \fBTcl_RestoreInterpState\fR is the status value originally
-passed to \fBTcl_SaveInterpState\fR when the snapshot token was
-created.
+\fBTcl_SaveResult\fR moves the result of \fIinterp\fR to the location
+\fIstatePtr\fR points to and returns the interpreter result to its initial
+state.  It does not save options such as \fB\-errorcode\fR or
+\fB\-errorinfo\fR.
 .PP
-\fBTcl_DiscardInterpState\fR is called to release a \fBTcl_InterpState\fR
-token previously returned by \fBTcl_SaveInterpState\fR when that
-snapshot is not to be restored to an interp.
-.PP
-The \fBTcl_InterpState\fR token returned by \fBTcl_SaveInterpState\fR
-must eventually be passed to either \fBTcl_RestoreInterpState\fR
-or \fBTcl_DiscardInterpState\fR to avoid a memory leak.  Once
-the \fBTcl_InterpState\fR token is passed to one of them, the
-token is no longer valid and should not be used anymore.
-.PP
-\fBTcl_SaveResult\fR moves the string and value results
-of \fIinterp\fR into the location specified by \fIstatePtr\fR.
-\fBTcl_SaveResult\fR clears the result for \fIinterp\fR and
-leaves the result in its normal empty initialized state.
-.PP
-\fBTcl_RestoreResult\fR moves the string and value results from
-\fIstatePtr\fR back into \fIinterp\fR.  Any result or error that was
-already in the interpreter will be cleared.  The \fIstatePtr\fR is left
-in an uninitialized state and cannot be used until another call to
+\fBTcl_RestoreResult\fR clears any existing result or error in \fIinterp\fR and
+moves the result from \fIstatePtr\fR back to \fIinterp\fR.  \fIstatePtr\fR is
+then in an undefined state and must not be used until passed again to
 \fBTcl_SaveResult\fR.
 .PP
-\fBTcl_DiscardResult\fR releases the saved interpreter state
-stored at \fBstatePtr\fR.  The state structure is left in an
-uninitialized state and cannot be used until another call to
+\fBTcl_DiscardResult\fR releases the state stored at \fBstatePtr\fR, which is
+then in an undefined state and must not be used until passed again to
 \fBTcl_SaveResult\fR.
 .PP
-Once \fBTcl_SaveResult\fR is called to save the interpreter
-result, either \fBTcl_RestoreResult\fR or
-\fBTcl_DiscardResult\fR must be called to properly clean up the
-memory associated with the saved state.
+If a saved result is not restored, \fBTcl_DiscardResult\fR must be called to
+release it.
 .SH KEYWORDS
 result, state, interp

doc/Utf.3

@@ -121,8 +121,8 @@ case-insensitive (1).
 
 .SH DESCRIPTION
 .PP
-These routines convert between UTF-8 strings and Tcl_UniChars.  A
-Tcl_UniChar is a Unicode character represented as an unsigned, fixed-size
+These routines convert between UTF-8 strings and Unicode characters.  An
+Unicode character represented as an unsigned, fixed-size
 quantity.  A UTF-8 character is a Unicode character represented as
 a varying-length sequence of up to \fBTCL_UTF_MAX\fR bytes.  A multibyte UTF-8
 sequence consists of a lead byte followed by some number of trail bytes.
@@ -130,9 +130,12 @@ sequence consists of a lead byte followed by some number of trail bytes.
 \fBTCL_UTF_MAX\fR is the maximum number of bytes that it takes to
 represent one Unicode character in the UTF-8 representation.
 .PP
-\fBTcl_UniCharToUtf\fR stores the Tcl_UniChar \fIch\fR as a UTF-8 string
+\fBTcl_UniCharToUtf\fR stores the character \fIch\fR as a UTF-8 string
 in starting at \fIbuf\fR.  The return value is the number of bytes stored
-in \fIbuf\fR.
+in \fIbuf\fR. If ch is an upper surrogate (range U+D800 - U+DBFF), then
+the return value will be 0 and nothing will be stored. If you still
+want to produce UTF-8 output for it (even though knowing it's an illegal
+code-point on its own), just call \fBTcl_UniCharToUtf\fR again using ch = -1.
 .PP
 \fBTcl_UtfToUniChar\fR reads one UTF-8 character starting at \fIsrc\fR
 and stores it as a Tcl_UniChar in \fI*chPtr\fR.  The return value is the
@@ -203,7 +206,7 @@ of \fIlength\fR bytes is long enough to be decoded by
 \fBTcl_UtfToUniChar\fR, or 0 otherwise.  This function does not guarantee
 that the UTF-8 string is properly formed.  This routine is used by
 procedures that are operating on a byte at a time and need to know if a
-full Tcl_UniChar has been seen.
+full Unicode character has been seen.
 .PP
 \fBTcl_NumUtfChars\fR corresponds to \fBstrlen\fR for UTF-8 strings.  It
 returns the number of Tcl_UniChars that are represented by the UTF-8 string
@@ -211,12 +214,12 @@ returns the number of Tcl_UniChars that are represented by the UTF-8 string
 length is negative, all bytes up to the first null byte are used.
 .PP
 \fBTcl_UtfFindFirst\fR corresponds to \fBstrchr\fR for UTF-8 strings.  It
-returns a pointer to the first occurrence of the Tcl_UniChar \fIch\fR
+returns a pointer to the first occurrence of the Unicode character \fIch\fR
 in the null-terminated UTF-8 string \fIsrc\fR.  The null terminator is
 considered part of the UTF-8 string.
 .PP
 \fBTcl_UtfFindLast\fR corresponds to \fBstrrchr\fR for UTF-8 strings.  It
-returns a pointer to the last occurrence of the Tcl_UniChar \fIch\fR
+returns a pointer to the last occurrence of the Unicode character \fIch\fR
 in the null-terminated UTF-8 string \fIsrc\fR.  The null terminator is
 considered part of the UTF-8 string.
 .PP

doc/abstract.n

@@ -0,0 +1,77 @@
+'\"
+'\" Copyright (c) 2018 Donal K. Fellows
+'\"
+'\" See the file "license.terms" for information on usage and redistribution
+'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES.
+'\"
+.TH abstract n 0.3 TclOO "TclOO Commands"
+.so man.macros
+.BS
+'\" Note:  do not modify the .SH NAME line immediately below!
+.SH NAME
+oo::abstract \- a class that does not allow direct instances of itself
+.SH SYNOPSIS
+.nf
+package require TclOO
+
+\fBoo::abstract\fI method \fR?\fIarg ...\fR?
+.fi
+.SH "CLASS HIERARCHY"
+.nf
+\fBoo::object\fR
+   \(-> \fBoo::class\fR
+       \(-> \fBoo::abstract\fR
+.fi
+.BE
+.SH DESCRIPTION
+Abstract classes are classes that can contain definitions, but which cannot be
+directly manufactured; they are intended to only ever be inherited from and
+instantiated indirectly. The characteristic methods of \fBoo::class\fR
+(\fBcreate\fR and \fBnew\fR) are not exported by an instance of
+\fBoo::abstract\fR.
+.PP
+Note that \fBoo::abstract\fR is not itself an instance of \fBoo::abstract\fR.
+.SS CONSTRUCTOR
+The \fBoo::abstract\fR class does not define an explicit constructor; this
+means that it is effectively the same as the constructor of the
+\fBoo::class\fR class.
+.SS DESTRUCTOR
+The \fBoo::abstract\fR class does not define an explicit destructor;
+destroying an instance of it is just like destroying an ordinary class (and
+will destroy all its subclasses).
+.SS "EXPORTED METHODS"
+The \fBoo::abstract\fR class defines no new exported methods.
+.SS "NON-EXPORTED METHODS"
+The \fBoo::abstract\fR class explicitly states that \fBcreate\fR,
+\fBcreateWithNamespace\fR, and \fBnew\fR are unexported.
+.SH EXAMPLES
+.PP
+This example defines a simple class hierarchy and creates a new instance of
+it. It then invokes a method of the object before destroying the hierarchy and
+showing that the destruction is transitive.
+.PP
+.CS
+\fBoo::abstract\fR create fruit {
+    method eat {} {
+        puts "yummy!"
+    }
+}
+oo::class create banana {
+    superclass fruit
+    method peel {} {
+        puts "skin now off"
+    }
+}
+set b [banana \fBnew\fR]
+$b peel              \fI\(-> prints 'skin now off'\fR
+$b eat               \fI\(-> prints 'yummy!'\fR
+set f [fruit new]    \fI\(-> error 'unknown method "new"...'\fR
+.CE
+.SH "SEE ALSO"
+oo::define(n), oo::object(n)
+.SH KEYWORDS
+abstract class, class, metaclass, object
+.\" Local variables:
+.\" mode: nroff
+.\" fill-column: 78
+.\" End:

doc/callback.n

@@ -0,0 +1,88 @@
+'\"
+'\" Copyright (c) 2018 Donal K. Fellows
+'\"
+'\" See the file "license.terms" for information on usage and redistribution
+'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES.
+'\"
+.TH callback n 0.3 TclOO "TclOO Commands"
+.so man.macros
+.BS
+'\" Note:  do not modify the .SH NAME line immediately below!
+.SH NAME
+callback, mymethod \- generate callbacks to methods
+.SH SYNOPSIS
+.nf
+package require TclOO
+
+\fBcallback\fR \fImethodName\fR ?\fIarg ...\fR?
+\fBmymethod\fR \fImethodName\fR ?\fIarg ...\fR?
+.fi
+.BE
+.SH DESCRIPTION
+The \fBcallback\fR command,
+'\" Based on notes in the tcllib docs, we know the provenance of mymethod
+also called \fBmymethod\fR for compatibility with the ooutil and snit packages
+of Tcllib,
+and which should only be used from within the context of a call to a method
+(i.e. inside a method, constructor or destructor body) is used to generate a
+script fragment that will invoke the method, \fImethodName\fR, on the current
+object (as reported by \fBself\fR) when executed. Any additional arguments
+provided will be provided as leading arguments to the callback. The resulting
+script fragment shall be a proper list.
+.PP
+Note that it is up to the caller to ensure that the current object is able to
+handle the call of \fImethodName\fR; this command does not check that.
+\fImethodName\fR may refer to any exported or unexported method, but may not
+refer to a private method as those can only be invoked directly from within
+methods. If there is no such method present at the point when the callback is
+invoked, the standard \fBunknown\fR method handler will be called.
+.SH EXAMPLE
+This is a simple echo server class. The \fBcallback\fR command is used in two
+places, to arrange for the incoming socket connections to be handled by the
+\fIAccept\fR method, and to arrange for the incoming bytes on those
+connections to be handled by the \fIReceive\fR method.
+.PP
+.CS
+oo::class create EchoServer {
+    variable server clients
+    constructor {port} {
+        set server [socket -server [\fBcallback\fR Accept] $port]
+        set clients {}
+    }
+    destructor {
+        chan close $server
+        foreach client [dict keys $clients] {
+            chan close $client
+        }
+    }
+
+    method Accept {channel clientAddress clientPort} {
+        dict set clients $channel [dict create \e
+                address $clientAddress port $clientPort]
+        chan event $channel readable [\fBcallback\fR Receive $channel]
+    }
+    method Receive {channel} {
+        if {[chan gets $channel line] >= 0} {
+            my echo $channel $line
+        } else {
+            chan close $channel
+            dict unset clients $channel
+        }
+    }
+
+    method echo {channel line} {
+        dict with clients $channel {
+            chan puts $channel \e
+                    [format {[%s:%d] %s} $address $port $line]
+        }
+    }
+}
+.CE
+.SH "SEE ALSO"
+chan(n), fileevent(n), my(n), self(n), socket(n), trace(n)
+.SH KEYWORDS
+callback, object
+.\" Local Variables:
+.\" mode: nroff
+.\" fill-column: 78
+.\" End:

doc/classvariable.n

@@ -0,0 +1,78 @@
+'\"
+'\" Copyright (c) 2011-2015 Andreas Kupries
+'\" Copyright (c) 2018 Donal K. Fellows
+'\"
+'\" See the file "license.terms" for information on usage and redistribution
+'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES.
+'\"
+.TH classvariable n 0.3 TclOO "TclOO Commands"
+.so man.macros
+.BS
+'\" Note:  do not modify the .SH NAME line immediately below!
+.SH NAME
+classvariable \- create link from local variable to variable in class
+.SH SYNOPSIS
+.nf
+package require TclOO
+
+\fBclassvariable\fR \fIvariableName\fR ?\fI...\fR?
+.fi
+.BE
+.SH DESCRIPTION
+The \fBclassvariable\fR command is available within methods. It takes a series
+of one or more variable names and makes them available in the method's scope;
+those variable names must not be qualified and must not refer to array
+elements. The originating scope for the variables is the namespace of the
+class that the method was defined by. In other words, the referenced variables
+are shared between all instances of that class.
+.PP
+Note: This command is equivalent to the command \fBtypevariable\fR provided by
+the snit package in tcllib for approximately the same purpose. If used in a
+method defined directly on a class instance (e.g., through the
+\fBoo::objdefine\fR \fBmethod\fR definition) this is very much like just
+using:
+.PP
+.CS
+namespace upvar [namespace current] $var $var
+.CE
+.PP
+for each variable listed to \fBclassvariable\fR.
+.SH EXAMPLE
+This class counts how many instances of it have been made.
+.PP
+.CS
+oo::class create Counted {
+    initialise {
+        variable count 0
+    }
+
+    variable number
+    constructor {} {
+        \fBclassvariable\fR count
+        set number [incr count]
+    }
+
+    method report {} {
+        \fBclassvariable\fR count
+        puts "This is instance $number of $count"
+    }
+}
+
+set a [Counted new]
+set b [Counted new]
+$a report
+        \fI\(-> This is instance 1 of 2\fR
+set c [Counted new]
+$b report
+        \fI\(-> This is instance 2 of 3\fR
+$c report
+        \fI\(-> This is instance 3 of 3\fR
+.CE
+.SH "SEE ALSO"
+global(n), namespace(n), oo::class(n), oo::define(n), upvar(n), variable(n)
+.SH KEYWORDS
+class, class variable, variable
+.\" Local Variables:
+.\" mode: nroff
+.\" fill-column: 78
+.\" End:

doc/clock.n

@@ -452,6 +452,19 @@ If this situation occurs, the first occurrence of the time is chosen.
 (For this reason, it is wise to have the input string contain the
 time zone when converting local times.  This caveat does not apply to
 UTC times.)
+.PP
+If the interpretation of the groups yields an impossible time because
+a field is out of range, enough of that field's unit will be added to
+or subtracted from the time to bring it in range. Thus, if attempting to
+scan or format day 0 of the month, one day will be subtracted from day
+1 of the month, yielding the last day of the previous month.
+.PP
+If the interpretation of the groups yields an impossible time because
+a Daylight Saving Time change skips over that time, or an ambiguous
+time because a Daylight Saving Time change skips back so that the clock
+observes the given time twice, and no time zone specifier (\fB%z\fR
+or \fB%Z\fR) is present in the format, the time is interpreted as
+if the clock had not changed.
 .SH "FORMAT GROUPS"
 .PP
 The following format groups are recognized by the \fBclock scan\fR and

doc/define.n

@@ -1,5 +1,5 @@
 '\"
-'\" Copyright (c) 2007 Donal K. Fellows
+'\" Copyright (c) 2007-2018 Donal K. Fellows
 '\"
 '\" See the file "license.terms" for information on usage and redistribution
 '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES.
@@ -39,6 +39,27 @@ used as the \fIdefScript\fR argument.
 The following commands are supported in the \fIdefScript\fR for
 \fBoo::define\fR, each of which may also be used in the \fIsubcommand\fR form:
 .TP
+\fBclassmethod\fI name\fR ?\fIargList bodyScrip\fR?
+.VS TIP478
+This creates a class method, or (if \fIargList\fR and \fIbodyScript\fR are
+omitted) promotes an existing method on the class object to be a class
+method. The \fIname\fR, \fIargList\fR and \fIbodyScript\fR arguments are as in
+the \fBmethod\fR definition, below.
+.RS
+.PP
+Class methods can be called on either the class itself or on the instances of
+that class. When they are called, the current object (see the \fBself\R and
+\fBmy\fR commands) is the class on which they are called or the class of the
+instance on which they are called, depending on whether they are called on the
+class or an instance of the class, respectively. If called on a subclass or
+instance of the subclass, the current object is the subclass.
+.PP
+In a private definition context, the methods as invoked on classes are
+\fInot\fR private, but the methods as invoked on instances of classes are
+private.
+.RE
+.VE TIP478
+.TP
 \fBconstructor\fI argList bodyScript\fR
 .
 This creates or updates the constructor for a class. The formal arguments to
@@ -82,17 +103,14 @@ 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?
 .
@@ -105,6 +123,22 @@ fully-qualified, the command will be searched for in each object's namespace,
 using the instances' namespace's path, or by looking in the global namespace.
 The method will be exported if \fIname\fR starts with a lower-case letter, and
 non-exported otherwise.
+.RS
+.PP
+.VS TIP500
+If in a private definition context (see the \fBprivate\fR definition command,
+below), this command creates private forwarded methods.
+.VE TIP500
+.RE
+.TP
+\fBinitialise\fI script\fR
+.TP
+\fBinitialize\fI script\fR
+.VS TIP478
+This evaluates \fIscript\fR in a context which supports local variables and
+where the current namespace is the instance namespace of the class object
+itself. This is useful for setting up, e.g., class-scoped variables.
+.VE TIP478
 .TP
 \fBmethod\fI name argList bodyScript\fR
 .
@@ -117,17 +151,40 @@ 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.
+.RS
+.PP
+.VS TIP500
+If in a private definition context (see the \fBprivate\fR definition command,
+below), this command creates private procedure-like methods.
+.VE TIP500
+.RE
 .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
+\fBprivate \fIcmd arg...\fR
+.TP
+\fBprivate \fIscript\fR
+.
+.VS TIP500
+This evaluates the \fIscript\fR (or the list of command and arguments given by
+\fIcmd\fR and \fIarg\fRs) in a context where the definitions made on the
+current class will be private definitions.
+.RS
+.PP
+The following class definition commands are affected by \fBprivate\fR:
+\fBforward\fR, \fBmethod\fR, \fBself\fR, and \fBvariable\fR. Nesting
+\fBprivate\fR inside \fBprivate\fR has no cumulative effect; the innermost
+definition context is just a private definition context. All other definition
+commands have no difference in behavior when used in a private definition
+context.
+.RE
+.VE TIP500
 .TP
 \fBrenamemethod\fI fromName toName\fR
 .
@@ -159,21 +216,23 @@ operates identically to
 If no arguments at all are used, this gives the name of the class currently
 being configured.
 .VE TIP470
+.VS TIP500
+If in a private definition context (see the \fBprivate\fR definition command,
+below), the definitions on the class object will also be made in a private
+definition context.
+.VE TIP500
 .RE
 .TP
 \fBsuperclass\fR ?\fI\-slotOperation\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?
 .
@@ -185,18 +244,31 @@ 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
+actually present in the namespace of 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
+.RS
+.PP
+.VS TIP500
+If in a private definition context (see the \fBprivate\fR definition command,
+below), this slot manipulates the list of private variable bindings for this
+class. In a private variable binding, the name of the variable within the
+instance object is different to the name given in the definition; the name
+used in the definition is the name that you use to access the variable within
+the methods of this class, and the name of the variable in the instance
+namespace has a unique prefix that makes accidental use from other classes
+extremely unlikely.
+.VE TIP500
+.RE
 .SS "CONFIGURING OBJECTS"
 .PP
 The following commands are supported in the \fIdefScript\fR for
@@ -223,18 +295,15 @@ 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?
 .
@@ -244,6 +313,13 @@ 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.
+.RS
+.PP
+.VS TIP500
+If in a private definition context (see the \fBprivate\fR definition command,
+below), this command creates private forwarded methods.
+.VE TIP500
+.RE
 .TP
 \fBmethod\fI name argList bodyScript\fR
 .
@@ -254,17 +330,38 @@ 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.
+.RS
+.PP
+.VS TIP500
+If in a private definition context (see the \fBprivate\fR definition command,
+below), this command creates private procedure-like methods.
+.VE TIP500
+.RE
 .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
+\fBprivate \fIcmd arg...\fR
+.TP
+\fBprivate \fIscript\fR
+.VS TIP500
+This evaluates the \fIscript\fR (or the list of command and arguments given by
+\fIcmd\fR and \fIarg\fRs) in a context where the definitions made on the
+current object will be private definitions.
+.RS
+.PP
+The following class definition commands are affected by \fBprivate\fR:
+\fBforward\fR, \fBmethod\fR, and \fBvariable\fR. Nesting \fBprivate\fR inside
+\fBprivate\fR has no cumulative effect; the innermost definition context is
+just a private definition context. All other definition commands have no
+difference in behavior when used in a private definition context.
+.RE
+.VE TIP500
 .TP
 \fBrenamemethod\fI fromName toName\fR
 .
@@ -275,7 +372,6 @@ 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
 \fBself \fR
-.
 .VS TIP470
 This gives the name of the object currently being configured.
 .VE TIP470
@@ -289,15 +385,42 @@ 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
+actually present in the namespace of 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.
+.RS
+.PP
+.VS TIP500
+If in a private definition context (see the \fBprivate\fR definition command,
+below), this slot manipulates the list of private variable bindings for this
+object.  In a private variable binding, the name of the variable within the
+instance object is different to the name given in the definition; the name
+used in the definition is the name that you use to access the variable within
+the methods of this instance object, and the name of the variable in the
+instance namespace has a unique prefix that makes accidental use from
+superclass methods extremely unlikely.
+.VE TIP500
+.RE
+.SH "PRIVATE METHODS"
+.VS TIP500
+When a class or instance has a private method, that private method can only be
+invoked from within methods of that class or instance. Other callers of the
+object's methods \fIcannot\fR invoke private methods, it is as if the private
+methods do not exist. However, a private method of a class \fIcan\fR be
+invoked from the class's methods when those methods are being used on another
+instance object; this means that a class can use them to coordinate behaviour
+between several instances of itself without interfering with how other
+classes (especially either subclasses or superclasses) interact. Private
+methods precede all mixed in classes in the method call order (as reported by
+\fBself call\fR).
+.VE TIP500
 .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
@@ -305,20 +428,17 @@ 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
@@ -331,17 +451,15 @@ which is forwarded to the default operation of the slot (thus, for the class
 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.
@@ -352,7 +470,6 @@ 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
@@ -409,6 +526,84 @@ oo::class create B {
 inst m1              \fI\(-> prints "red brick"\fR
 inst m2              \fI\(-> prints "blue brick"\fR
 .CE
+.PP
+.VS TIP478
+This example shows how to create and use class variables. It is a class that
+counts how many instances of itself have been made.
+.PP
+.CS
+oo::class create Counted
+\fBoo::define\fR Counted {
+    \fBinitialise\fR {
+        variable count 0
+    }
+
+    \fBvariable\fR number
+    \fBconstructor\fR {} {
+        classvariable count
+        set number [incr count]
+    }
+
+    \fBmethod\fR report {} {
+        classvariable count
+        puts "This is instance $number of $count"
+    }
+}
+
+set a [Counted new]
+set b [Counted new]
+$a report
+        \fI\(-> This is instance 1 of 2\fR
+set c [Counted new]
+$b report
+        \fI\(-> This is instance 2 of 3\fR
+$c report
+        \fI\(-> This is instance 3 of 3\fR
+.CE
+.PP
+This example demonstrates how to use class methods. (Note that the constructor
+for \fBoo::class\fR calls \fBoo::define\fR on the class.)
+.PP
+.CS
+oo::class create DBTable {
+    \fBclassmethod\fR find {description} {
+        puts "DB: locate row from [self] matching $description"
+        return [my new]
+    }
+    \fBclassmethod\fR insert {description} {
+        puts "DB: create row in [self] matching $description"
+        return [my new]
+    }
+    \fBmethod\fR update {description} {
+        puts "DB: update row [self] with $description"
+    }
+    \fBmethod\fR delete {} {
+        puts "DB: delete row [self]"
+        my destroy; # Just delete the object, not the DB row
+    }
+}
+
+oo::class create Users {
+    \fBsuperclass\fR DBTable
+}
+oo::class create Groups {
+    \fBsuperclass\fR DBTable
+}
+
+set u1 [Users insert "username=abc"]
+        \fI\(-> DB: create row from ::Users matching username=abc\fR
+set u2 [Users insert "username=def"]
+        \fI\(-> DB: create row from ::Users matching username=def\fR
+$u2 update "group=NULL"
+        \fI\(-> DB: update row ::oo::Obj124 with group=NULL\fR
+$u1 delete
+        \fI\(-> DB: delete row ::oo::Obj123\fR
+set g [Group find "groupname=webadmins"]
+        \fI\(-> DB: locate row ::Group with groupname=webadmins\fR
+$g update "emailaddress=admins"
+        \fI\(-> DB: update row ::oo::Obj125 with emailaddress=admins\fR
+.CE
+.VE TIP478
 .SH "SEE ALSO"
 next(n), oo::class(n), oo::object(n)
 .SH KEYWORDS

doc/info.n

@@ -35,10 +35,9 @@ Returns the body of procedure \fIprocname\fR.  \fIProcname\fR must be
 the name of a Tcl command procedure.
 .TP
 \fBinfo class\fI subcommand class\fR ?\fIarg ...\fR
-.VS 8.6
+.
 Returns information about the class, \fIclass\fR. The \fIsubcommand\fRs are
 described in \fBCLASS INTROSPECTION\fR below.
-.VE 8.6
 .TP
 \fBinfo cmdcount\fR
 .
@@ -78,11 +77,10 @@ command is not complete, the script can delay evaluating it until additional
 lines have been typed to complete the command.
 .TP
 \fBinfo coroutine\fR
-.VS 8.6
+.
 Returns the name of the currently executing \fBcoroutine\fR, or the empty
 string if either no coroutine is currently executing, or the current coroutine
 has been deleted (but has not yet returned or yielded since deletion).
-.VE 8.6
 .TP
 \fBinfo default \fIprocname arg varname\fR
 .
@@ -93,7 +91,7 @@ Otherwise it returns \fB1\fR and places the default value of \fIarg\fR
 into variable \fIvarname\fR.
 .TP
 \fBinfo errorstack \fR?\fIinterp\fR?
-.VS 8.6
+.
 Returns, in a form that is programmatically easy to parse, the function names
 and arguments at each level from the call stack of the last error in the given
 \fIinterp\fR, or in the current one if not specified.
@@ -118,7 +116,6 @@ options dictionary returned by 3-argument \fBcatch\fR; \fBinfo errorstack\fR
 is a convenient way of retrieving it for uncaught errors at top-level in an
 interactive \fBtclsh\fR.
 .RE
-.VE 8.6
 .TP
 \fBinfo exists \fIvarName\fR
 .
@@ -329,10 +326,9 @@ was invoked.  If Tcl was unable to identify the file, then an empty
 string is returned.
 .TP
 \fBinfo object\fI subcommand object\fR ?\fIarg ...\fR
-.VS 8.6
+.
 Returns information about the object, \fIobject\fR. The \fIsubcommand\fRs are
 described in \fBOBJECT INTROSPECTION\fR below.
-.VE 8.6
 .TP
 \fBinfo patchlevel\fR
 .
@@ -399,20 +395,22 @@ Note that a currently-visible variable may not yet
 if it has not
 been set (e.g. a variable declared but not set by \fBvariable\fR).
 .SS "CLASS INTROSPECTION"
-.VS 8.6
 .PP
 The following \fIsubcommand\fR values are supported by \fBinfo class\fR:
-.VE 8.6
 .TP
 \fBinfo class call\fI class method\fR
-.VS
+.
 Returns a description of the method implementations that are used to provide a
 stereotypical instance of \fIclass\fR's implementation of \fImethod\fR
 (stereotypical instances being objects instantiated by a class without having
 any object-specific definitions added). This consists of a list of lists of
 four elements, where each sublist consists of a word that describes the
 general type of method implementation (being one of \fBmethod\fR for an
-ordinary method, \fBfilter\fR for an applied filter, and \fBunknown\fR for a
+ordinary method, \fBfilter\fR for an applied filter,
+.VS TIP500
+\fBprivate\fR for a private method,
+.VE TIP500
+and \fBunknown\fR for a
 method that is invoked as part of unknown method handling), a word giving the
 name of the particular method invoked (which is always the same as
 \fImethod\fR for the \fBmethod\fR type, and
@@ -423,122 +421,149 @@ implementation (see \fBinfo class methodtype\fR).
 .RS
 .PP
 Note that there is no inspection of whether the method implementations
-actually use \fBnext\fR to transfer control along the call chain.
+actually use \fBnext\fR to transfer control along the call chain,
+.VS TIP500
+and the call chains that this command files do not actually contain private
+methods.
+.VE TIP500
 .RE
-.VE 8.6
 .TP
 \fBinfo class constructor\fI class\fR
-.VS 8.6
+.
 This subcommand returns a description of the definition of the constructor of
 class \fIclass\fR. The definition is described as a two element list; the first
 element is the list of arguments to the constructor in a form suitable for
 passing to another call to \fBproc\fR or a method definition, and the second
 element is the body of the constructor. If no constructor is present, this
 returns the empty list.
-.VE 8.6
 .TP
 \fBinfo class definition\fI class method\fR
-.VS 8.6
+.
 This subcommand returns a description of the definition of the method named
 \fImethod\fR of class \fIclass\fR. The definition is described as a two element
 list; the first element is the list of arguments to the method in a form
 suitable for passing to another call to \fBproc\fR or a method definition, and
 the second element is the body of the method.
-.VE 8.6
 .TP
 \fBinfo class destructor\fI class\fR
-.VS 8.6
+.
 This subcommand returns the body of the destructor of class \fIclass\fR. If no
 destructor is present, this returns the empty string.
-.VE 8.6
 .TP
 \fBinfo class filters\fI class\fR
-.VS 8.6
+.
 This subcommand returns the list of filter methods set on the class.
-.VE 8.6
 .TP
 \fBinfo class forward\fI class method\fR
-.VS 8.6
+.
 This subcommand returns the argument list for the method forwarding called
 \fImethod\fR that is set on the class called \fIclass\fR.
-.VE 8.6
 .TP
 \fBinfo class instances\fI class\fR ?\fIpattern\fR?
-.VS 8.6
+.
 This subcommand returns a list of instances of class \fIclass\fR. If the
 optional \fIpattern\fR argument is present, it constrains the list of returned
 instances to those that match it according to the rules of \fBstring match\fR.
-.VE 8.6
 .TP
 \fBinfo class methods\fI class\fR ?\fIoptions...\fR?
-.VS 8.6
+.
 This subcommand returns a list of all public (i.e. exported) methods of the
 class called \fIclass\fR. Any of the following \fIoption\fRs may be
 specified, controlling exactly which method names are returned:
 .RS
-.VE 8.6
 .TP
 \fB\-all\fR
-.VS 8.6
-If the \fB\-all\fR flag is given, the list of methods will include those
+.
+If the \fB\-all\fR flag is given,
+.VS TIP500
+and the \fB\-scope\fR flag is not given,
+.VE TIP500
+the list of methods will include those
 methods defined not just by the class, but also by the class's superclasses
 and mixins.
-.VE 8.6
 .TP
 \fB\-private\fR
-.VS 8.6
-If the \fB\-private\fR flag is given, the list of methods will also include
-the private (i.e. non-exported) methods of the class (and superclasses and
+.
+If the \fB\-private\fR flag is given,
+.VS TIP500
+and the \fB\-scope\fR flag is not given,
+.VE TIP500
+the list of methods will also include
+the non-exported methods of the class (and superclasses and
 mixins, if \fB\-all\fR is also given).
+.VS TIP500
+Note that this naming is an unfortunate clash with true private methods; this
+option name is retained for backward compatibility.
+.VE TIP500
+.TP
+\fB\-scope\fI scope\fR
+.VS TIP500
+Returns a list of all methods on \fIclass\fR that have the given visibility
+\fIscope\fR.  When this option is supplied, both the \fB\-all\fR and
+\fB\-private\fR options are ignored. The valid values for \fIscope\fR are:
+.RS
+.IP \fBpublic\fR 3
+Only methods with \fIpublic\fR scope (i.e., callable from anywhere by any instance
+of this class) are to be returned.
+.IP \fBunexported\fR 3
+Only methods with \fIunexported\fR scope (i.e., only callable via \fBmy\fR) are to
+be returned.
+.IP \fBprivate\fR 3
+Only methods with \fIprivate\fR scope (i.e., only callable from within this class's
+methods) are to be returned.
+.RE
+.VE TIP500
 .RE
-.VE 8.6
 .TP
 \fBinfo class methodtype\fI class method\fR
-.VS 8.6
+.
 This subcommand returns a description of the type of implementation used for
 the method named \fImethod\fR of class \fIclass\fR. When the result is
 \fBmethod\fR, further information can be discovered with \fBinfo class
 definition\fR, and when the result is \fBforward\fR, further information can
 be discovered with \fBinfo class forward\fR.
-.VE 8.6
 .TP
 \fBinfo class mixins\fI class\fR
-.VS 8.6
+.
 This subcommand returns a list of all classes that have been mixed into the
 class named \fIclass\fR.
-.VE 8.6
 .TP
 \fBinfo class subclasses\fI class\fR ?\fIpattern\fR?
-.VS 8.6
+.
 This subcommand returns a list of direct subclasses of class \fIclass\fR. If
 the optional \fIpattern\fR argument is present, it constrains the list of
 returned classes to those that match it according to the rules of
 \fBstring match\fR.
-.VE 8.6
 .TP
 \fBinfo class superclasses\fI class\fR
-.VS 8.6
+.
 This subcommand returns a list of direct superclasses of class \fIclass\fR in
 inheritance precedence order.
-.VE 8.6
 .TP
-\fBinfo class variables\fI class\fR
-.VS 8.6
+\fBinfo class variables\fI class\fR ?\fB\-private\fR?
+.
 This subcommand returns a list of all variables that have been declared for
 the class named \fIclass\fR (i.e. that are automatically present in the
 class's methods, constructor and destructor).
+.VS TIP500
+If the \fB\-private\fR option is specified, this lists the private variables
+declared instead.
+.VE TIP500
 .SS "OBJECT INTROSPECTION"
 .PP
 The following \fIsubcommand\fR values are supported by \fBinfo object\fR:
-.VE 8.6
 .TP
 \fBinfo object call\fI object method\fR
-.VS 8.6
+.
 Returns a description of the method implementations that are used to provide
 \fIobject\fR's implementation of \fImethod\fR.  This consists of a list of
 lists of four elements, where each sublist consists of a word that describes
 the general type of method implementation (being one of \fBmethod\fR for an
-ordinary method, \fBfilter\fR for an applied filter, and \fBunknown\fR for a
+ordinary method, \fBfilter\fR for an applied filter,
+.VS TIP500
+\fBprivate\fR for a private method,
+.VE TIP500
+and \fBunknown\fR for a
 method that is invoked as part of unknown method handling), a word giving the
 name of the particular method invoked (which is always the same as
 \fImethod\fR for the \fBmethod\fR type, and
@@ -550,128 +575,160 @@ implementation (see \fBinfo object methodtype\fR).
 .RS
 .PP
 Note that there is no inspection of whether the method implementations
-actually use \fBnext\fR to transfer control along the call chain.
+actually use \fBnext\fR to transfer control along the call chain,
+.VS TIP500
+and the call chains that this command files do not actually contain private
+methods.
+.VE TIP500
 .RE
-.VE 8.6
 .TP
 \fBinfo object class\fI object\fR ?\fIclassName\fR?
-.VS 8.6
+.
 If \fIclassName\fR is unspecified, this subcommand returns class of the
 \fIobject\fR object. If \fIclassName\fR is present, this subcommand returns a
 boolean value indicating whether the \fIobject\fR is of that class.
-.VE 8.6
+.TP
+\fBinfo object creationid\fI object\fR
+.VS TIP500
+Returns the unique creation identifier for the \fIobject\fR object. This
+creation identifier is unique to the object (within a Tcl interpreter) and
+cannot be controlled at object creation time or altered afterwards.
+.RS
+.PP
+\fIImplementation note:\fR the creation identifier is used to generate unique
+identifiers associated with the object, especially for private variables.
+.RE
+.VE TIP500
 .TP
 \fBinfo object definition\fI object method\fR
-.VS 8.6
+.
 This subcommand returns a description of the definition of the method named
 \fImethod\fR of object \fIobject\fR. The definition is described as a two
 element list; the first element is the list of arguments to the method in a
 form suitable for passing to another call to \fBproc\fR or a method definition,
 and the second element is the body of the method.
-.VE 8.6
 .TP
 \fBinfo object filters\fI object\fR
-.VS 8.6
+.
 This subcommand returns the list of filter methods set on the object.
-.VE 8.6
 .TP
 \fBinfo object forward\fI object method\fR
-.VS 8.6
+.
 This subcommand returns the argument list for the method forwarding called
 \fImethod\fR that is set on the object called \fIobject\fR.
-.VE 8.6
 .TP
 \fBinfo object isa\fI category object\fR ?\fIarg\fR?
-.VS 8.6
+.
 This subcommand tests whether an object belongs to a particular category,
 returning a boolean value that indicates whether the \fIobject\fR argument
 meets the criteria for the category. The supported categories are:
-.VE 8.6
 .RS
 .TP
 \fBinfo object isa class\fI object\fR
-.VS 8.6
+.
 This returns whether \fIobject\fR is a class (i.e. an instance of
 \fBoo::class\fR or one of its subclasses).
-.VE 8.6
 .TP
 \fBinfo object isa metaclass\fI object\fR
-.VS 8.6
+.
 This returns whether \fIobject\fR is a class that can manufacture classes
 (i.e. is \fBoo::class\fR or a subclass of it).
-.VE 8.6
 .TP
 \fBinfo object isa mixin\fI object class\fR
-.VS 8.6
+.
 This returns whether \fIclass\fR is directly mixed into \fIobject\fR.
-.VE 8.6
 .TP
 \fBinfo object isa object\fI object\fR
-.VS 8.6
+.
 This returns whether \fIobject\fR really is an object.
-.VE 8.6
 .TP
 \fBinfo object isa typeof\fI object class\fR
-.VS 8.6
+.
 This returns whether \fIclass\fR is the type of \fIobject\fR (i.e. whether
 \fIobject\fR is an instance of \fIclass\fR or one of its subclasses, whether
 direct or indirect).
 .RE
-.VE 8.6
 .TP
 \fBinfo object methods\fI object\fR ?\fIoption...\fR?
-.VS 8.6
+.
 This subcommand returns a list of all public (i.e. exported) methods of the
 object called \fIobject\fR. Any of the following \fIoption\fRs may be
 specified, controlling exactly which method names are returned:
 .RS
-.VE 8.6
 .TP
 \fB\-all\fR
-.VS 8.6
-If the \fB\-all\fR flag is given, the list of methods will include those
+.
+If the \fB\-all\fR flag is given,
+.VS TIP500
+and the \fB\-scope\fR flag is not given,
+.VE TIP500
+the list of methods will include those
 methods defined not just by the object, but also by the object's class and
 mixins, plus the superclasses of those classes.
-.VE 8.6
 .TP
 \fB\-private\fR
-.VS 8.6
-If the \fB\-private\fR flag is given, the list of methods will also include
-the private (i.e. non-exported) methods of the object (and classes, if
+.
+If the \fB\-private\fR flag is given,
+.VS TIP500
+and the \fB\-scope\fR flag is not given,
+.VE TIP500
+the list of methods will also include
+the non-exported methods of the object (and classes, if
 \fB\-all\fR is also given).
+.VS TIP500
+Note that this naming is an unfortunate clash with true private methods; this
+option name is retained for backward compatibility.
+.VE TIP500
+.TP
+\fB\-scope\fI scope\fR
+.VS TIP500
+Returns a list of all methods on \fIobject\fR that have the given visibility
+\fIscope\fR.  When this option is supplied, both the \fB\-all\fR and
+\fB\-private\fR options are ignored. The valid values for \fIscope\fR are:
+.RS
+.IP \fBpublic\fR 3
+Only methods with \fIpublic\fR scope (i.e., callable from anywhere) are to be
+returned.
+.IP \fBunexported\fR 3
+Only methods with \fIunexported\fR scope (i.e., only callable via \fBmy\fR) are to
+be returned.
+.IP \fBprivate\fR 3
+Only methods with \fIprivate\fR scope (i.e., only callable from within this object's
+instance methods) are to be returned.
+.RE
+.VE TIP500
 .RE
-.VE 8.6
 .TP
 \fBinfo object methodtype\fI object method\fR
-.VS 8.6
+.
 This subcommand returns a description of the type of implementation used for
 the method named \fImethod\fR of object \fIobject\fR. When the result is
 \fBmethod\fR, further information can be discovered with \fBinfo object
 definition\fR, and when the result is \fBforward\fR, further information can
 be discovered with \fBinfo object forward\fR.
-.VE 8.6
 .TP
 \fBinfo object mixins\fI object\fR
-.VS 8.6
+.
 This subcommand returns a list of all classes that have been mixed into the
 object named \fIobject\fR.
-.VE 8.6
 .TP
 \fBinfo object namespace\fI object\fR
-.VS 8.6
+.
 This subcommand returns the name of the internal namespace of the object named
 \fIobject\fR.
-.VE 8.6
 .TP
-\fBinfo object variables\fI object\fR
-.VS 8.6
+\fBinfo object variables\fI object\fRR ?\fB\-private\fR?
+.
 This subcommand returns a list of all variables that have been declared for
 the object named \fIobject\fR (i.e. that are automatically present in the
 object's methods).
-.VE 8.6
+.VS TIP500
+If the \fB\-private\fR option is specified, this lists the private variables
+declared instead.
+.VE TIP500
 .TP
 \fBinfo object vars\fI object\fR ?\fIpattern\fR?
-.VS 8.6
+.
 This subcommand returns a list of all variables in the private namespace of
 the object named \fIobject\fR. If the optional \fIpattern\fR argument is
 given, it is a filter (in the syntax of a \fBstring match\fR glob pattern)
@@ -680,7 +737,6 @@ from the list returned by \fBinfo object variables\fR; that can include
 variables that are currently unset, whereas this can include variables that
 are not automatically included by any of \fIobject\fR's methods (or those of
 its class, superclasses or mixins).
-.VE 8.6
 .SH EXAMPLES
 .PP
 This command prints out a procedure suitable for saving in a Tcl
@@ -703,7 +759,6 @@ proc printProc {procName} {
 }
 .CE
 .SS "EXAMPLES WITH OBJECTS"
-.VS 8.6
 .PP
 Every object necessarily knows what its class is; this information is
 trivially extractable through introspection:
@@ -724,8 +779,10 @@ method and get how it is defined. This procedure illustrates how:
 proc getDef {obj method} {
     foreach inf [\fBinfo object call\fR $obj $method] {
         lassign $inf calltype name locus methodtype
+
         # Assume no forwards or filters, and hence no $calltype
         # or $methodtype checks...
+
         if {$locus eq "object"} {
             return [\fBinfo object definition\fR $obj $name]
         } else {
@@ -748,7 +805,9 @@ proc getDef {obj method} {
         # Assume no forwards
         return [\fBinfo object definition\fR $obj $method]
     }
+
     set cls [\fBinfo object class\fR $obj]
+
     while {$method ni [\fBinfo class methods\fR $cls]} {
         # Assume the simple case
         set cls [lindex [\fBinfo class superclass\fR $cls] 0]
@@ -756,22 +815,17 @@ proc getDef {obj method} {
             error "no definition for $method"
         }
     }
+
     # Assume no forwards
     return [\fBinfo class definition\fR $cls $method]
 }
 .CE
-.VE 8.6
 .SH "SEE ALSO"
-.VS 8.6
 global(n), oo::class(n), oo::define(n), oo::object(n), proc(n), self(n),
-.VE 8.6
 tcl_library(n), tcl_patchLevel(n), tcl_version(n)
 .SH KEYWORDS
 command, information, interpreter, introspection, level, namespace,
-.VS 8.6
-object,
-.VE 8.6
-procedure, variable
+object, procedure, variable
 '\" Local Variables:
 '\" mode: nroff
 '\" fill-column: 78

doc/link.n

@@ -0,0 +1,124 @@
+'\"
+'\" Copyright (c) 2011-2015 Andreas Kupries
+'\" Copyright (c) 2018 Donal K. Fellows
+'\"
+'\" See the file "license.terms" for information on usage and redistribution
+'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES.
+'\"
+.TH link n 0.3 TclOO "TclOO Commands"
+.so man.macros
+.BS
+'\" Note:  do not modify the .SH NAME line immediately below!
+.SH NAME
+link \- create link from command to method of object
+.SH SYNOPSIS
+.nf
+package require TclOO
+
+\fBlink\fR \fImethodName\fR ?\fI...\fR?
+\fBlink\fR \fB{\fIcommandName methodName\fB}\fR ?\fI...\fR?
+.fi
+.BE
+.SH DESCRIPTION
+The \fBlink\fR command is available within methods. It takes a series of one
+or more method names (\fImethodName ...\fR) and/or pairs of command- and
+method-name (\fB{\fIcommandName methodName\fB}\fR) and makes the named methods
+available as commands without requiring the explicit use of the name of the
+object or the \fBmy\fR command. The method does not need to exist at the time
+that the link is made; if the link command is invoked when the method does not
+exist, the standard \fBunknown\fR method handling system is used.
+.PP
+The command name under which the method becomes available defaults to the
+method name, except where explicitly specified through an alias/method pair.
+Formally, every argument must be a list; if the list has two elements, the
+first element is the name of the command to create and the second element is
+the name of the method of the current object to which the command links;
+otherwise, the name of the command and the name of the method are the same
+string (the first element of the list).
+.PP
+If the name of the command is not a fully-qualified command name, it will be
+resolved with respect to the current namespace (i.e., the object namespace).
+.SH EXAMPLES
+This demonstrates linking a single method in various ways. First it makes a
+simple link, then a renamed link, then an external link. Note that the method
+itself is unexported, but that it can still be called directly from outside
+the class.
+.PP
+.CS
+oo::class create ABC {
+    method Foo {} {
+        puts "This is Foo in [self]"
+    }
+
+    constructor {} {
+        \fBlink\fR Foo
+        # The method foo is now directly accessible as foo here
+        \fBlink\fR {bar Foo}
+        # The method foo is now directly accessible as bar
+        \fBlink\fR {::ExternalCall Foo}
+        # The method foo is now directly accessible in the global
+        # namespace as ExternalCall
+    }
+
+    method grill {} {
+        puts "Step 1:"
+        Foo
+        puts "Step 2:"
+        bar
+    }
+}
+
+ABC create abc
+abc grill
+        \fI\(-> Step 1:\fR
+        \fI\(-> This is foo in ::abc\fR
+        \fI\(-> Step 2:\fR
+        \fI\(-> This is foo in ::abc\fR
+# Direct access via the linked command
+puts "Step 3:"; ExternalCall
+        \fI\(-> Step 3:\fR
+        \fI\(-> This is foo in ::abc\fR
+.CE
+.PP
+This example shows that multiple linked commands can be made in a call to
+\fBlink\fR, and that they can handle arguments.
+.PP
+.CS
+oo::class create Ex {
+    constructor {} {
+        \fBlink\fR a b c
+        # The methods a, b, and c (defined below) are all now
+        # directly acessible within methods under their own names.
+    }
+
+    method a {} {
+        puts "This is a"
+    }
+    method b {x} {
+        puts "This is b($x)"
+    }
+    method c {y z} {
+        puts "This is c($y,$z)"
+    }
+
+    method call {p q r} {
+        a
+        b $p
+        c $q $r
+    }
+}
+
+set o [Ex new]
+$o 3 5 7
+        \fI\(-> This is a\fR
+        \fI\(-> This is b(3)\fR
+        \fI\(-> This is c(5,7)\fR
+.CE
+.SH "SEE ALSO"
+interp(n), my(n), oo::class(n), oo::define(n)
+.SH KEYWORDS
+command, method, object
+.\" Local Variables:
+.\" mode: nroff
+.\" fill-column: 78
+.\" End:

doc/my.n

@@ -9,25 +9,45 @@
 .BS
 '\" Note:  do not modify the .SH NAME line immediately below!
 .SH NAME
-my \- invoke any method of current object
+my, myclass \- invoke any method of current object or its class
 .SH SYNOPSIS
 .nf
 package require TclOO
 
 \fBmy\fI methodName\fR ?\fIarg ...\fR?
+\fBmyclass\fI methodName\fR ?\fIarg ...\fR?
 .fi
 .BE
 .SH DESCRIPTION
 .PP
-The \fBmy\fR command is used to allow methods of objects to invoke any method
-of the object (or its class). In particular, the set of valid values for
+The \fBmy\fR command is used to allow methods of objects to invoke methods
+of the object (or its class),
+.VS TIP478
+and he \fBmyclass\fR command is used to allow methods of objects to invoke
+methods of the current class of the object \fIas an object\fR.
+.VE TIP478
+In particular, the set of valid values for
 \fImethodName\fR is the set of all methods supported by an object and its
-superclasses, including those that are not exported. The object upon which the
-method is invoked is always the one that is the current context of the method
-(i.e. the object that is returned by \fBself object\fR) from which the
-\fBmy\fR command is invoked.
+superclasses, including those that are not exported
+.VS TIP500
+and private methods of the object or class when used within another method
+defined by that object or class.
+.VE TIP500
 .PP
-Each object has its own \fBmy\fR command, contained in its instance namespace.
+The object upon which the method is invoked via \fBmy\fR is the one that owns
+the namespace that the \fBmy\fR command is contained in initially (\fBNB:\fR the link
+remains if the command is renamed), which is the currently invoked object by
+default.
+.VS TIP478
+Similarly, the object on which the method is invoked via \fBmyclass\fR is the
+object that is the current class of the object that owns the namespace that
+the \fBmyclass\fR command is contained in initially. As with \fBmy\fR, the
+link remains even if the command is renamed into another namespace, and
+defaults to being the manufacturing class of the current object.
+.VE TIP478
+.PP
+Each object has its own \fBmy\fR and \fBmyclass\fR commands, contained in its
+instance namespace.
 .SH EXAMPLES
 .PP
 This example shows basic use of \fBmy\fR to use the \fBvariables\fR method of
@@ -40,16 +60,71 @@ oo::class create c {
         puts [incr counter]
     }
 }
+
 c create o
 o count              \fI\(-> prints "1"\fR
 o count              \fI\(-> prints "2"\fR
 o count              \fI\(-> prints "3"\fR
 .CE
+.PP
+This example shows how you can use \fBmy\fR to make callbacks to private
+methods from outside the object (from a \fBtrace\fR), using
+\fBnamespace code\fR to enter the correct context. (See the \fBcallback\fR
+command for the recommended way of doing this.)
+.PP
+.CS
+oo::class create HasCallback {
+    method makeCallback {} {
+        return [namespace code {
+            \fBmy\fR Callback
+        }]
+    }
+
+    method Callback {args} {
+        puts "callback: $args"
+    }
+}
+
+set o [HasCallback new]
+trace add variable xyz write [$o makeCallback]
+set xyz "called"     \fI\(-> prints "callback: xyz {} write"\fR
+.CE
+.PP
+.VS TIP478
+This example shows how to access a private method of a class from an instance
+of that class. (See the \fBclassmethod\fR declaration in \fBoo::define\fR for
+a higher level interface for doing this.)
+.PP
+.CS
+oo::class create CountedSteps {
+    self {
+        variable count
+        method Count {} {
+            return [incr count]
+        }
+    }
+    method advanceTwice {} {
+        puts "in [self] step A: [\fBmyclass\fR Count]"
+        puts "in [self] step B: [\fBmyclass\fR Count]"
+    }
+}
+
+CountedSteps create x
+CountedSteps create y
+x advanceTwice       \fI\(-> prints "in ::x step A: 1"\fR
+                     \fI\(-> prints "in ::x step B: 2"\fR
+y advanceTwice       \fI\(-> prints "in ::y step A: 3"\fR
+                     \fI\(-> prints "in ::y step B: 4"\fR
+x advanceTwice       \fI\(-> prints "in ::x step A: 5"\fR
+                     \fI\(-> prints "in ::x step B: 6"\fR
+y advanceTwice       \fI\(-> prints "in ::y step A: 7"\fR
+                     \fI\(-> prints "in ::y step B: 8"\fR
+.CE
+.VE TIP478
 .SH "SEE ALSO"
 next(n), oo::object(n), self(n)
 .SH KEYWORDS
 method, method visibility, object, private method, public method
-
 .\" Local variables:
 .\" mode: nroff
 .\" fill-column: 78

doc/next.n

@@ -112,6 +112,7 @@ oo::class create theSuperclass {
         puts "in the superclass, args = $args"
     }
 }
+
 oo::class create theSubclass {
     superclass theSuperclass
     method example {args} {
@@ -121,6 +122,7 @@ oo::class create theSubclass {
         puts "after chaining from subclass"
     }
 }
+
 theSubclass create obj
 oo::objdefine obj method example args {
     puts "per-object method, args = $args"
@@ -167,6 +169,7 @@ oo::class create cache {
         \fI# Compute value, insert into cache, and return it\fR
         return [set ValueCache($key) [\fBnext\fR {*}$args]]
     }
+
     method flushCache {} {
         my variable ValueCache
         unset ValueCache
@@ -178,10 +181,12 @@ oo::class create cache {
 oo::object create demo
 oo::objdefine demo {
     mixin cache
+
     method compute {a b c} {
         after 3000 \fI;# Simulate deep thought\fR
         return [expr {$a + $b * $c}]
     }
+
     method compute2 {a b c} {
         after 3000 \fI;# Simulate deep thought\fR
         return [expr {$a * $b + $c}]

doc/process.n

@@ -0,0 +1,131 @@
+'\"
+'\" Copyright (c) 2017 Frederic Bonnet.
+'\"
+'\" See the file "license.terms" for information on usage and redistribution
+'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES.
+'\"
+.TH process n 8.7 Tcl "Tcl Built-In Commands"
+.so man.macros
+.BS
+'\" Note:  do not modify the .SH NAME line immediately below!
+.SH NAME
+tcl::process \- Subprocess management
+.SH SYNOPSIS
+\fB::tcl::process \fIoption \fR?\fIarg arg ...\fR?
+.BE
+.SH DESCRIPTION
+.PP
+This command provides a way to manage subprocesses created by the \fBopen\fR
+and \fBexec\fR commands. The legal \fIoptions\fR (which may be abbreviated) are:
+.TP
+\fB::tcl::process list\fR
+.
+Returns the list of subprocess PIDs.
+.TP
+\fB::tcl::process status\fR ?\fIswitches\fR? ?\fIpids\fR?
+.
+Returns a dictionary mapping subprocess PIDs to their respective status. If
+\fIpids\fR is specified as a list of PIDs then the command only returns the
+status of the matching subprocesses if they exist, and raises an error
+otherwise. For active processes, the status is an empty value. For terminated
+processes, the status is a list with the following format:
+.QW "{code ?\fImsg errorCode\fR?}" ,
+where:
+.RS
+.TP
+\fBcode\fR\0
+.
+is a standard Tcl return code,
+.TP
+\fBmsg\fR\0
+.
+is the human-readable error message,
+.TP
+\fBerrorCode\fR\0
+.
+uses the same format as the \fBerrorCode\fR global variable
+.RE
+Note that \fBmsg\fR and \fBerrorCode\fR are only present for abnormally
+terminated processes (i.e. those where \fBcode\fR is nonzero). Under the hood
+this command calls \fBTcl_WaitPid\fR with the \fBWNOHANG\fR flag set for
+non-blocking behavior, unless the \fB\-wait\fR switch is set (see below).
+.RS
+.PP
+Additionally, \fB::tcl::process status\fR accepts the following switches:
+.TP
+\fB\-wait\fR\0
+.
+By default the command returns immediately (the underlying \fBTcl_WaitPid\fR is
+called with the \fBWNOHANG\fR flag set) unless this switch is set. If \fBpids\fR
+is specified as a list of PIDs then the command waits until the status of the
+matching subprocesses are available. If \fBpids\fR is not specified then it
+waits for all known subprocesses.
+.TP
+\fB\-\|\-\fR
+.
+Marks the end of switches.  The argument following this one will
+be treated as the first \fIarg\fR even if it starts with a \fB\-\fR.
+.RE
+.TP
+\fB::tcl::process purge ?\fIpids\fR?
+.
+Cleans up all data associated with terminated subprocesses. If \fBpids\fR is
+specified as a list of PIDs then the command only cleanup data for the matching
+subprocesses if they exist, and raises an error otherwise. If the process is
+still active then it does nothing.
+.TP
+\fB::tcl::process autopurge ?\fIflag\fR?
+.
+Automatic purge facility. If \fBflag\fR is specified as a boolean value then it
+activates or deactivate autopurge. In all cases it returns the current status as
+a boolean value. When autopurge is active, \fBTcl_ReapDetachedProcs\fR is called
+each time the exec command is executed or a pipe channel created by open is
+closed. When autopurge is inactive, \fB::tcl::process\fR purge must be called
+explicitly. By default autopurge is active.
+.RE
+.SH "EXAMPLES"
+.PP
+.CS
+\fB::tcl::process autopurge\fR
+     \fI\(-> true\fR
+\fB::tcl::process autopurge\fR false
+     \fI\(-> false\fR
+
+set pid1 [exec command1 a b c | command2 d e f &]
+     \fI\(-> 123 456\fR
+set chan [open "|command1 a b c | command2 d e f"]
+     \fI\(-> file123\fR
+set pid2 [pid $chan]
+     \fI\(-> 789 1011\fR
+
+\fB::tcl::process list\fR
+     \fI\(-> 123 456 789 1011\fR
+
+\fB::tcl::process status\fR
+     \fI\(-> 123 0 456 {1 "child killed: write on pipe with no readers" {CHILDKILLED 456 SIGPIPE "write on pipe with no readers"}} 789 {1 "child suspended: background tty read" {CHILDSUSP 789 SIGTTIN "background tty read"}} 1011 {}\fR
+
+\fB::tcl::process status\fR 123
+     \fI\(-> 123 0\fR
+
+\fB::tcl::process status\fR 1011
+     \fI\(-> 1011 {}\fR
+
+\fB::tcl::process status\fR -wait
+     \fI\(-> 123 0 456 {1 "child killed: write on pipe with no readers" {CHILDKILLED 456 SIGPIPE "write on pipe with no readers"}} 789 {1 "child suspended: background tty read" {CHILDSUSP 789 SIGTTIN "background tty read"}} 1011 {1 "child process exited abnormally" {CHILDSTATUS 1011 -1}}\fR
+
+\fB::tcl::process status\fR 1011
+     \fI\(-> 1011 {1 "child process exited abnormally" {CHILDSTATUS 1011 -1}}\fR
+
+\fB::tcl::process purge\fR
+exec command1 1 2 3 &
+     \fI\(-> 1213\fR
+\fB::tcl::process list\fR
+     \fI\(-> 1213\fR
+.CE
+.SH "SEE ALSO"
+exec(n), open(n), Tcl_DetachPids(3), Tcl_WaitPid(3), Tcl_ReapDetachedProcs(3)
+.SH "KEYWORDS"
+background, child, detach, process, wait
+'\" Local Variables:
+'\" mode: nroff
+'\" End:

doc/self.n

@@ -32,7 +32,12 @@ implement the current call chain. The first element is the same as would be
 reported by \fBinfo object\fR \fBcall\fR for the current method (except that this
 also reports useful values from within constructors and destructors, whose
 names are reported as \fB<constructor>\fR and \fB<destructor>\fR
-respectively), and the second element is an index into the first element's
+respectively,
+.VS TIP500
+and for private methods, which are described as being \fBprivate\fR instead of
+being a \fBmethod\fR),
+.VE TIP500
+and the second element is an index into the first element's
 list that indicates which actual implementation is currently executing (the
 first implementation to execute is always at index 0).
 .TP

doc/singleton.n

@@ -0,0 +1,99 @@
+'\"
+'\" Copyright (c) 2018 Donal K. Fellows
+'\"
+'\" See the file "license.terms" for information on usage and redistribution
+'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES.
+'\"
+.TH singleton n 0.3 TclOO "TclOO Commands"
+.so man.macros
+.BS
+'\" Note:  do not modify the .SH NAME line immediately below!
+.SH NAME
+oo::singleton \- a class that does only allows one instance of itself
+.SH SYNOPSIS
+.nf
+package require TclOO
+
+\fBoo::singleton\fI method \fR?\fIarg ...\fR?
+.fi
+.SH "CLASS HIERARCHY"
+.nf
+\fBoo::object\fR
+   \(-> \fBoo::class\fR
+       \(-> \fBoo::singleton\fR
+.fi
+.BE
+.SH DESCRIPTION
+Singleton classes are classes that only permit at most one instance of
+themselves to exist. They unexport the \fBcreate\fR and
+\fBcreateWithNamespace\fR methods entirely, and override the \fBnew\fR method
+so that it only makes a new instance if there is no existing instance.  It is
+not recommended to inherit from a singleton class; singleton-ness is \fInot\fR
+inherited. It is not recommended that a singleton class's constructor take any
+arguments.
+.PP
+Instances have their\fB destroy\fR method overridden with a method that always
+returns an error in order to discourage destruction of the object, but
+destruction remains possible if strictly necessary (e.g., by destroying the
+class or using \fBrename\fR to delete it). They also have a (non-exported)
+\fB<cloned>\fR method defined on them that similarly always returns errors to
+make attempts to use the singleton instance with \fBoo::copy\fR fail.
+.SS CONSTRUCTOR
+The \fBoo::singleton\fR class does not define an explicit constructor; this
+means that it is effectively the same as the constructor of the
+\fBoo::class\fR class.
+.SS DESTRUCTOR
+The \fBoo::singleton\fR class does not define an explicit destructor;
+destroying an instance of it is just like destroying an ordinary class (and
+will destroy the singleton object).
+.SS "EXPORTED METHODS"
+.TP
+\fIcls \fBnew \fR?\fIarg ...\fR?
+.
+This returns the current instance of the singleton class, if one exists, and
+creates a new instance only if there is no existing instance. The additional
+arguments, \fIarg ...\fR, are only used if a new instance is actually
+manufactured; that construction is via the \fBoo::class\fR class's \fBnew\fR
+method.
+.RS
+.PP
+This is an override of the behaviour of a superclass's method with an
+identical call signature to the superclass's implementation.
+.RE
+.SS "NON-EXPORTED METHODS"
+The \fBoo::singleton\fR class explicitly states that \fBcreate\fR and
+\fBcreateWithNamespace\fR are unexported; callers should not assume that they
+have control over either the name or the namespace name of the singleton instance.
+.SH EXAMPLE
+.PP
+This example demonstrates that there is only one instance even though the
+\fBnew\fR method is called three times.
+.PP
+.CS
+\fBoo::singleton\fR create Highlander {
+    method say {} {
+        puts "there can be only one"
+    }
+}
+
+set h1 [Highlander new]
+set h2 [Highlander new]
+if {$h1 eq $h2} {
+    puts "equal objects"    \fI\(-> prints "equal objects"\fR
+}
+set h3 [Highlander new]
+if {$h1 eq $h3} {
+    puts "equal objects"    \fI\(-> prints "equal objects"\fR
+}
+.CE
+.PP
+Note that the name of the instance of the singleton is not guaranteed to be
+anything in particular.
+.SH "SEE ALSO"
+oo::class(n)
+.SH KEYWORDS
+class, metaclass, object, single instance
+.\" Local variables:
+.\" mode: nroff
+.\" fill-column: 78
+.\" End:

generic/tcl.decls

@@ -104,7 +104,7 @@ declare 20 {
 declare 21 {
     int Tcl_DbIsShared(Tcl_Obj *objPtr, const char *file, int line)
 }
-declare 22 {
+declare 22 {deprecated {No longer in use, changed to macro}} {
     Tcl_Obj *Tcl_DbNewBooleanObj(int boolValue, const char *file, int line)
 }
 declare 23 {
@@ -119,7 +119,7 @@ declare 25 {
     Tcl_Obj *Tcl_DbNewListObj(int objc, Tcl_Obj *const *objv,
 	    const char *file, int line)
 }
-declare 26 {
+declare 26 {deprecated {No longer in use, changed to macro}} {
     Tcl_Obj *Tcl_DbNewLongObj(long longValue, const char *file, int line)
 }
 declare 27 {
@@ -152,7 +152,7 @@ declare 35 {
     int Tcl_GetDoubleFromObj(Tcl_Interp *interp, Tcl_Obj *objPtr,
 	    double *doublePtr)
 }
-declare 36 {
+declare 36 {deprecated {No longer in use, changed to macro}} {
     int Tcl_GetIndexFromObj(Tcl_Interp *interp, Tcl_Obj *objPtr,
 	    const char *const *tablePtr, const char *msg, int flags, int *indexPtr)
 }
@@ -198,7 +198,7 @@ declare 48 {
     int Tcl_ListObjReplace(Tcl_Interp *interp, Tcl_Obj *listPtr, int first,
 	    int count, int objc, Tcl_Obj *const objv[])
 }
-declare 49 {
+declare 49 {deprecated {No longer in use, changed to macro}} {
     Tcl_Obj *Tcl_NewBooleanObj(int boolValue)
 }
 declare 50 {
@@ -207,13 +207,13 @@ declare 50 {
 declare 51 {
     Tcl_Obj *Tcl_NewDoubleObj(double doubleValue)
 }
-declare 52 {
+declare 52 {deprecated {No longer in use, changed to macro}} {
     Tcl_Obj *Tcl_NewIntObj(int intValue)
 }
 declare 53 {
     Tcl_Obj *Tcl_NewListObj(int objc, Tcl_Obj *const objv[])
 }
-declare 54 {
+declare 54 {deprecated {No longer in use, changed to macro}} {
     Tcl_Obj *Tcl_NewLongObj(long longValue)
 }
 declare 55 {
@@ -222,7 +222,7 @@ declare 55 {
 declare 56 {
     Tcl_Obj *Tcl_NewStringObj(const char *bytes, int length)
 }
-declare 57 {
+declare 57 {deprecated {No longer in use, changed to macro}} {
     void Tcl_SetBooleanObj(Tcl_Obj *objPtr, int boolValue)
 }
 declare 58 {
@@ -235,13 +235,13 @@ declare 59 {
 declare 60 {
     void Tcl_SetDoubleObj(Tcl_Obj *objPtr, double doubleValue)
 }
-declare 61 {
+declare 61 {deprecated {No longer in use, changed to macro}} {
     void Tcl_SetIntObj(Tcl_Obj *objPtr, int intValue)
 }
 declare 62 {
     void Tcl_SetListObj(Tcl_Obj *objPtr, int objc, Tcl_Obj *const objv[])
 }
-declare 63 {
+declare 63 {deprecated {No longer in use, changed to macro}} {
     void Tcl_SetLongObj(Tcl_Obj *objPtr, long longValue)
 }
 declare 64 {
@@ -250,10 +250,10 @@ declare 64 {
 declare 65 {
     void Tcl_SetStringObj(Tcl_Obj *objPtr, const char *bytes, int length)
 }
-declare 66 {
+declare 66 {deprecated {No longer in use, changed to macro}} {
     void Tcl_AddErrorInfo(Tcl_Interp *interp, const char *message)
 }
-declare 67 {
+declare 67 {deprecated {No longer in use, changed to macro}} {
     void Tcl_AddObjErrorInfo(Tcl_Interp *interp, const char *message,
 	    int length)
 }
@@ -472,7 +472,7 @@ declare 129 {
 declare 130 {
     int Tcl_EvalFile(Tcl_Interp *interp, const char *fileName)
 }
-declare 131 {
+declare 131 {deprecated {No longer in use, changed to macro}} {
     int Tcl_EvalObj(Tcl_Interp *interp, Tcl_Obj *objPtr)
 }
 declare 132 {
@@ -624,7 +624,7 @@ declare 173 {
 declare 174 {
     const char *Tcl_GetStringResult(Tcl_Interp *interp)
 }
-declare 175 {
+declare 175 {deprecated {No longer in use, changed to macro}} {
     const char *Tcl_GetVar(Tcl_Interp *interp, const char *varName,
 	    int flags)
 }
@@ -635,7 +635,7 @@ declare 176 {
 declare 177 {
     int Tcl_GlobalEval(Tcl_Interp *interp, const char *command)
 }
-declare 178 {
+declare 178 {deprecated {No longer in use, changed to macro}} {
     int Tcl_GlobalEvalObj(Tcl_Interp *interp, Tcl_Obj *objPtr)
 }
 declare 179 {
@@ -834,7 +834,7 @@ declare 235 {
 declare 236 {
     void Tcl_SetStdChannel(Tcl_Channel channel, int type)
 }
-declare 237 {
+declare 237 {deprecated {No longer in use, changed to macro}} {
     const char *Tcl_SetVar(Tcl_Interp *interp, const char *varName,
 	    const char *newValue, int flags)
 }
@@ -869,7 +869,7 @@ declare 245 {
 declare 246 {deprecated {}} {
     int Tcl_TellOld(Tcl_Channel chan)
 }
-declare 247 {
+declare 247 {deprecated {No longer in use, changed to macro}} {
     int Tcl_TraceVar(Tcl_Interp *interp, const char *varName, int flags,
 	    Tcl_VarTraceProc *proc, ClientData clientData)
 }
@@ -890,14 +890,14 @@ declare 251 {
 declare 252 {
     int Tcl_UnregisterChannel(Tcl_Interp *interp, Tcl_Channel chan)
 }
-declare 253 {
+declare 253 {deprecated {No longer in use, changed to macro}} {
     int Tcl_UnsetVar(Tcl_Interp *interp, const char *varName, int flags)
 }
 declare 254 {
     int Tcl_UnsetVar2(Tcl_Interp *interp, const char *part1, const char *part2,
 	    int flags)
 }
-declare 255 {
+declare 255 {deprecated {No longer in use, changed to macro}} {
     void Tcl_UntraceVar(Tcl_Interp *interp, const char *varName, int flags,
 	    Tcl_VarTraceProc *proc, ClientData clientData)
 }
@@ -909,7 +909,7 @@ declare 256 {
 declare 257 {
     void Tcl_UpdateLinkedVar(Tcl_Interp *interp, const char *varName)
 }
-declare 258 {
+declare 258 {deprecated {No longer in use, changed to macro}} {
     int Tcl_UpVar(Tcl_Interp *interp, const char *frameName,
 	    const char *varName, const char *localName, int flags)
 }
@@ -920,7 +920,7 @@ declare 259 {
 declare 260 {
     int Tcl_VarEval(Tcl_Interp *interp, ...)
 }
-declare 261 {
+declare 261 {deprecated {No longer in use, changed to macro}} {
     ClientData Tcl_VarTraceInfo(Tcl_Interp *interp, const char *varName,
 	    int flags, Tcl_VarTraceProc *procPtr, ClientData prevClientData)
 }
@@ -955,7 +955,7 @@ declare 270 {
     const char *Tcl_ParseVar(Tcl_Interp *interp, const char *start,
 	    const char **termPtr)
 }
-declare 271 {
+declare 271 {deprecated {No longer in use, changed to macro}} {
     const char *Tcl_PkgPresent(Tcl_Interp *interp, const char *name,
 	    const char *version, int exact)
 }
@@ -964,12 +964,12 @@ declare 272 {
 	    const char *name, const char *version, int exact,
 	    void *clientDataPtr)
 }
-declare 273 {
+declare 273 {deprecated {No longer in use, changed to macro}} {
     int Tcl_PkgProvide(Tcl_Interp *interp, const char *name,
 	    const char *version)
 }
 # TIP #268: The internally used new Require function is in slot 573.
-declare 274 {
+declare 274 {deprecated {No longer in use, changed to macro}} {
     const char *Tcl_PkgRequire(Tcl_Interp *interp, const char *name,
 	    const char *version, int exact)
 }
@@ -1350,7 +1350,7 @@ declare 380 {
 declare 381 {
     int Tcl_GetUniChar(Tcl_Obj *objPtr, int index)
 }
-declare 382 {
+declare 382 {deprecated {No longer in use, changed to macro}} {
     Tcl_UniChar *Tcl_GetUnicode(Tcl_Obj *objPtr)
 }
 declare 383 {
@@ -2378,6 +2378,10 @@ declare 1 macosx {
 export {
     void Tcl_Main(int argc, char **argv, Tcl_AppInitProc *appInitProc)
 }
+export {
+    void Tcl_MainEx(int argc, char **argv, Tcl_AppInitProc *appInitProc,
+    Tcl_Interp *interp)
+}
 export {
     const char *Tcl_InitStubs(Tcl_Interp *interp, const char *version,
 	int exact)

generic/tcl.h

@@ -89,6 +89,10 @@ extern "C" {
 #  define JOIN(a,b) JOIN1(a,b)
 #  define JOIN1(a,b) a##b
 #endif
+
+#ifndef TCL_THREADS
+#   define TCL_THREADS 1
+#endif
 #endif /* !TCL_NO_DEPRECATED */
 
 /*
@@ -103,15 +107,10 @@ extern "C" {
 #ifndef RC_INVOKED
 
 /*
- * Special macro to define mutexes, that doesn't do anything if we are not
- * using threads.
+ * Special macro to define mutexes.
  */
 
-#ifdef TCL_THREADS
 #define TCL_DECLARE_MUTEX(name) static Tcl_Mutex name;
-#else
-#define TCL_DECLARE_MUTEX(name)
-#endif
 
 /*
  * Tcl's public routine Tcl_FSSeek() uses the values SEEK_SET, SEEK_CUR, and
@@ -2146,9 +2145,9 @@ typedef struct Tcl_EncodingType {
 
 /*
  * The maximum number of bytes that are necessary to represent a single
- * Unicode character in UTF-8. The valid values should be 3, 4 or 6
- * (or perhaps 1 if we want to support a non-unicode enabled core). If 3 or
- * 4, then Tcl_UniChar must be 2-bytes in size (UCS-2) (the default). If 6,
+ * Unicode character in UTF-8. The valid values are 4 and 6
+ * (or perhaps 1 if we want to support a non-unicode enabled core). If 4,
+ * then Tcl_UniChar must be 2-bytes in size (UCS-2) (the default). If 6,
  * then Tcl_UniChar must be 4-bytes in size (UCS-4). At this time UCS-2 mode
  * is the default and recommended mode. UCS-4 is experimental and not
  * recommended. It works for the core, but most extensions expect UCS-2.
@@ -2361,6 +2360,11 @@ const char *		Tcl_InitStubs(Tcl_Interp *interp, const char *version,
 			    int exact, int magic);
 const char *		TclTomMathInitializeStubs(Tcl_Interp *interp,
 			    const char *version, int epoch, int revision);
+#if defined(_WIN32)
+    TCL_NORETURN void Tcl_ConsolePanic(const char *format, ...);
+#else
+#   define Tcl_ConsolePanic ((Tcl_PanicProc *)0)
+#endif
 
 #ifdef USE_TCL_STUBS
 #if TCL_RELEASE_LEVEL == TCL_FINAL_RELEASE
@@ -2392,7 +2396,7 @@ const char *		TclTomMathInitializeStubs(Tcl_Interp *interp,
  */
 
 #define Tcl_Main(argc, argv, proc) Tcl_MainEx(argc, argv, proc, \
-	    ((Tcl_CreateInterp)()))
+	    (((Tcl_SetPanicProc)(Tcl_ConsolePanic), Tcl_CreateInterp)()))
 EXTERN void		Tcl_MainEx(int argc, char **argv,
 			    Tcl_AppInitProc *appInitProc, Tcl_Interp *interp);
 EXTERN const char *	Tcl_PkgInitStubsCheck(Tcl_Interp *interp,
@@ -2550,27 +2554,6 @@ EXTERN void		Tcl_GetMemoryInfo(Tcl_DString *dsPtr);
 #define Tcl_CreateHashEntry(tablePtr, key, newPtr) \
 	(*((tablePtr)->createProc))(tablePtr, (const char *)(key), newPtr)
 
-/*
- *----------------------------------------------------------------------------
- * Macros that eliminate the overhead of the thread synchronization functions
- * when compiling without thread support.
- */
-
-#ifndef TCL_THREADS
-#undef  Tcl_MutexLock
-#define Tcl_MutexLock(mutexPtr)
-#undef  Tcl_MutexUnlock
-#define Tcl_MutexUnlock(mutexPtr)
-#undef  Tcl_MutexFinalize
-#define Tcl_MutexFinalize(mutexPtr)
-#undef  Tcl_ConditionNotify
-#define Tcl_ConditionNotify(condPtr)
-#undef  Tcl_ConditionWait
-#define Tcl_ConditionWait(condPtr, mutexPtr, timePtr)
-#undef  Tcl_ConditionFinalize
-#define Tcl_ConditionFinalize(condPtr)
-#endif /* TCL_THREADS */
-
 /*
  *----------------------------------------------------------------------------
  * Deprecated Tcl functions:

generic/tclAlloc.c

@@ -22,7 +22,7 @@
  */
 
 #include "tclInt.h"
-#if !defined(TCL_THREADS) || !defined(USE_THREAD_ALLOC)
+#if !TCL_THREADS || !defined(USE_THREAD_ALLOC)
 
 #if USE_TCLALLOC
 
@@ -121,7 +121,7 @@ static struct block bigBlocks={	/* Big blocks aren't suballocated. */
  * variable.
  */
 
-#ifdef TCL_THREADS
+#if TCL_THREADS
 static Tcl_Mutex *allocMutexPtr;
 #endif
 static int allocInit = 0;
@@ -171,7 +171,7 @@ TclInitAlloc(void)
 {
     if (!allocInit) {
 	allocInit = 1;
-#ifdef TCL_THREADS
+#if TCL_THREADS
 	allocMutexPtr = Tcl_GetAllocMutex();
 #endif
     }

generic/tclAssembly.c

@@ -2253,7 +2253,7 @@ GetListIndexOperand(
     if (GetNextOperand(assemEnvPtr, tokenPtrPtr, &value) != TCL_OK) {
 	return TCL_ERROR;
     }
-     
+
     /* Convert to an integer, advance to the next token and return. */
     /*
      * NOTE: Indexing a list with an index before it yields the

generic/tclBasic.c

@@ -749,7 +749,7 @@ Tcl_CreateInterp(void)
      * cache was already initialised by the call to alloc the interp struct.
      */
 
-#if defined(TCL_THREADS) && defined(USE_THREAD_ALLOC)
+#if TCL_THREADS && defined(USE_THREAD_ALLOC)
     iPtr->allocCache = TclpGetAllocCache();
 #else
     iPtr->allocCache = NULL;
@@ -964,7 +964,7 @@ Tcl_CreateInterp(void)
 #endif /* !TCL_NO_DEPRECATED */
     TclpSetVariables(interp);
 
-#ifdef TCL_THREADS
+#if TCL_THREADS
     /*
      * The existence of the "threaded" element of the tcl_platform array
      * indicates that this particular Tcl shell has been compiled with threads
@@ -2295,30 +2295,33 @@ Tcl_CreateObjCommand(
 }
 
 Tcl_Command
-TclCreateObjCommandInNs (
+TclCreateObjCommandInNs(
     Tcl_Interp *interp,
-    const char *cmdName,	/* Name of command, without any namespace components */
+    const char *cmdName,	/* Name of command, without any namespace
+                                 * components. */
     Tcl_Namespace *namespace,   /* The namespace to create the command in */
     Tcl_ObjCmdProc *proc,	/* Object-based function to associate with
 				 * name. */
     ClientData clientData,	/* Arbitrary value to pass to object
 				 * function. */
-    Tcl_CmdDeleteProc *deleteProc
+    Tcl_CmdDeleteProc *deleteProc)
 				/* If not NULL, gives a function to call when
 				 * this command is deleted. */
-) {
+{
     int deleted = 0, isNew = 0;
     Command *cmdPtr;
     ImportRef *oldRefPtr = NULL;
     ImportedCmdData *dataPtr;
     Tcl_HashEntry *hPtr;
     Namespace *nsPtr = (Namespace *) namespace;
+
     /*
-     * If the command name we seek to create already exists, we need to
-     * delete that first.  That can be tricky in the presence of traces.
-     * Loop until we no longer find an existing command in the way, or
-     * until we've deleted one command and that didn't finish the job.
+     * If the command name we seek to create already exists, we need to delete
+     * that first. That can be tricky in the presence of traces. Loop until we
+     * no longer find an existing command in the way, or until we've deleted
+     * one command and that didn't finish the job.
      */
+
     while (1) {
 	hPtr = Tcl_CreateHashEntry(&nsPtr->cmdTable, cmdName, &isNew);
 
@@ -2330,16 +2333,18 @@ TclCreateObjCommandInNs (
 	    break;
 	}
 
+	/*
+         * An existing command conflicts. Try to delete it.
+         */
 
-	/* An existing command conflicts. Try to delete it.. */
 	cmdPtr = Tcl_GetHashValue(hPtr);
 
 	/*
-	 * [***] This is wrong.  See Tcl Bug a16752c252.
-	 * However, this buggy behavior is kept under particular
-	 * circumstances to accommodate deployed binaries of the
-	 * "tclcompiler" program. http://sourceforge.net/projects/tclpro/
-	 * that crash if the bug is fixed.
+	 * [***] This is wrong. See Tcl Bug a16752c252. However, this buggy
+	 * behavior is kept under particular circumstances to accommodate
+	 * deployed binaries of the "tclcompiler" program
+	 *     http://sourceforge.net/projects/tclpro/
+         * that crash if the bug is fixed.
 	 */
 
 	if (cmdPtr->objProc == TclInvokeStringCommand
@@ -2363,12 +2368,15 @@ TclCreateObjCommandInNs (
 	    cmdPtr->flags |= CMD_REDEF_IN_PROGRESS;
 	}
 
-	/* Make sure namespace doesn't get deallocated. */
+	/*
+         * Make sure namespace doesn't get deallocated.
+         */
+
 	cmdPtr->nsPtr->refCount++;
 
 	Tcl_DeleteCommandFromToken(interp, (Tcl_Command) cmdPtr);
 	nsPtr = (Namespace *) TclEnsureNamespace(interp,
-	    (Tcl_Namespace *)cmdPtr->nsPtr);
+                (Tcl_Namespace *) cmdPtr->nsPtr);
 	TclNsDecrRefCount(cmdPtr->nsPtr);
 
 	if (cmdPtr->flags & CMD_REDEF_IN_PROGRESS) {
@@ -2380,9 +2388,9 @@ TclCreateObjCommandInNs (
     }
     if (!isNew) {
 	/*
-	 * If the deletion callback recreated the command, just throw away
-	 * the new command (if we try to delete it again, we could get
-	 * stuck in an infinite loop).
+	 * If the deletion callback recreated the command, just throw away the
+	 * new command (if we try to delete it again, we could get stuck in an
+	 * infinite loop).
 	 */
 
 	ckfree(Tcl_GetHashValue(hPtr));
@@ -2437,6 +2445,7 @@ TclCreateObjCommandInNs (
 	cmdPtr->importRefPtr = oldRefPtr;
 	while (oldRefPtr != NULL) {
 	    Command *refCmdPtr = oldRefPtr->importedCmdPtr;
+
 	    dataPtr = refCmdPtr->objClientData;
 	    dataPtr->realCmdPtr = cmdPtr;
 	    oldRefPtr = oldRefPtr->nextPtr;
@@ -7629,7 +7638,7 @@ ExprEntierFunc(
 
     if (type == TCL_NUMBER_DOUBLE) {
 	d = *((const double *) ptr);
-	if ((d >= (double)LONG_MAX) || (d <= (double)LONG_MIN)) {
+	if ((d >= (double)LLONG_MAX) || (d <= (double)LLONG_MIN)) {
 	    mp_int big;
 
 	    if (Tcl_InitBignumFromDouble(interp, d, &big) != TCL_OK) {
@@ -7639,9 +7648,9 @@ ExprEntierFunc(
 	    Tcl_SetObjResult(interp, Tcl_NewBignumObj(&big));
 	    return TCL_OK;
 	} else {
-	    long result = (long) d;
+	    Tcl_WideInt result = (Tcl_WideInt) d;
 
-	    Tcl_SetObjResult(interp, Tcl_NewLongObj(result));
+	    Tcl_SetObjResult(interp, Tcl_NewWideIntObj(result));
 	    return TCL_OK;
 	}
     }
@@ -8276,23 +8285,26 @@ Tcl_NRCreateCommand(
 				 * this command is deleted. */
 {
     Command *cmdPtr = (Command *)
-	    Tcl_CreateObjCommand(interp,cmdName,proc,clientData,deleteProc);
+	    Tcl_CreateObjCommand(interp, cmdName, proc, clientData,
+                    deleteProc);
 
     cmdPtr->nreProc = nreProc;
     return (Tcl_Command) cmdPtr;
 }
 
 Tcl_Command
-TclNRCreateCommandInNs (
+TclNRCreateCommandInNs(
     Tcl_Interp *interp,
     const char *cmdName,
     Tcl_Namespace *nsPtr,
     Tcl_ObjCmdProc *proc,
     Tcl_ObjCmdProc *nreProc,
     ClientData clientData,
-    Tcl_CmdDeleteProc *deleteProc) {
+    Tcl_CmdDeleteProc *deleteProc)
+{
     Command *cmdPtr = (Command *)
-	TclCreateObjCommandInNs(interp,cmdName,nsPtr,proc,clientData,deleteProc);
+            TclCreateObjCommandInNs(interp, cmdName, nsPtr, proc, clientData,
+                    deleteProc);
 
     cmdPtr->nreProc = nreProc;
     return (Tcl_Command) cmdPtr;
@@ -8396,7 +8408,6 @@ TclPushTailcallPoint(
     TclNRAddCallback(interp, NRCommand, NULL, NULL, NULL, NULL);
     ((Interp *) interp)->numLevels++;
 }
-
 
 /*
  *----------------------------------------------------------------------
@@ -8432,7 +8443,6 @@ TclSetTailcall(
     }
     runPtr->data[1] = listPtr;
 }
-
 
 /*
  *----------------------------------------------------------------------
@@ -8490,25 +8500,18 @@ TclNRTailcallObjCmd(
     if (objc > 1) {
         Tcl_Obj *listPtr, *nsObjPtr;
         Tcl_Namespace *nsPtr = (Tcl_Namespace *) iPtr->varFramePtr->nsPtr;
-        Tcl_Namespace *ns1Ptr;
 
         /* The tailcall data is in a Tcl list: the first element is the
          * namespace, the rest the command to be tailcalled. */
 
-        listPtr = Tcl_NewListObj(objc, objv);
-
         nsObjPtr = Tcl_NewStringObj(nsPtr->fullName, -1);
-        if ((TCL_OK != TclGetNamespaceFromObj(interp, nsObjPtr, &ns1Ptr))
-                || (nsPtr != ns1Ptr)) {
-            Tcl_Panic("Tailcall failed to find the proper namespace");
-        }
+        listPtr = Tcl_NewListObj(objc, objv);
  	TclListObjSetElement(interp, listPtr, 0, nsObjPtr);
 
         iPtr->varFramePtr->tailcallPtr = listPtr;
     }
     return TCL_RETURN;
 }
-
 
 /*
  *----------------------------------------------------------------------
@@ -8576,7 +8579,6 @@ TclNRReleaseValues(
     }
     return result;
 }
-
 
 void
 Tcl_NRAddCallback(

generic/tclCkalloc.c

@@ -156,7 +156,7 @@ TclInitDbCkalloc(void)
     if (!ckallocInit) {
 	ckallocInit = 1;
 	ckallocMutexPtr = Tcl_GetAllocMutex();
-#ifndef TCL_THREADS
+#if !TCL_THREADS
 	/* Silence compiler warning */
 	(void)ckallocMutexPtr;
 #endif

generic/tclCmdAH.c

@@ -513,63 +513,6 @@ Tcl_ContinueObjCmd(
     return TCL_CONTINUE;
 }
 
-/*
- *----------------------------------------------------------------------
- *
- * Tcl_EncodingObjCmd --
- *
- *	This command manipulates encodings.
- *
- * Results:
- *	A standard Tcl result.
- *
- * Side effects:
- *	See the user documentation.
- *
- *----------------------------------------------------------------------
- */
-
-int
-Tcl_EncodingObjCmd(
-    ClientData dummy,		/* Not used. */
-    Tcl_Interp *interp,		/* Current interpreter. */
-    int objc,			/* Number of arguments. */
-    Tcl_Obj *const objv[])	/* Argument objects. */
-{
-    int index;
-
-    static const char *const optionStrings[] = {
-	"convertfrom", "convertto", "dirs", "names", "system",
-	NULL
-    };
-    enum options {
-	ENC_CONVERTFROM, ENC_CONVERTTO, ENC_DIRS, ENC_NAMES, ENC_SYSTEM
-    };
-
-    if (objc < 2) {
-	Tcl_WrongNumArgs(interp, 1, objv, "option ?arg ...?");
-	return TCL_ERROR;
-    }
-    if (Tcl_GetIndexFromObj(interp, objv[1], optionStrings, "option", 0,
-	    &index) != TCL_OK) {
-	return TCL_ERROR;
-    }
-
-    switch ((enum options) index) {
-    case ENC_CONVERTTO:
-	return EncodingConverttoObjCmd(dummy, interp, objc, objv);
-    case ENC_CONVERTFROM:
-	return EncodingConvertfromObjCmd(dummy, interp, objc, objv);
-    case ENC_DIRS:
-	return EncodingDirsObjCmd(dummy, interp, objc, objv);
-    case ENC_NAMES:
-	return EncodingNamesObjCmd(dummy, interp, objc, objv);
-    case ENC_SYSTEM:
-	return EncodingSystemObjCmd(dummy, interp, objc, objv);
-    }
-    return TCL_OK;
-}
-
 /*
  *-----------------------------------------------------------------------------
  *

generic/tclCmdIL.c

@@ -3333,7 +3333,7 @@ Tcl_LsearchObjCmd(
 	 * sense in doing this when the match sense is inverted.
 	 */
 
-	/* 
+	/*
 	 * With -stride, lower, upper and i are kept as multiples of groupSize.
 	 */
 
@@ -4015,7 +4015,7 @@ Tcl_LsortObjCmd(
 		/*
 		 * Do not shrink the actual memory block used; that doesn't
 		 * work with TclStackAlloc-allocated memory. [Bug 2918962]
-		 * 
+		 *
 		 * TODO: Consider a pointer increment to replace this
 		 * array shift.
 		 */

generic/tclCmdMZ.c

@@ -597,9 +597,9 @@ Tcl_RegsubObjCmd(
 	 * slightly modified version of the one pair STR_MAP code.
 	 */
 
-	int slen, nocase;
+	int slen, nocase, wsrclc;
 	int (*strCmpFn)(const Tcl_UniChar*,const Tcl_UniChar*,unsigned long);
-	Tcl_UniChar *p, wsrclc;
+	Tcl_UniChar *p;
 
 	numMatches = 0;
 	nocase = (cflags & TCL_REG_NOCASE);
@@ -1447,6 +1447,9 @@ StringIndexCmd(
 	    char buf[4];
 
 	    length = Tcl_UniCharToUtf(ch, buf);
+	    if (!length) {
+		length = Tcl_UniCharToUtf(-1, buf);
+	    }
 	    Tcl_SetObjResult(interp, Tcl_NewStringObj(buf, length));
 	}
     }
@@ -2001,8 +2004,8 @@ StringMapCmd(
 	 * larger strings.
 	 */
 
-	int mapLen;
-	Tcl_UniChar *mapString, u2lc;
+	int mapLen, u2lc;
+	Tcl_UniChar *mapString;
 
 	ustring2 = Tcl_GetUnicodeFromObj(mapElemv[0], &length2);
 	p = ustring1;
@@ -2033,8 +2036,8 @@ StringMapCmd(
 	    }
 	}
     } else {
-	Tcl_UniChar **mapStrings, *u2lc = NULL;
-	int *mapLens;
+	Tcl_UniChar **mapStrings;
+	int *mapLens, *u2lc = NULL;
 
 	/*
 	 * Precompute pointers to the unicode string and length. This saves us
@@ -2046,7 +2049,7 @@ StringMapCmd(
 	mapStrings = TclStackAlloc(interp, mapElemc*2*sizeof(Tcl_UniChar *));
 	mapLens = TclStackAlloc(interp, mapElemc * 2 * sizeof(int));
 	if (nocase) {
-	    u2lc = TclStackAlloc(interp, mapElemc * sizeof(Tcl_UniChar));
+	    u2lc = TclStackAlloc(interp, mapElemc * sizeof(int));
 	}
 	for (index = 0; index < mapElemc; index++) {
 	    mapStrings[index] = Tcl_GetUnicodeFromObj(mapElemv[index],
@@ -2546,10 +2549,8 @@ StringEqualCmd(
      * the expr string comparison in INST_EQ/INST_NEQ/INST_LT/...).
      */
 
-    const char *string1, *string2;
-    int length1, length2, i, match, length, nocase = 0, reqlength = -1;
-    typedef int (*strCmpFn_t)(const char *, const char *, unsigned int);
-    strCmpFn_t strCmpFn;
+    const char *string2;
+    int length, i, match, nocase = 0, reqlength = -1;
 
     if (objc < 3 || objc > 6) {
     str_cmp_args:
@@ -2559,11 +2560,11 @@ StringEqualCmd(
     }
 
     for (i = 1; i < objc-2; i++) {
-	string2 = TclGetStringFromObj(objv[i], &length2);
-	if ((length2 > 1) && !strncmp(string2, "-nocase", (size_t)length2)) {
+	string2 = TclGetStringFromObj(objv[i], &length);
+	if ((length > 1) && !strncmp(string2, "-nocase", (size_t)length)) {
 	    nocase = 1;
-	} else if ((length2 > 1)
-		&& !strncmp(string2, "-length", (size_t)length2)) {
+	} else if ((length > 1)
+		&& !strncmp(string2, "-length", (size_t)length)) {
 	    if (i+1 >= objc-2) {
 		goto str_cmp_args;
 	    }
@@ -2588,78 +2589,7 @@ StringEqualCmd(
 
     objv += objc-2;
 
-    if ((reqlength == 0) || (objv[0] == objv[1])) {
-	/*
-	 * Always match at 0 chars of if it is the same obj.
-	 */
-
-	Tcl_SetObjResult(interp, Tcl_NewBooleanObj(1));
-	return TCL_OK;
-    }
-
-    if (!nocase && TclIsPureByteArray(objv[0]) &&
-	    TclIsPureByteArray(objv[1])) {
-	/*
-	 * Use binary versions of comparisons since that won't cause undue
-	 * type conversions and it is much faster. Only do this if we're
-	 * case-sensitive (which is all that really makes sense with byte
-	 * arrays anyway, and we have no memcasecmp() for some reason... :^)
-	 */
-
-	string1 = (char *) Tcl_GetByteArrayFromObj(objv[0], &length1);
-	string2 = (char *) Tcl_GetByteArrayFromObj(objv[1], &length2);
-	strCmpFn = (strCmpFn_t) memcmp;
-    } else if ((objv[0]->typePtr == &tclStringType)
-	    && (objv[1]->typePtr == &tclStringType)) {
-	/*
-	 * Do a unicode-specific comparison if both of the args are of String
-	 * type. In benchmark testing this proved the most efficient check
-	 * between the unicode and string comparison operations.
-	 */
-
-	string1 = (char *) Tcl_GetUnicodeFromObj(objv[0], &length1);
-	string2 = (char *) Tcl_GetUnicodeFromObj(objv[1], &length2);
-	strCmpFn = (strCmpFn_t)
-		(nocase ? Tcl_UniCharNcasecmp : Tcl_UniCharNcmp);
-    } else {
-	/*
-	 * As a catch-all we will work with UTF-8. We cannot use memcmp() as
-	 * that is unsafe with any string containing NUL (\xC0\x80 in Tcl's
-	 * utf rep). We can use the more efficient TclpUtfNcmp2 if we are
-	 * case-sensitive and no specific length was requested.
-	 */
-
-	string1 = (char *) TclGetStringFromObj(objv[0], &length1);
-	string2 = (char *) TclGetStringFromObj(objv[1], &length2);
-	if ((reqlength < 0) && !nocase) {
-	    strCmpFn = (strCmpFn_t) TclpUtfNcmp2;
-	} else {
-	    length1 = Tcl_NumUtfChars(string1, length1);
-	    length2 = Tcl_NumUtfChars(string2, length2);
-	    strCmpFn = (strCmpFn_t) (nocase ? Tcl_UtfNcasecmp : Tcl_UtfNcmp);
-	}
-    }
-
-    if ((reqlength < 0) && (length1 != length2)) {
-	match = 1;		/* This will be reversed below. */
-    } else {
-	length = (length1 < length2) ? length1 : length2;
-	if (reqlength > 0 && reqlength < length) {
-	    length = reqlength;
-	} else if (reqlength < 0) {
-	    /*
-	     * The requested length is negative, so we ignore it by setting it
-	     * to length + 1 so we correct the match var.
-	     */
-
-	    reqlength = length + 1;
-	}
-
-	match = strCmpFn(string1, string2, (unsigned) length);
-	if ((match == 0) && (reqlength > length)) {
-	    match = length1 - length2;
-	}
-    }
+    match = TclStringCmp(objv[0], objv[1], 0, nocase, reqlength);
 
     Tcl_SetObjResult(interp, Tcl_NewBooleanObj(match ? 0 : 1));
     return TCL_OK;
@@ -2696,11 +2626,31 @@ StringCmpCmd(
      * the expr string comparison in INST_EQ/INST_NEQ/INST_LT/...).
      */
 
-    const char *string1, *string2;
-    int length1, length2, i, match, length, nocase = 0, reqlength = -1;
-    typedef int (*strCmpFn_t)(const char *, const char *, unsigned int);
-    strCmpFn_t strCmpFn;
+    int match, nocase, reqlength, status;
 
+    status = TclStringCmpOpts(interp, objc, objv, &nocase, &reqlength);
+    if (status != TCL_OK) {
+	return status;
+    }
+
+    objv += objc-2;
+    match = TclStringCmp(objv[0], objv[1], 0, nocase, reqlength);
+    Tcl_SetObjResult(interp, Tcl_NewIntObj(match));
+    return TCL_OK;
+}
+
+int TclStringCmpOpts(
+    Tcl_Interp *interp,		/* Current interpreter. */
+    int objc,			/* Number of arguments. */
+    Tcl_Obj *const objv[],	/* Argument objects. */
+    int *nocase,
+    int *reqlength)
+{
+    int i, length;
+    const char *string;
+
+    *reqlength = -1;
+    *nocase = 0;
     if (objc < 3 || objc > 6) {
     str_cmp_args:
 	Tcl_WrongNumArgs(interp, 1, objv,
@@ -2709,106 +2659,27 @@ StringCmpCmd(
     }
 
     for (i = 1; i < objc-2; i++) {
-	string2 = TclGetStringFromObj(objv[i], &length2);
-	if ((length2 > 1) && !strncmp(string2, "-nocase", (size_t)length2)) {
-	    nocase = 1;
-	} else if ((length2 > 1)
-		&& !strncmp(string2, "-length", (size_t)length2)) {
+	string = TclGetStringFromObj(objv[i], &length);
+	if ((length > 1) && !strncmp(string, "-nocase", (size_t)length)) {
+	    *nocase = 1;
+	} else if ((length > 1)
+		&& !strncmp(string, "-length", (size_t)length)) {
 	    if (i+1 >= objc-2) {
 		goto str_cmp_args;
 	    }
 	    i++;
-	    if (TclGetIntFromObj(interp, objv[i], &reqlength) != TCL_OK) {
+	    if (TclGetIntFromObj(interp, objv[i], reqlength) != TCL_OK) {
 		return TCL_ERROR;
 	    }
 	} else {
 	    Tcl_SetObjResult(interp, Tcl_ObjPrintf(
 		    "bad option \"%s\": must be -nocase or -length",
-		    string2));
+		    string));
 	    Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "INDEX", "option",
-		    string2, NULL);
+		    string, NULL);
 	    return TCL_ERROR;
 	}
     }
-
-    /*
-     * From now on, we only access the two objects at the end of the argument
-     * array.
-     */
-
-    objv += objc-2;
-
-    if ((reqlength == 0) || (objv[0] == objv[1])) {
-	/*
-	 * Always match at 0 chars of if it is the same obj.
-	 */
-
-	Tcl_SetObjResult(interp, Tcl_NewBooleanObj(0));
-	return TCL_OK;
-    }
-
-    if (!nocase && TclIsPureByteArray(objv[0]) &&
-	    TclIsPureByteArray(objv[1])) {
-	/*
-	 * Use binary versions of comparisons since that won't cause undue
-	 * type conversions and it is much faster. Only do this if we're
-	 * case-sensitive (which is all that really makes sense with byte
-	 * arrays anyway, and we have no memcasecmp() for some reason... :^)
-	 */
-
-	string1 = (char *) Tcl_GetByteArrayFromObj(objv[0], &length1);
-	string2 = (char *) Tcl_GetByteArrayFromObj(objv[1], &length2);
-	strCmpFn = (strCmpFn_t) memcmp;
-    } else if ((objv[0]->typePtr == &tclStringType)
-	    && (objv[1]->typePtr == &tclStringType)) {
-	/*
-	 * Do a unicode-specific comparison if both of the args are of String
-	 * type. In benchmark testing this proved the most efficient check
-	 * between the unicode and string comparison operations.
-	 */
-
-	string1 = (char *) Tcl_GetUnicodeFromObj(objv[0], &length1);
-	string2 = (char *) Tcl_GetUnicodeFromObj(objv[1], &length2);
-	strCmpFn = (strCmpFn_t)
-		(nocase ? Tcl_UniCharNcasecmp : Tcl_UniCharNcmp);
-    } else {
-	/*
-	 * As a catch-all we will work with UTF-8. We cannot use memcmp() as
-	 * that is unsafe with any string containing NUL (\xC0\x80 in Tcl's
-	 * utf rep). We can use the more efficient TclpUtfNcmp2 if we are
-	 * case-sensitive and no specific length was requested.
-	 */
-
-	string1 = (char *) TclGetStringFromObj(objv[0], &length1);
-	string2 = (char *) TclGetStringFromObj(objv[1], &length2);
-	if ((reqlength < 0) && !nocase) {
-	    strCmpFn = (strCmpFn_t) TclpUtfNcmp2;
-	} else {
-	    length1 = Tcl_NumUtfChars(string1, length1);
-	    length2 = Tcl_NumUtfChars(string2, length2);
-	    strCmpFn = (strCmpFn_t) (nocase ? Tcl_UtfNcasecmp : Tcl_UtfNcmp);
-	}
-    }
-
-    length = (length1 < length2) ? length1 : length2;
-    if (reqlength > 0 && reqlength < length) {
-	length = reqlength;
-    } else if (reqlength < 0) {
-	/*
-	 * The requested length is negative, so we ignore it by setting it to
-	 * length + 1 so we correct the match var.
-	 */
-
-	reqlength = length + 1;
-    }
-
-    match = strCmpFn(string1, string2, (unsigned) length);
-    if ((match == 0) && (reqlength > length)) {
-	match = length1 - length2;
-    }
-
-    Tcl_SetObjResult(interp,
-	    Tcl_NewIntObj((match > 0) ? 1 : (match < 0) ? -1 : 0));
     return TCL_OK;
 }
 

generic/tclCompCmdsGR.c

@@ -27,7 +27,6 @@ static void		CompileReturnInternal(CompileEnv *envPtr,
 			    Tcl_Obj *returnOpts);
 static int		IndexTailVarIfKnown(Tcl_Interp *interp,
 			    Tcl_Token *varTokenPtr, CompileEnv *envPtr);
-
 
 /*
  *----------------------------------------------------------------------
@@ -35,7 +34,7 @@ static int		IndexTailVarIfKnown(Tcl_Interp *interp,
  * TclGetIndexFromToken --
  *
  *	Parse a token to determine if an index value is known at
- *	compile time. 
+ *	compile time.
  *
  * Returns:
  *	TCL_OK if parsing succeeded, and TCL_ERROR if it failed.
@@ -127,9 +126,12 @@ TclCompileGlobalCmd(
 	    return TCL_ERROR;
 	}
 
-	/* TODO: Consider what value can pass through the
-	 * IndexTailVarIfKnown() screen.  Full CompileWord()
-	 * likely does not apply here.  Push known value instead. */
+	/*
+	 * TODO: Consider what value can pass through the
+	 * IndexTailVarIfKnown() screen. Full CompileWord() likely does not
+	 * apply here. Push known value instead.
+	 */
+
 	CompileWord(envPtr, varTokenPtr, interp, i);
 	TclEmitInstInt4(	INST_NSUPVAR, localIndex,	envPtr);
     }
@@ -270,7 +272,7 @@ TclCompileIfCmd(
 		jumpIndex = jumpFalseFixupArray.next;
 		jumpFalseFixupArray.next++;
 		TclEmitForwardJump(envPtr, TCL_FALSE_JUMP,
-			jumpFalseFixupArray.fixup+jumpIndex);
+			jumpFalseFixupArray.fixup + jumpIndex);
 	    }
 	    code = TCL_OK;
 	}
@@ -317,7 +319,7 @@ TclCompileIfCmd(
 	    }
 	    jumpEndFixupArray.next++;
 	    TclEmitForwardJump(envPtr, TCL_UNCONDITIONAL_JUMP,
-		    jumpEndFixupArray.fixup+jumpIndex);
+		    jumpEndFixupArray.fixup + jumpIndex);
 
 	    /*
 	     * Fix the target of the jumpFalse after the test. Generate a 4
@@ -329,7 +331,7 @@ TclCompileIfCmd(
 
 	    TclAdjustStackDepth(-1, envPtr);
 	    if (TclFixupForwardJumpToHere(envPtr,
-		    jumpFalseFixupArray.fixup+jumpIndex, 120)) {
+		    jumpFalseFixupArray.fixup + jumpIndex, 120)) {
 		/*
 		 * Adjust the code offset for the proceeding jump to the end
 		 * of the "if" command.
@@ -412,7 +414,7 @@ TclCompileIfCmd(
     for (j = jumpEndFixupArray.next;  j > 0;  j--) {
 	jumpIndex = (j - 1);	/* i.e. process the closest jump first. */
 	if (TclFixupForwardJumpToHere(envPtr,
-		jumpEndFixupArray.fixup+jumpIndex, 127)) {
+		jumpEndFixupArray.fixup + jumpIndex, 127)) {
 	    /*
 	     * Adjust the immediately preceeding "ifFalse" jump. We moved it's
 	     * target (just after this jump) down three bytes.
@@ -920,7 +922,7 @@ TclCompileLappendCmd(
 	CompileWord(envPtr, valueTokenPtr, interp, i);
 	valueTokenPtr = TokenAfter(valueTokenPtr);
     }
-    TclEmitInstInt4(	    INST_LIST, numWords-2,		envPtr);
+    TclEmitInstInt4(	    INST_LIST, numWords - 2,		envPtr);
     if (isScalar) {
 	if (localIndex < 0) {
 	    TclEmitOpcode(  INST_LAPPEND_LIST_STK,		envPtr);
@@ -997,7 +999,7 @@ TclCompileLassignCmd(
 	 */
 
 	PushVarNameWord(interp, tokenPtr, envPtr, 0, &localIndex,
-		&isScalar, idx+2);
+		&isScalar, idx + 2);
 
 	/*
 	 * Emit instructions to get the idx'th item out of the list value on
@@ -1414,7 +1416,7 @@ TclCompileLinsertCmd(
 	tokenPtr = TokenAfter(tokenPtr);
 	CompileWord(envPtr, tokenPtr, interp, i);
     }
-    TclEmitInstInt4(		INST_LIST, i-3,			envPtr);
+    TclEmitInstInt4(		INST_LIST, i - 3,		envPtr);
 
     if (idx == TCL_INDEX_START) {
 	TclEmitInstInt4(	INST_REVERSE, 2,		envPtr);
@@ -1439,7 +1441,7 @@ TclCompileLinsertCmd(
 	}
 	TclEmitInstInt4(	INST_OVER, 1,			envPtr);
 	TclEmitInstInt4(	INST_LIST_RANGE_IMM, 0,		envPtr);
-	TclEmitInt4(			idx-1,			envPtr);
+	TclEmitInt4(			idx - 1,		envPtr);
 	TclEmitInstInt4(	INST_REVERSE, 3,		envPtr);
 	TclEmitInstInt4(	INST_LIST_RANGE_IMM, idx,	envPtr);
 	TclEmitInt4(			TCL_INDEX_END,		envPtr);
@@ -1551,7 +1553,7 @@ TclCompileLreplaceCmd(
 
 	emptyPrefix = 0;
     }
-     
+
     /*
      * [lreplace] raises an error when idx1 points after the list, but
      * only when the list is not empty. This is maximum stupidity.
@@ -2234,7 +2236,7 @@ TclCompileRegexpCmd(
     }
 
     if (!simple) {
-	CompileWord(envPtr, varTokenPtr, interp, parsePtr->numWords-2);
+	CompileWord(envPtr, varTokenPtr, interp, parsePtr->numWords - 2);
     }
 
     /*
@@ -2242,7 +2244,7 @@ TclCompileRegexpCmd(
      */
 
     varTokenPtr = TokenAfter(varTokenPtr);
-    CompileWord(envPtr, varTokenPtr, interp, parsePtr->numWords-1);
+    CompileWord(envPtr, varTokenPtr, interp, parsePtr->numWords - 1);
 
     if (simple) {
 	if (exact && !nocase) {
@@ -2426,7 +2428,7 @@ TclCompileRegsubCmd(
     PushLiteral(envPtr,	bytes, len);
     bytes = TclGetStringFromObj(replacementObj, &len);
     PushLiteral(envPtr,	bytes, len);
-    CompileWord(envPtr,	stringTokenPtr, interp, parsePtr->numWords-2);
+    CompileWord(envPtr,	stringTokenPtr, interp, parsePtr->numWords - 2);
     TclEmitOpcode(	INST_STR_MAP,	envPtr);
 
   done:
@@ -2555,7 +2557,7 @@ TclCompileReturnCmd(
      */
 
     if (explicitResult) {
-	 CompileWord(envPtr, wordTokenPtr, interp, numWords-1);
+	 CompileWord(envPtr, wordTokenPtr, interp, numWords - 1);
     } else {
 	/*
 	 * No explict result argument, so default result is empty string.
@@ -2633,7 +2635,7 @@ TclCompileReturnCmd(
      */
 
     if (explicitResult) {
-	CompileWord(envPtr, wordTokenPtr, interp, numWords-1);
+	CompileWord(envPtr, wordTokenPtr, interp, numWords - 1);
     } else {
 	PushStringLiteral(envPtr, "");
     }
@@ -2864,12 +2866,12 @@ TclCompileVariableCmd(
 	CompileWord(envPtr, varTokenPtr, interp, i);
 	TclEmitInstInt4(	INST_VARIABLE, localIndex,	envPtr);
 
-	if (i+1 < numWords) {
+	if (i + 1 < numWords) {
 	    /*
 	     * A value has been given: set the variable, pop the value
 	     */
 
-	    CompileWord(envPtr, valueTokenPtr, interp, i+1);
+	    CompileWord(envPtr, valueTokenPtr, interp, i + 1);
 	    Emit14Inst(		INST_STORE_SCALAR, localIndex,	envPtr);
 	    TclEmitOpcode(	INST_POP,			envPtr);
 	}
@@ -2945,7 +2947,7 @@ IndexTailVarIfKnown(
     tailName = TclGetStringFromObj(tailPtr, &len);
 
     if (len) {
-	if (*(tailName+len-1) == ')') {
+	if (*(tailName + len - 1) == ')') {
 	    /*
 	     * Possible array: bail out
 	     */
@@ -2959,7 +2961,7 @@ IndexTailVarIfKnown(
 	 */
 
 	for (p = tailName + len -1; p > tailName; p--) {
-	    if ((*p == ':') && (*(p-1) == ':')) {
+	    if ((*p == ':') && (*(p - 1) == ':')) {
 		p++;
 		break;
 	    }

generic/tclCompCmdsSZ.c

@@ -1002,13 +1002,13 @@ TclCompileStringReplaceCmd(
     if (parsePtr->numWords < 4 || parsePtr->numWords > 5) {
 	return TCL_ERROR;
     }
- 
+
     /* Bytecode to compute/push string argument being replaced */
     valueTokenPtr = TokenAfter(parsePtr->tokenPtr);
     CompileWord(envPtr, valueTokenPtr, interp, 1);
 
     /*
-     * Check for first index known and useful at compile time. 
+     * Check for first index known and useful at compile time.
      */
     tokenPtr = TokenAfter(valueTokenPtr);
     if (TclGetIndexFromToken(tokenPtr, TCL_INDEX_BEFORE, TCL_INDEX_AFTER,
@@ -1017,7 +1017,7 @@ TclCompileStringReplaceCmd(
     }
 
     /*
-     * Check for last index known and useful at compile time. 
+     * Check for last index known and useful at compile time.
      */
     tokenPtr = TokenAfter(tokenPtr);
     if (TclGetIndexFromToken(tokenPtr, TCL_INDEX_BEFORE, TCL_INDEX_AFTER,
@@ -1025,7 +1025,7 @@ TclCompileStringReplaceCmd(
 	goto genericReplace;
     }
 
-    /* 
+    /*
      * [string replace] is an odd bird.  For many arguments it is
      * a conventional substring replacer.  However it also goes out
      * of its way to become a no-op for many cases where it would be
@@ -1108,12 +1108,12 @@ TclCompileStringReplaceCmd(
      * Finally we need, third:
      *
      *		(first <= last)
-     * 
+     *
      * Considered in combination with the constraints we already have,
      * we see that we can proceed when (first == TCL_INDEX_BEFORE)
      * or (last == TCL_INDEX_AFTER). These also permit simplification
      * of the prefix|replace|suffix construction. The other constraints,
-     * though, interfere with getting a guarantee that first <= last. 
+     * though, interfere with getting a guarantee that first <= last.
      */
 
     if ((first == TCL_INDEX_BEFORE) && (last >= TCL_INDEX_START)) {
@@ -1141,7 +1141,7 @@ TclCompileStringReplaceCmd(
 	/* FLOW THROUGH TO genericReplace */
 
     } else {
-	/* 
+	/*
 	 * When we have no replacement string to worry about, we may
 	 * have more luck, because the forbidden empty string replacements
 	 * are harmless when they are replaced by another empty string.

generic/tclDate.c

@@ -1348,7 +1348,7 @@ yyparse (info)
 int yychar;
 
 /* The semantic value of the look-ahead symbol.  */
-YYSTYPE yylval;
+YYSTYPE yylval = {0};
 
 /* Number of syntax errors so far.  */
 int yynerrs;

generic/tclDecls.h

@@ -119,7 +119,8 @@ EXTERN void		Tcl_DbIncrRefCount(Tcl_Obj *objPtr, const char *file,
 EXTERN int		Tcl_DbIsShared(Tcl_Obj *objPtr, const char *file,
 				int line);
 /* 22 */
-EXTERN Tcl_Obj *	Tcl_DbNewBooleanObj(int boolValue, const char *file,
+TCL_DEPRECATED("No longer in use, changed to macro")
+Tcl_Obj *		Tcl_DbNewBooleanObj(int boolValue, const char *file,
 				int line);
 /* 23 */
 EXTERN Tcl_Obj *	Tcl_DbNewByteArrayObj(const unsigned char *bytes,
@@ -131,7 +132,8 @@ EXTERN Tcl_Obj *	Tcl_DbNewDoubleObj(double doubleValue,
 EXTERN Tcl_Obj *	Tcl_DbNewListObj(int objc, Tcl_Obj *const *objv,
 				const char *file, int line);
 /* 26 */
-EXTERN Tcl_Obj *	Tcl_DbNewLongObj(long longValue, const char *file,
+TCL_DEPRECATED("No longer in use, changed to macro")
+Tcl_Obj *		Tcl_DbNewLongObj(long longValue, const char *file,
 				int line);
 /* 27 */
 EXTERN Tcl_Obj *	Tcl_DbNewObj(const char *file, int line);
@@ -158,7 +160,8 @@ EXTERN int		Tcl_GetDouble(Tcl_Interp *interp, const char *src,
 EXTERN int		Tcl_GetDoubleFromObj(Tcl_Interp *interp,
 				Tcl_Obj *objPtr, double *doublePtr);
 /* 36 */
-EXTERN int		Tcl_GetIndexFromObj(Tcl_Interp *interp,
+TCL_DEPRECATED("No longer in use, changed to macro")
+int			Tcl_GetIndexFromObj(Tcl_Interp *interp,
 				Tcl_Obj *objPtr, const char *const *tablePtr,
 				const char *msg, int flags, int *indexPtr);
 /* 37 */
@@ -198,24 +201,28 @@ EXTERN int		Tcl_ListObjReplace(Tcl_Interp *interp,
 				Tcl_Obj *listPtr, int first, int count,
 				int objc, Tcl_Obj *const objv[]);
 /* 49 */
-EXTERN Tcl_Obj *	Tcl_NewBooleanObj(int boolValue);
+TCL_DEPRECATED("No longer in use, changed to macro")
+Tcl_Obj *		Tcl_NewBooleanObj(int boolValue);
 /* 50 */
 EXTERN Tcl_Obj *	Tcl_NewByteArrayObj(const unsigned char *bytes,
 				int length);
 /* 51 */
 EXTERN Tcl_Obj *	Tcl_NewDoubleObj(double doubleValue);
 /* 52 */
-EXTERN Tcl_Obj *	Tcl_NewIntObj(int intValue);
+TCL_DEPRECATED("No longer in use, changed to macro")
+Tcl_Obj *		Tcl_NewIntObj(int intValue);
 /* 53 */
 EXTERN Tcl_Obj *	Tcl_NewListObj(int objc, Tcl_Obj *const objv[]);
 /* 54 */
-EXTERN Tcl_Obj *	Tcl_NewLongObj(long longValue);
+TCL_DEPRECATED("No longer in use, changed to macro")
+Tcl_Obj *		Tcl_NewLongObj(long longValue);
 /* 55 */
 EXTERN Tcl_Obj *	Tcl_NewObj(void);
 /* 56 */
 EXTERN Tcl_Obj *	Tcl_NewStringObj(const char *bytes, int length);
 /* 57 */
-EXTERN void		Tcl_SetBooleanObj(Tcl_Obj *objPtr, int boolValue);
+TCL_DEPRECATED("No longer in use, changed to macro")
+void			Tcl_SetBooleanObj(Tcl_Obj *objPtr, int boolValue);
 /* 58 */
 EXTERN unsigned char *	Tcl_SetByteArrayLength(Tcl_Obj *objPtr, int length);
 /* 59 */
@@ -224,22 +231,26 @@ EXTERN void		Tcl_SetByteArrayObj(Tcl_Obj *objPtr,
 /* 60 */
 EXTERN void		Tcl_SetDoubleObj(Tcl_Obj *objPtr, double doubleValue);
 /* 61 */
-EXTERN void		Tcl_SetIntObj(Tcl_Obj *objPtr, int intValue);
+TCL_DEPRECATED("No longer in use, changed to macro")
+void			Tcl_SetIntObj(Tcl_Obj *objPtr, int intValue);
 /* 62 */
 EXTERN void		Tcl_SetListObj(Tcl_Obj *objPtr, int objc,
 				Tcl_Obj *const objv[]);
 /* 63 */
-EXTERN void		Tcl_SetLongObj(Tcl_Obj *objPtr, long longValue);
+TCL_DEPRECATED("No longer in use, changed to macro")
+void			Tcl_SetLongObj(Tcl_Obj *objPtr, long longValue);
 /* 64 */
 EXTERN void		Tcl_SetObjLength(Tcl_Obj *objPtr, int length);
 /* 65 */
 EXTERN void		Tcl_SetStringObj(Tcl_Obj *objPtr, const char *bytes,
 				int length);
 /* 66 */
-EXTERN void		Tcl_AddErrorInfo(Tcl_Interp *interp,
+TCL_DEPRECATED("No longer in use, changed to macro")
+void			Tcl_AddErrorInfo(Tcl_Interp *interp,
 				const char *message);
 /* 67 */
-EXTERN void		Tcl_AddObjErrorInfo(Tcl_Interp *interp,
+TCL_DEPRECATED("No longer in use, changed to macro")
+void			Tcl_AddObjErrorInfo(Tcl_Interp *interp,
 				const char *message, int length);
 /* 68 */
 EXTERN void		Tcl_AllowExceptions(Tcl_Interp *interp);
@@ -422,7 +433,8 @@ EXTERN int		Tcl_Eval(Tcl_Interp *interp, const char *script);
 EXTERN int		Tcl_EvalFile(Tcl_Interp *interp,
 				const char *fileName);
 /* 131 */
-EXTERN int		Tcl_EvalObj(Tcl_Interp *interp, Tcl_Obj *objPtr);
+TCL_DEPRECATED("No longer in use, changed to macro")
+int			Tcl_EvalObj(Tcl_Interp *interp, Tcl_Obj *objPtr);
 /* 132 */
 EXTERN void		Tcl_EventuallyFree(ClientData clientData,
 				Tcl_FreeProc *freeProc);
@@ -549,7 +561,8 @@ EXTERN Tcl_Channel	Tcl_GetStdChannel(int type);
 /* 174 */
 EXTERN const char *	Tcl_GetStringResult(Tcl_Interp *interp);
 /* 175 */
-EXTERN const char *	Tcl_GetVar(Tcl_Interp *interp, const char *varName,
+TCL_DEPRECATED("No longer in use, changed to macro")
+const char *		Tcl_GetVar(Tcl_Interp *interp, const char *varName,
 				int flags);
 /* 176 */
 EXTERN const char *	Tcl_GetVar2(Tcl_Interp *interp, const char *part1,
@@ -558,7 +571,8 @@ EXTERN const char *	Tcl_GetVar2(Tcl_Interp *interp, const char *part1,
 EXTERN int		Tcl_GlobalEval(Tcl_Interp *interp,
 				const char *command);
 /* 178 */
-EXTERN int		Tcl_GlobalEvalObj(Tcl_Interp *interp,
+TCL_DEPRECATED("No longer in use, changed to macro")
+int			Tcl_GlobalEvalObj(Tcl_Interp *interp,
 				Tcl_Obj *objPtr);
 /* 179 */
 EXTERN int		Tcl_HideCommand(Tcl_Interp *interp,
@@ -713,7 +727,8 @@ EXTERN void		Tcl_SetObjResult(Tcl_Interp *interp,
 /* 236 */
 EXTERN void		Tcl_SetStdChannel(Tcl_Channel channel, int type);
 /* 237 */
-EXTERN const char *	Tcl_SetVar(Tcl_Interp *interp, const char *varName,
+TCL_DEPRECATED("No longer in use, changed to macro")
+const char *		Tcl_SetVar(Tcl_Interp *interp, const char *varName,
 				const char *newValue, int flags);
 /* 238 */
 EXTERN const char *	Tcl_SetVar2(Tcl_Interp *interp, const char *part1,
@@ -743,7 +758,8 @@ EXTERN int		Tcl_StringMatch(const char *str, const char *pattern);
 TCL_DEPRECATED("")
 int			Tcl_TellOld(Tcl_Channel chan);
 /* 247 */
-EXTERN int		Tcl_TraceVar(Tcl_Interp *interp, const char *varName,
+TCL_DEPRECATED("No longer in use, changed to macro")
+int			Tcl_TraceVar(Tcl_Interp *interp, const char *varName,
 				int flags, Tcl_VarTraceProc *proc,
 				ClientData clientData);
 /* 248 */
@@ -764,13 +780,15 @@ EXTERN void		Tcl_UnlinkVar(Tcl_Interp *interp,
 EXTERN int		Tcl_UnregisterChannel(Tcl_Interp *interp,
 				Tcl_Channel chan);
 /* 253 */
-EXTERN int		Tcl_UnsetVar(Tcl_Interp *interp, const char *varName,
+TCL_DEPRECATED("No longer in use, changed to macro")
+int			Tcl_UnsetVar(Tcl_Interp *interp, const char *varName,
 				int flags);
 /* 254 */
 EXTERN int		Tcl_UnsetVar2(Tcl_Interp *interp, const char *part1,
 				const char *part2, int flags);
 /* 255 */
-EXTERN void		Tcl_UntraceVar(Tcl_Interp *interp,
+TCL_DEPRECATED("No longer in use, changed to macro")
+void			Tcl_UntraceVar(Tcl_Interp *interp,
 				const char *varName, int flags,
 				Tcl_VarTraceProc *proc,
 				ClientData clientData);
@@ -783,7 +801,8 @@ EXTERN void		Tcl_UntraceVar2(Tcl_Interp *interp,
 EXTERN void		Tcl_UpdateLinkedVar(Tcl_Interp *interp,
 				const char *varName);
 /* 258 */
-EXTERN int		Tcl_UpVar(Tcl_Interp *interp, const char *frameName,
+TCL_DEPRECATED("No longer in use, changed to macro")
+int			Tcl_UpVar(Tcl_Interp *interp, const char *frameName,
 				const char *varName, const char *localName,
 				int flags);
 /* 259 */
@@ -793,7 +812,8 @@ EXTERN int		Tcl_UpVar2(Tcl_Interp *interp, const char *frameName,
 /* 260 */
 EXTERN int		Tcl_VarEval(Tcl_Interp *interp, ...);
 /* 261 */
-EXTERN ClientData	Tcl_VarTraceInfo(Tcl_Interp *interp,
+TCL_DEPRECATED("No longer in use, changed to macro")
+ClientData		Tcl_VarTraceInfo(Tcl_Interp *interp,
 				const char *varName, int flags,
 				Tcl_VarTraceProc *procPtr,
 				ClientData prevClientData);
@@ -825,17 +845,20 @@ EXTERN char *		Tcl_HashStats(Tcl_HashTable *tablePtr);
 EXTERN const char *	Tcl_ParseVar(Tcl_Interp *interp, const char *start,
 				const char **termPtr);
 /* 271 */
-EXTERN const char *	Tcl_PkgPresent(Tcl_Interp *interp, const char *name,
+TCL_DEPRECATED("No longer in use, changed to macro")
+const char *		Tcl_PkgPresent(Tcl_Interp *interp, const char *name,
 				const char *version, int exact);
 /* 272 */
 EXTERN const char *	Tcl_PkgPresentEx(Tcl_Interp *interp,
 				const char *name, const char *version,
 				int exact, void *clientDataPtr);
 /* 273 */
-EXTERN int		Tcl_PkgProvide(Tcl_Interp *interp, const char *name,
+TCL_DEPRECATED("No longer in use, changed to macro")
+int			Tcl_PkgProvide(Tcl_Interp *interp, const char *name,
 				const char *version);
 /* 274 */
-EXTERN const char *	Tcl_PkgRequire(Tcl_Interp *interp, const char *name,
+TCL_DEPRECATED("No longer in use, changed to macro")
+const char *		Tcl_PkgRequire(Tcl_Interp *interp, const char *name,
 				const char *version, int exact);
 /* 275 */
 TCL_DEPRECATED("see TIP #422")
@@ -1125,7 +1148,8 @@ EXTERN int		Tcl_GetCharLength(Tcl_Obj *objPtr);
 /* 381 */
 EXTERN int		Tcl_GetUniChar(Tcl_Obj *objPtr, int index);
 /* 382 */
-EXTERN Tcl_UniChar *	Tcl_GetUnicode(Tcl_Obj *objPtr);
+TCL_DEPRECATED("No longer in use, changed to macro")
+Tcl_UniChar *		Tcl_GetUnicode(Tcl_Obj *objPtr);
 /* 383 */
 EXTERN Tcl_Obj *	Tcl_GetRange(Tcl_Obj *objPtr, int first, int last);
 /* 384 */
@@ -1887,11 +1911,11 @@ typedef struct TclStubs {
     void (*tcl_DbDecrRefCount) (Tcl_Obj *objPtr, const char *file, int line); /* 19 */
     void (*tcl_DbIncrRefCount) (Tcl_Obj *objPtr, const char *file, int line); /* 20 */
     int (*tcl_DbIsShared) (Tcl_Obj *objPtr, const char *file, int line); /* 21 */
-    Tcl_Obj * (*tcl_DbNewBooleanObj) (int boolValue, const char *file, int line); /* 22 */
+    TCL_DEPRECATED_API("No longer in use, changed to macro") Tcl_Obj * (*tcl_DbNewBooleanObj) (int boolValue, const char *file, int line); /* 22 */
     Tcl_Obj * (*tcl_DbNewByteArrayObj) (const unsigned char *bytes, int length, const char *file, int line); /* 23 */
     Tcl_Obj * (*tcl_DbNewDoubleObj) (double doubleValue, const char *file, int line); /* 24 */
     Tcl_Obj * (*tcl_DbNewListObj) (int objc, Tcl_Obj *const *objv, const char *file, int line); /* 25 */
-    Tcl_Obj * (*tcl_DbNewLongObj) (long longValue, const char *file, int line); /* 26 */
+    TCL_DEPRECATED_API("No longer in use, changed to macro") Tcl_Obj * (*tcl_DbNewLongObj) (long longValue, const char *file, int line); /* 26 */
     Tcl_Obj * (*tcl_DbNewObj) (const char *file, int line); /* 27 */
     Tcl_Obj * (*tcl_DbNewStringObj) (const char *bytes, int length, const char *file, int line); /* 28 */
     Tcl_Obj * (*tcl_DuplicateObj) (Tcl_Obj *objPtr); /* 29 */
@@ -1901,7 +1925,7 @@ typedef struct TclStubs {
     unsigned char * (*tcl_GetByteArrayFromObj) (Tcl_Obj *objPtr, int *lengthPtr); /* 33 */
     int (*tcl_GetDouble) (Tcl_Interp *interp, const char *src, double *doublePtr); /* 34 */
     int (*tcl_GetDoubleFromObj) (Tcl_Interp *interp, Tcl_Obj *objPtr, double *doublePtr); /* 35 */
-    int (*tcl_GetIndexFromObj) (Tcl_Interp *interp, Tcl_Obj *objPtr, const char *const *tablePtr, const char *msg, int flags, int *indexPtr); /* 36 */
+    TCL_DEPRECATED_API("No longer in use, changed to macro") int (*tcl_GetIndexFromObj) (Tcl_Interp *interp, Tcl_Obj *objPtr, const char *const *tablePtr, const char *msg, int flags, int *indexPtr); /* 36 */
     int (*tcl_GetInt) (Tcl_Interp *interp, const char *src, int *intPtr); /* 37 */
     int (*tcl_GetIntFromObj) (Tcl_Interp *interp, Tcl_Obj *objPtr, int *intPtr); /* 38 */
     int (*tcl_GetLongFromObj) (Tcl_Interp *interp, Tcl_Obj *objPtr, long *longPtr); /* 39 */
@@ -1914,25 +1938,25 @@ typedef struct TclStubs {
     int (*tcl_ListObjIndex) (Tcl_Interp *interp, Tcl_Obj *listPtr, int index, Tcl_Obj **objPtrPtr); /* 46 */
     int (*tcl_ListObjLength) (Tcl_Interp *interp, Tcl_Obj *listPtr, int *lengthPtr); /* 47 */
     int (*tcl_ListObjReplace) (Tcl_Interp *interp, Tcl_Obj *listPtr, int first, int count, int objc, Tcl_Obj *const objv[]); /* 48 */
-    Tcl_Obj * (*tcl_NewBooleanObj) (int boolValue); /* 49 */
+    TCL_DEPRECATED_API("No longer in use, changed to macro") Tcl_Obj * (*tcl_NewBooleanObj) (int boolValue); /* 49 */
     Tcl_Obj * (*tcl_NewByteArrayObj) (const unsigned char *bytes, int length); /* 50 */
     Tcl_Obj * (*tcl_NewDoubleObj) (double doubleValue); /* 51 */
-    Tcl_Obj * (*tcl_NewIntObj) (int intValue); /* 52 */
+    TCL_DEPRECATED_API("No longer in use, changed to macro") Tcl_Obj * (*tcl_NewIntObj) (int intValue); /* 52 */
     Tcl_Obj * (*tcl_NewListObj) (int objc, Tcl_Obj *const objv[]); /* 53 */
-    Tcl_Obj * (*tcl_NewLongObj) (long longValue); /* 54 */
+    TCL_DEPRECATED_API("No longer in use, changed to macro") Tcl_Obj * (*tcl_NewLongObj) (long longValue); /* 54 */
     Tcl_Obj * (*tcl_NewObj) (void); /* 55 */
     Tcl_Obj * (*tcl_NewStringObj) (const char *bytes, int length); /* 56 */
-    void (*tcl_SetBooleanObj) (Tcl_Obj *objPtr, int boolValue); /* 57 */
+    TCL_DEPRECATED_API("No longer in use, changed to macro") void (*tcl_SetBooleanObj) (Tcl_Obj *objPtr, int boolValue); /* 57 */
     unsigned char * (*tcl_SetByteArrayLength) (Tcl_Obj *objPtr, int length); /* 58 */
     void (*tcl_SetByteArrayObj) (Tcl_Obj *objPtr, const unsigned char *bytes, int length); /* 59 */
     void (*tcl_SetDoubleObj) (Tcl_Obj *objPtr, double doubleValue); /* 60 */
-    void (*tcl_SetIntObj) (Tcl_Obj *objPtr, int intValue); /* 61 */
+    TCL_DEPRECATED_API("No longer in use, changed to macro") void (*tcl_SetIntObj) (Tcl_Obj *objPtr, int intValue); /* 61 */
     void (*tcl_SetListObj) (Tcl_Obj *objPtr, int objc, Tcl_Obj *const objv[]); /* 62 */
-    void (*tcl_SetLongObj) (Tcl_Obj *objPtr, long longValue); /* 63 */
+    TCL_DEPRECATED_API("No longer in use, changed to macro") void (*tcl_SetLongObj) (Tcl_Obj *objPtr, long longValue); /* 63 */
     void (*tcl_SetObjLength) (Tcl_Obj *objPtr, int length); /* 64 */
     void (*tcl_SetStringObj) (Tcl_Obj *objPtr, const char *bytes, int length); /* 65 */
-    void (*tcl_AddErrorInfo) (Tcl_Interp *interp, const char *message); /* 66 */
-    void (*tcl_AddObjErrorInfo) (Tcl_Interp *interp, const char *message, int length); /* 67 */
+    TCL_DEPRECATED_API("No longer in use, changed to macro") void (*tcl_AddErrorInfo) (Tcl_Interp *interp, const char *message); /* 66 */
+    TCL_DEPRECATED_API("No longer in use, changed to macro") void (*tcl_AddObjErrorInfo) (Tcl_Interp *interp, const char *message, int length); /* 67 */
     void (*tcl_AllowExceptions) (Tcl_Interp *interp); /* 68 */
     void (*tcl_AppendElement) (Tcl_Interp *interp, const char *element); /* 69 */
     void (*tcl_AppendResult) (Tcl_Interp *interp, ...); /* 70 */
@@ -1996,7 +2020,7 @@ typedef struct TclStubs {
     const char * (*tcl_ErrnoMsg) (int err); /* 128 */
     int (*tcl_Eval) (Tcl_Interp *interp, const char *script); /* 129 */
     int (*tcl_EvalFile) (Tcl_Interp *interp, const char *fileName); /* 130 */
-    int (*tcl_EvalObj) (Tcl_Interp *interp, Tcl_Obj *objPtr); /* 131 */
+    TCL_DEPRECATED_API("No longer in use, changed to macro") int (*tcl_EvalObj) (Tcl_Interp *interp, Tcl_Obj *objPtr); /* 131 */
     void (*tcl_EventuallyFree) (ClientData clientData, Tcl_FreeProc *freeProc); /* 132 */
     TCL_NORETURN1 void (*tcl_Exit) (int status); /* 133 */
     int (*tcl_ExposeCommand) (Tcl_Interp *interp, const char *hiddenCmdToken, const char *cmdName); /* 134 */
@@ -2048,10 +2072,10 @@ typedef struct TclStubs {
     Tcl_Interp * (*tcl_GetSlave) (Tcl_Interp *interp, const char *slaveName); /* 172 */
     Tcl_Channel (*tcl_GetStdChannel) (int type); /* 173 */
     const char * (*tcl_GetStringResult) (Tcl_Interp *interp); /* 174 */
-    const char * (*tcl_GetVar) (Tcl_Interp *interp, const char *varName, int flags); /* 175 */
+    TCL_DEPRECATED_API("No longer in use, changed to macro") const char * (*tcl_GetVar) (Tcl_Interp *interp, const char *varName, int flags); /* 175 */
     const char * (*tcl_GetVar2) (Tcl_Interp *interp, const char *part1, const char *part2, int flags); /* 176 */
     int (*tcl_GlobalEval) (Tcl_Interp *interp, const char *command); /* 177 */
-    int (*tcl_GlobalEvalObj) (Tcl_Interp *interp, Tcl_Obj *objPtr); /* 178 */
+    TCL_DEPRECATED_API("No longer in use, changed to macro") int (*tcl_GlobalEvalObj) (Tcl_Interp *interp, Tcl_Obj *objPtr); /* 178 */
     int (*tcl_HideCommand) (Tcl_Interp *interp, const char *cmdName, const char *hiddenCmdToken); /* 179 */
     int (*tcl_Init) (Tcl_Interp *interp); /* 180 */
     void (*tcl_InitHashTable) (Tcl_HashTable *tablePtr, int keyType); /* 181 */
@@ -2110,7 +2134,7 @@ typedef struct TclStubs {
     void (*tcl_SetObjErrorCode) (Tcl_Interp *interp, Tcl_Obj *errorObjPtr); /* 234 */
     void (*tcl_SetObjResult) (Tcl_Interp *interp, Tcl_Obj *resultObjPtr); /* 235 */
     void (*tcl_SetStdChannel) (Tcl_Channel channel, int type); /* 236 */
-    const char * (*tcl_SetVar) (Tcl_Interp *interp, const char *varName, const char *newValue, int flags); /* 237 */
+    TCL_DEPRECATED_API("No longer in use, changed to macro") const char * (*tcl_SetVar) (Tcl_Interp *interp, const char *varName, const char *newValue, int flags); /* 237 */
     const char * (*tcl_SetVar2) (Tcl_Interp *interp, const char *part1, const char *part2, const char *newValue, int flags); /* 238 */
     const char * (*tcl_SignalId) (int sig); /* 239 */
     const char * (*tcl_SignalMsg) (int sig); /* 240 */
@@ -2120,21 +2144,21 @@ typedef struct TclStubs {
     void (*tcl_StaticPackage) (Tcl_Interp *interp, const char *pkgName, Tcl_PackageInitProc *initProc, Tcl_PackageInitProc *safeInitProc); /* 244 */
     int (*tcl_StringMatch) (const char *str, const char *pattern); /* 245 */
     TCL_DEPRECATED_API("") int (*tcl_TellOld) (Tcl_Channel chan); /* 246 */
-    int (*tcl_TraceVar) (Tcl_Interp *interp, const char *varName, int flags, Tcl_VarTraceProc *proc, ClientData clientData); /* 247 */
+    TCL_DEPRECATED_API("No longer in use, changed to macro") int (*tcl_TraceVar) (Tcl_Interp *interp, const char *varName, int flags, Tcl_VarTraceProc *proc, ClientData clientData); /* 247 */
     int (*tcl_TraceVar2) (Tcl_Interp *interp, const char *part1, const char *part2, int flags, Tcl_VarTraceProc *proc, ClientData clientData); /* 248 */
     char * (*tcl_TranslateFileName) (Tcl_Interp *interp, const char *name, Tcl_DString *bufferPtr); /* 249 */
     int (*tcl_Ungets) (Tcl_Channel chan, const char *str, int len, int atHead); /* 250 */
     void (*tcl_UnlinkVar) (Tcl_Interp *interp, const char *varName); /* 251 */
     int (*tcl_UnregisterChannel) (Tcl_Interp *interp, Tcl_Channel chan); /* 252 */
-    int (*tcl_UnsetVar) (Tcl_Interp *interp, const char *varName, int flags); /* 253 */
+    TCL_DEPRECATED_API("No longer in use, changed to macro") int (*tcl_UnsetVar) (Tcl_Interp *interp, const char *varName, int flags); /* 253 */
     int (*tcl_UnsetVar2) (Tcl_Interp *interp, const char *part1, const char *part2, int flags); /* 254 */
-    void (*tcl_UntraceVar) (Tcl_Interp *interp, const char *varName, int flags, Tcl_VarTraceProc *proc, ClientData clientData); /* 255 */
+    TCL_DEPRECATED_API("No longer in use, changed to macro") void (*tcl_UntraceVar) (Tcl_Interp *interp, const char *varName, int flags, Tcl_VarTraceProc *proc, ClientData clientData); /* 255 */
     void (*tcl_UntraceVar2) (Tcl_Interp *interp, const char *part1, const char *part2, int flags, Tcl_VarTraceProc *proc, ClientData clientData); /* 256 */
     void (*tcl_UpdateLinkedVar) (Tcl_Interp *interp, const char *varName); /* 257 */
-    int (*tcl_UpVar) (Tcl_Interp *interp, const char *frameName, const char *varName, const char *localName, int flags); /* 258 */
+    TCL_DEPRECATED_API("No longer in use, changed to macro") int (*tcl_UpVar) (Tcl_Interp *interp, const char *frameName, const char *varName, const char *localName, int flags); /* 258 */
     int (*tcl_UpVar2) (Tcl_Interp *interp, const char *frameName, const char *part1, const char *part2, const char *localName, int flags); /* 259 */
     int (*tcl_VarEval) (Tcl_Interp *interp, ...); /* 260 */
-    ClientData (*tcl_VarTraceInfo) (Tcl_Interp *interp, const char *varName, int flags, Tcl_VarTraceProc *procPtr, ClientData prevClientData); /* 261 */
+    TCL_DEPRECATED_API("No longer in use, changed to macro") ClientData (*tcl_VarTraceInfo) (Tcl_Interp *interp, const char *varName, int flags, Tcl_VarTraceProc *procPtr, ClientData prevClientData); /* 261 */
     ClientData (*tcl_VarTraceInfo2) (Tcl_Interp *interp, const char *part1, const char *part2, int flags, Tcl_VarTraceProc *procPtr, ClientData prevClientData); /* 262 */
     int (*tcl_Write) (Tcl_Channel chan, const char *s, int slen); /* 263 */
     void (*tcl_WrongNumArgs) (Tcl_Interp *interp, int objc, Tcl_Obj *const objv[], const char *message); /* 264 */
@@ -2144,10 +2168,10 @@ typedef struct TclStubs {
     TCL_DEPRECATED_API("see TIP #422") void (*tcl_AppendStringsToObjVA) (Tcl_Obj *objPtr, va_list argList); /* 268 */
     char * (*tcl_HashStats) (Tcl_HashTable *tablePtr); /* 269 */
     const char * (*tcl_ParseVar) (Tcl_Interp *interp, const char *start, const char **termPtr); /* 270 */
-    const char * (*tcl_PkgPresent) (Tcl_Interp *interp, const char *name, const char *version, int exact); /* 271 */
+    TCL_DEPRECATED_API("No longer in use, changed to macro") const char * (*tcl_PkgPresent) (Tcl_Interp *interp, const char *name, const char *version, int exact); /* 271 */
     const char * (*tcl_PkgPresentEx) (Tcl_Interp *interp, const char *name, const char *version, int exact, void *clientDataPtr); /* 272 */
-    int (*tcl_PkgProvide) (Tcl_Interp *interp, const char *name, const char *version); /* 273 */
-    const char * (*tcl_PkgRequire) (Tcl_Interp *interp, const char *name, const char *version, int exact); /* 274 */
+    TCL_DEPRECATED_API("No longer in use, changed to macro") int (*tcl_PkgProvide) (Tcl_Interp *interp, const char *name, const char *version); /* 273 */
+    TCL_DEPRECATED_API("No longer in use, changed to macro") const char * (*tcl_PkgRequire) (Tcl_Interp *interp, const char *name, const char *version, int exact); /* 274 */
     TCL_DEPRECATED_API("see TIP #422") void (*tcl_SetErrorCodeVA) (Tcl_Interp *interp, va_list argList); /* 275 */
     TCL_DEPRECATED_API("see TIP #422") int (*tcl_VarEvalVA) (Tcl_Interp *interp, va_list argList); /* 276 */
     Tcl_Pid (*tcl_WaitPid) (Tcl_Pid pid, int *statPtr, int options); /* 277 */
@@ -2255,7 +2279,7 @@ typedef struct TclStubs {
     void (*tcl_SetUnicodeObj) (Tcl_Obj *objPtr, const Tcl_UniChar *unicode, int numChars); /* 379 */
     int (*tcl_GetCharLength) (Tcl_Obj *objPtr); /* 380 */
     int (*tcl_GetUniChar) (Tcl_Obj *objPtr, int index); /* 381 */
-    Tcl_UniChar * (*tcl_GetUnicode) (Tcl_Obj *objPtr); /* 382 */
+    TCL_DEPRECATED_API("No longer in use, changed to macro") Tcl_UniChar * (*tcl_GetUnicode) (Tcl_Obj *objPtr); /* 382 */
     Tcl_Obj * (*tcl_GetRange) (Tcl_Obj *objPtr, int first, int last); /* 383 */
     void (*tcl_AppendUnicodeToObj) (Tcl_Obj *objPtr, const Tcl_UniChar *unicode, int length); /* 384 */
     int (*tcl_RegExpMatchObj) (Tcl_Interp *interp, Tcl_Obj *textObj, Tcl_Obj *patternObj); /* 385 */
@@ -3810,15 +3834,12 @@ extern const TclStubs *tclStubsPtr;
 #   undef Tcl_GetStringResult
 #   undef Tcl_Init
 #   undef Tcl_SetPanicProc
-#   undef Tcl_SetVar
 #   undef Tcl_ObjSetVar2
 #   undef Tcl_StaticPackage
 #   define Tcl_CreateInterp() (tclStubsPtr->tcl_CreateInterp())
 #   define Tcl_GetStringResult(interp) (tclStubsPtr->tcl_GetStringResult(interp))
 #   define Tcl_Init(interp) (tclStubsPtr->tcl_Init(interp))
 #   define Tcl_SetPanicProc(proc) (tclStubsPtr->tcl_SetPanicProc(proc))
-#   define Tcl_SetVar(interp, varName, newValue, flags) \
-	    (tclStubsPtr->tcl_SetVar(interp, varName, newValue, flags))
 #   define Tcl_ObjSetVar2(interp, part1, part2, newValue, flags) \
 	    (tclStubsPtr->tcl_ObjSetVar2(interp, part1, part2, newValue, flags))
 #endif
@@ -3974,9 +3995,11 @@ extern const TclStubs *tclStubsPtr;
 #undef Tcl_DbNewLongObj
 #define Tcl_DbNewLongObj(value, file, line) Tcl_DbNewWideIntObj((long)(value), file, line)
 #undef Tcl_SetIntObj
-#define Tcl_SetIntObj(objPtr, value)	Tcl_SetWideIntObj(objPtr, (int)(value))
+#define Tcl_SetIntObj(objPtr, value)	Tcl_SetWideIntObj((objPtr), (int)(value))
 #undef Tcl_SetLongObj
-#define Tcl_SetLongObj(objPtr, value)	Tcl_SetWideIntObj(objPtr, (long)(value))
+#define Tcl_SetLongObj(objPtr, value)	Tcl_SetWideIntObj((objPtr), (long)(value))
+#undef Tcl_GetUnicode
+#define Tcl_GetUnicode(objPtr)	Tcl_GetUnicodeFromObj((objPtr), NULL)
 
 /*
  * Deprecated Tcl procedures:

generic/tclDictObj.c

@@ -153,7 +153,7 @@ typedef struct Dict {
  * must be assignable as well as readable.
  */
 
-#define DICT(dictObj)   (*((Dict **)&(dictObj)->internalRep.twoPtrValue.ptr1))
+#define DICT(dictObj)   ((dictObj)->internalRep.twoPtrValue.ptr1)
 
 /*
  * The structure below defines the dictionary object type by means of

generic/tclDisassemble.c

@@ -894,7 +894,7 @@ PrintSourceToObj(
 		Tcl_AppendPrintfToObj(appendObj, "\\U%08x", ch);
 		i += 10;
 	    } else
-#elif TCL_UTF_MAX > 3
+#else
 	    /* If len == 0, this means we have a char > 0xffff, resulting in
 	     * TclUtfToUniChar producing a surrogate pair. We want to output
 	     * this pair as a single Unicode character.

generic/tclEnsemble.c

@@ -87,8 +87,8 @@ static const Tcl_ObjType ensembleCmdType = {
 };
 
 /*
- * The internal rep for caching ensemble subcommand lookups and
- * spell corrections.
+ * The internal rep for caching ensemble subcommand lookups and spelling
+ * corrections.
  */
 
 typedef struct {
@@ -98,10 +98,9 @@ typedef struct {
     Command *token;             /* Reference to the command for which this
                                  * structure is a cache of the resolution. */
     Tcl_Obj *fix;               /* Corrected spelling, if needed. */
-    Tcl_HashEntry *hPtr;        /* Direct link to entry in the subcommand
-                                 * hash table. */
+    Tcl_HashEntry *hPtr;        /* Direct link to entry in the subcommand hash
+                                 * table. */
 } EnsembleCmdRep;
-
 
 static inline Tcl_Obj *
 NewNsObj(
@@ -111,9 +110,8 @@ NewNsObj(
 
     if (namespacePtr == TclGetGlobalNamespace(nsPtr->interp)) {
 	return Tcl_NewStringObj("::", 2);
-    } else {
-	return Tcl_NewStringObj(nsPtr->fullName, -1);
     }
+    return Tcl_NewStringObj(nsPtr->fullName, -1);
 }
 
 /*
@@ -147,7 +145,7 @@ TclNamespaceEnsembleCmd(
 {
     Tcl_Namespace *namespacePtr;
     Namespace *nsPtr = (Namespace *) TclGetCurrentNamespace(interp), *cxtPtr,
-    	*foundNsPtr, *altFoundNsPtr, *actualCxtPtr;
+	    *foundNsPtr, *altFoundNsPtr, *actualCxtPtr;
     Tcl_Command token;
     Tcl_DictSearch search;
     Tcl_Obj *listObj;
@@ -302,7 +300,8 @@ TclNamespaceEnsembleCmd(
 			Tcl_DictObjPut(NULL, patchedDict, subcmdWordsObj,
 				newList);
 		    }
-		    Tcl_DictObjNext(&search, &subcmdWordsObj,&listObj, &done);
+		    Tcl_DictObjNext(&search, &subcmdWordsObj, &listObj,
+			    &done);
 		} while (!done);
 
 		if (allocatedMapFlag) {
@@ -336,8 +335,8 @@ TclNamespaceEnsembleCmd(
 	}
 
 	TclGetNamespaceForQualName(interp, name, cxtPtr,
-	TCL_CREATE_NS_IF_UNKNOWN, &foundNsPtr, &altFoundNsPtr, &actualCxtPtr,
-	&simpleName);
+		TCL_CREATE_NS_IF_UNKNOWN, &foundNsPtr, &altFoundNsPtr,
+		&actualCxtPtr, &simpleName);
 
 	/*
 	 * Create the ensemble. Note that this might delete another ensemble
@@ -347,8 +346,8 @@ TclNamespaceEnsembleCmd(
 	 */
 
 	token = TclCreateEnsembleInNs(interp, simpleName,
-	     (Tcl_Namespace *) foundNsPtr, (Tcl_Namespace *) nsPtr,
-	     (permitPrefix ? TCL_ENSEMBLE_PREFIX : 0));
+		(Tcl_Namespace *) foundNsPtr, (Tcl_Namespace *) nsPtr,
+		(permitPrefix ? TCL_ENSEMBLE_PREFIX : 0));
 	Tcl_SetEnsembleSubcommandList(interp, token, subcmdObj);
 	Tcl_SetEnsembleMappingDict(interp, token, mapObj);
 	Tcl_SetEnsembleUnknownHandler(interp, token, unknownObj);
@@ -576,7 +575,8 @@ TclNamespaceEnsembleCmd(
 				Tcl_AppendStringsToObj(newCmd, "::", NULL);
 			    }
 			    Tcl_AppendObjToObj(newCmd, listv[0]);
-			    Tcl_ListObjReplace(NULL, newList, 0,1, 1,&newCmd);
+			    Tcl_ListObjReplace(NULL, newList, 0, 1, 1,
+				    &newCmd);
 			    if (patchedDict == NULL) {
 				patchedDict = Tcl_DuplicateObj(objv[1]);
 			    }
@@ -650,15 +650,13 @@ TclNamespaceEnsembleCmd(
 Tcl_Command
 TclCreateEnsembleInNs(
     Tcl_Interp *interp,
-
-    const char *name,   /* Simple name of command to create (no */
-			/* namespace components). */
-    Tcl_Namespace       /* Name of namespace to create the command in. */
-    *nameNsPtr,
-    Tcl_Namespace
-    *ensembleNsPtr,	/* Name of the namespace for the ensemble. */
-    int flags
-    )
+    const char *name,		/* Simple name of command to create (no
+				 * namespace components). */
+    Tcl_Namespace *nameNsPtr,	/* Name of namespace to create the command
+				 * in. */
+    Tcl_Namespace *ensembleNsPtr,
+				/* Name of the namespace for the ensemble. */
+    int flags)
 {
     Namespace *nsPtr = (Namespace *) ensembleNsPtr;
     EnsembleConfig *ensemblePtr;
@@ -666,8 +664,8 @@ TclCreateEnsembleInNs(
 
     ensemblePtr = ckalloc(sizeof(EnsembleConfig));
     token = TclNRCreateCommandInNs(interp, name,
-	(Tcl_Namespace *) nameNsPtr, NsEnsembleImplementationCmd,
-	NsEnsembleImplementationCmdNR, ensemblePtr, DeleteEnsembleConfig);
+	    (Tcl_Namespace *) nameNsPtr, NsEnsembleImplementationCmd,
+	    NsEnsembleImplementationCmdNR, ensemblePtr, DeleteEnsembleConfig);
     if (token == NULL) {
 	ckfree(ensemblePtr);
 	return NULL;
@@ -701,18 +699,15 @@ TclCreateEnsembleInNs(
     }
 
     return ensemblePtr->token;
-
 }
-
-
+
 /*
  *----------------------------------------------------------------------
  *
  * Tcl_CreateEnsemble
  *
- *	Create a simple ensemble attached to the given namespace.
- *
- *	Deprecated by TclCreateEnsembleInNs.
+ *	Create a simple ensemble attached to the given namespace. Deprecated
+ *	(internally) by TclCreateEnsembleInNs.
  *
  * Value
  *
@@ -732,8 +727,8 @@ Tcl_CreateEnsemble(
     Tcl_Namespace *namespacePtr,
     int flags)
 {
-    Namespace *nsPtr = (Namespace *)namespacePtr, *foundNsPtr, *altNsPtr,
-    	*actualNsPtr;
+    Namespace *nsPtr = (Namespace *) namespacePtr, *foundNsPtr, *altNsPtr,
+	    *actualNsPtr;
     const char * simpleName;
 
     if (nsPtr == NULL) {
@@ -741,11 +736,10 @@ Tcl_CreateEnsemble(
     }
 
     TclGetNamespaceForQualName(interp, name, nsPtr, TCL_CREATE_NS_IF_UNKNOWN,
-    	&foundNsPtr, &altNsPtr, &actualNsPtr, &simpleName);
+	    &foundNsPtr, &altNsPtr, &actualNsPtr, &simpleName);
     return TclCreateEnsembleInNs(interp, simpleName,
-	(Tcl_Namespace *) foundNsPtr, (Tcl_Namespace *) nsPtr, flags);
+	    (Tcl_Namespace *) foundNsPtr, (Tcl_Namespace *) nsPtr, flags);
 }
-
 
 /*
  *----------------------------------------------------------------------
@@ -2117,22 +2111,27 @@ TclSpellFix(
 	iPtr->ensembleRewrite.numInsertedObjs = 0;
     }
 
-    /* Compute the valid length of the ensemble root */
+    /*
+     * Compute the valid length of the ensemble root.
+     */
 
     size = iPtr->ensembleRewrite.numRemovedObjs + objc
-		- iPtr->ensembleRewrite.numInsertedObjs;
+	    - iPtr->ensembleRewrite.numInsertedObjs;
 
     search = iPtr->ensembleRewrite.sourceObjs;
     if (search[0] == NULL) {
-	/* Awful casting abuse here */
+	/*
+	 * Awful casting abuse here...
+	 */
 	search = (Tcl_Obj *const *) search[1];
     }
 
     if (badIdx < iPtr->ensembleRewrite.numInsertedObjs) {
 	/*
-	 * Misspelled value was inserted. We cannot directly jump
-	 * to the bad value, but have to search.
+	 * Misspelled value was inserted. We cannot directly jump to the bad
+	 * value, but have to search.
 	 */
+
 	idx = 1;
 	while (idx < size) {
 	    if (search[idx] == bad) {
@@ -2156,13 +2155,14 @@ TclSpellFix(
 
     search = iPtr->ensembleRewrite.sourceObjs;
     if (search[0] == NULL) {
-	store = (Tcl_Obj **)search[2];
-    }  else {
+	store = (Tcl_Obj **) search[2];
+    } else {
 	Tcl_Obj **tmp = ckalloc(3 * sizeof(Tcl_Obj *));
+
 	tmp[0] = NULL;
-	tmp[1] = (Tcl_Obj *)iPtr->ensembleRewrite.sourceObjs;
-	tmp[2] = (Tcl_Obj *)ckalloc(size * sizeof(Tcl_Obj *));
-	memcpy(tmp[2], tmp[1], size*sizeof(Tcl_Obj *));
+	tmp[1] = (Tcl_Obj *) iPtr->ensembleRewrite.sourceObjs;
+	tmp[2] = (Tcl_Obj *) ckalloc(size * sizeof(Tcl_Obj *));
+	memcpy(tmp[2], tmp[1], size * sizeof(Tcl_Obj *));
 
 	iPtr->ensembleRewrite.sourceObjs = (Tcl_Obj *const *) tmp;
 	TclNRAddCallback(interp, FreeER, tmp, NULL, NULL, NULL);
@@ -2589,7 +2589,9 @@ BuildEnsembleConfig(
                 }
             }
         } else {
-            /* Usual case where we can freely act on the list and dict. */
+            /*
+	     * Usual case where we can freely act on the list and dict.
+	     */
 
             for (i = 0; i < subc; i++) {
                 name = TclGetString(subv[i]);
@@ -2598,7 +2600,10 @@ BuildEnsembleConfig(
                     continue;
                 }
 
-                /* Lookup target in the dictionary */
+                /*
+		 * Lookup target in the dictionary.
+		 */
+
                 if (mapDict) {
                     Tcl_DictObjGet(NULL, mapDict, subv[i], &target);
                     if (target) {
@@ -2610,10 +2615,11 @@ BuildEnsembleConfig(
 
                 /*
                  * target was not in the dictionary so map onto the namespace.
-                 * Note in this case that we do not guarantee that the
-                 * command is actually there; that is the programmer's
-                 * responsibility (or [::unknown] of course).
+                 * Note in this case that we do not guarantee that the command
+                 * is actually there; that is the programmer's responsibility
+                 * (or [::unknown] of course).
                  */
+
                 cmdObj = Tcl_NewStringObj(name, -1);
                 cmdPrefixObj = Tcl_NewListObj(1, &cmdObj);
                 Tcl_SetHashValue(hPtr, cmdPrefixObj);

generic/tclEnv.c

@@ -723,14 +723,25 @@ TclFinalizeEnvironment(void)
      * strings. This may leak more memory that strictly necessary, since some
      * of the strings may no longer be in the environment. However,
      * determining which ones are ok to delete is n-squared, and is pretty
-     * unlikely, so we don't bother.
+     * unlikely, so we don't bother.  However, in the case of DPURIFY, just
+     * free all strings in the cache.
      */
 
     if (env.cache) {
+#ifdef PURIFY
+	int i;
+	for (i = 0; i < env.cacheSize; i++) {
+	    ckfree(env.cache[i]);
+	}
+#endif
 	ckfree(env.cache);
 	env.cache = NULL;
 	env.cacheSize = 0;
 #ifndef USE_PUTENV
+	if ((env.ourEnviron != NULL)) {
+	    ckfree(env.ourEnviron);
+	    env.ourEnviron = NULL;
+	}
 	env.ourEnvironSize = 0;
 #endif
     }

generic/tclEvent.c

@@ -100,7 +100,7 @@ typedef struct ThreadSpecificData {
 } ThreadSpecificData;
 static Tcl_ThreadDataKey dataKey;
 
-#ifdef TCL_THREADS
+#if TCL_THREADS
 typedef struct {
     Tcl_ThreadCreateProc *proc;	/* Main() function of the thread */
     ClientData clientData;	/* The one argument to Main() */
@@ -1043,7 +1043,7 @@ TclInitSubsystems(void)
 #if USE_TCLALLOC
 	    TclInitAlloc();		/* Process wide mutex init */
 #endif
-#if defined(TCL_THREADS) && defined(USE_THREAD_ALLOC)
+#if TCL_THREADS && defined(USE_THREAD_ALLOC)
 	    TclInitThreadAlloc();	/* Setup thread allocator caches */
 #endif
 #ifdef TCL_MEM_DEBUG
@@ -1220,7 +1220,7 @@ Tcl_Finalize(void)
      * Close down the thread-specific object allocator.
      */
 
-#if defined(TCL_THREADS) && defined(USE_THREAD_ALLOC)
+#if TCL_THREADS && defined(USE_THREAD_ALLOC)
     TclFinalizeThreadAlloc();
 #endif
 
@@ -1538,7 +1538,7 @@ Tcl_UpdateObjCmd(
     return TCL_OK;
 }
 
-#ifdef TCL_THREADS
+#if TCL_THREADS
 /*
  *----------------------------------------------------------------------
  *
@@ -1601,7 +1601,7 @@ Tcl_CreateThread(
     int flags)			/* Flags controlling behaviour of the new
 				 * thread. */
 {
-#ifdef TCL_THREADS
+#if TCL_THREADS
     ThreadClientData *cdPtr = ckalloc(sizeof(ThreadClientData));
     int result;
 

generic/tclExecute.c

@@ -4964,7 +4964,7 @@ TEBCresume(
 
 	/* Decode index value operands. */
 
-	/* 
+	/*
 	assert ( toIdx != TCL_INDEX_AFTER);
 	 *
 	 * Extra safety for legacy bytecodes:
@@ -5088,88 +5088,10 @@ TEBCresume(
 	value2Ptr = OBJ_AT_TOS;
 	valuePtr = OBJ_UNDER_TOS;
 
-	if (valuePtr == value2Ptr) {
-	    match = 0;
-	} else {
-	    /*
-	     * We only need to check (in)equality when we have equal length
-	     * strings.  We can use memcmp in all (n)eq cases because we
-	     * don't need to worry about lexical LE/BE variance.
-	     */
-
-	    typedef int (*memCmpFn_t)(const void*, const void*, size_t);
-	    memCmpFn_t memCmpFn;
+	{
 	    int checkEq = ((*pc == INST_EQ) || (*pc == INST_NEQ)
 		    || (*pc == INST_STR_EQ) || (*pc == INST_STR_NEQ));
-
-	    if (TclIsPureByteArray(valuePtr)
-		    && TclIsPureByteArray(value2Ptr)) {
-		s1 = (char *) Tcl_GetByteArrayFromObj(valuePtr, &s1len);
-		s2 = (char *) Tcl_GetByteArrayFromObj(value2Ptr, &s2len);
-		memCmpFn = memcmp;
-	    } else if ((valuePtr->typePtr == &tclStringType)
-		    && (value2Ptr->typePtr == &tclStringType)) {
-		/*
-		 * Do a unicode-specific comparison if both of the args are of
-		 * String type. If the char length == byte length, we can do a
-		 * memcmp. In benchmark testing this proved the most efficient
-		 * check between the unicode and string comparison operations.
-		 */
-
-		s1len = Tcl_GetCharLength(valuePtr);
-		s2len = Tcl_GetCharLength(value2Ptr);
-		if ((s1len == valuePtr->length)
-			&& (valuePtr->bytes != NULL)
-			&& (s2len == value2Ptr->length)
-			&& (value2Ptr->bytes != NULL)) {
-		    s1 = valuePtr->bytes;
-		    s2 = value2Ptr->bytes;
-		    memCmpFn = memcmp;
-		} else {
-		    s1 = (char *) Tcl_GetUnicode(valuePtr);
-		    s2 = (char *) Tcl_GetUnicode(value2Ptr);
-		    if (
-#ifdef WORDS_BIGENDIAN
-			1
-#else
-			checkEq
-#endif
-			) {
-			memCmpFn = memcmp;
-			s1len *= sizeof(Tcl_UniChar);
-			s2len *= sizeof(Tcl_UniChar);
-		    } else {
-			memCmpFn = (memCmpFn_t) Tcl_UniCharNcmp;
-		    }
-		}
-	    } else {
-		/*
-		 * strcmp can't do a simple memcmp in order to handle the
-		 * special Tcl \xC0\x80 null encoding for utf-8.
-		 */
-
-		s1 = TclGetStringFromObj(valuePtr, &s1len);
-		s2 = TclGetStringFromObj(value2Ptr, &s2len);
-		if (checkEq) {
-		    memCmpFn = memcmp;
-		} else {
-		    memCmpFn = (memCmpFn_t) TclpUtfNcmp2;
-		}
-	    }
-
-	    if (checkEq && (s1len != s2len)) {
-		match = 1;
-	    } else {
-		/*
-		 * The comparison function should compare up to the minimum
-		 * byte length only.
-		 */
-		match = memCmpFn(s1, s2,
-			(size_t) ((s1len < s2len) ? s1len : s2len));
-		if (match == 0) {
-		    match = s1len - s2len;
-		}
-	    }
+	    match = TclStringCmp(valuePtr, value2Ptr, checkEq, 0, -1);
 	}
 
 	/*
@@ -5301,9 +5223,15 @@ TEBCresume(
 	     * but creating the object as a string seems to be faster in
 	     * practical use.
 	     */
-
-	    length = (ch != -1) ? Tcl_UniCharToUtf(ch, buf) : 0;
-	    objResultPtr = Tcl_NewStringObj(buf, length);
+	    if (ch == -1) {
+		objResultPtr = Tcl_NewObj();
+	    } else {
+		length = Tcl_UniCharToUtf(ch, buf);
+		if (!length) {
+		    length = Tcl_UniCharToUtf(-1, buf);
+		}
+		objResultPtr = Tcl_NewStringObj(buf, length);
+	    }
 	}
 
 	TRACE_APPEND(("\"%s\"\n", O2S(objResultPtr)));
@@ -5739,6 +5667,14 @@ TEBCresume(
 	value2Ptr = OBJ_AT_TOS;
 	valuePtr = OBJ_UNDER_TOS;
 
+	/*
+	    Try to determine, without triggering generation of a string
+	    representation, whether one value is not a number.
+	*/
+	if (TclCheckEmptyString(valuePtr) > 0 || TclCheckEmptyString(value2Ptr) > 0) {
+	    goto stringCompare;
+	}
+
 	if (GetNumberFromObj(NULL, valuePtr, &ptr1, &type1) != TCL_OK
 		|| GetNumberFromObj(NULL, value2Ptr, &ptr2, &type2) != TCL_OK) {
 	    /*

generic/tclFCmd.c

@@ -240,9 +240,13 @@ TclFileMakeDirsCmd(
 	    break;
 	}
 	for (j = 0; j < pobjc; j++) {
+	    int errCount = 2;
+
 	    target = Tcl_FSJoinPath(split, j + 1);
 	    Tcl_IncrRefCount(target);
 
+	createDir:
+
 	    /*
 	     * Call Tcl_FSStat() so that if target is a symlink that points to
 	     * a directory we will create subdirectories in that directory.
@@ -269,23 +273,25 @@ TclFileMakeDirsCmd(
 		 * subdirectory.
 		 */
 
-		if (errno != EEXIST) {
-		    errfile = target;
-		    goto done;
-		} else if ((Tcl_FSStat(target, &statBuf) == 0)
-			&& S_ISDIR(statBuf.st_mode)) {
-		    /*
-		     * It is a directory that wasn't there before, so keep
-		     * going without error.
-		     */
-
-		    Tcl_ResetResult(interp);
-		} else {
-		    errfile = target;
-		    goto done;
+		if (errno == EEXIST) {
+		    /* Be aware other workers could delete it immediately after
+		     * creation, so give this worker still one chance (repeat once),
+		     * see [270f78ca95] for description of the race-condition.
+		     * Don't repeat the create always (to avoid endless loop). */
+		    if (--errCount > 0) {
+			goto createDir;
+		    }
+		    /* Already tried, with delete in-between directly after
+		     * creation, so just continue (assume created successful). */
+		    goto nextPart;
 		}
+
+		/* return with error */
+		errfile = target;
+		goto done;
 	    }
 
+	nextPart:
 	    /*
 	     * Forget about this sub-path.
 	     */

generic/tclIORChan.c

@@ -39,7 +39,7 @@ static int		ReflectOutput(ClientData clientData, const char *buf,
 			    int toWrite, int *errorCodePtr);
 static void		ReflectWatch(ClientData clientData, int mask);
 static int		ReflectBlock(ClientData clientData, int mode);
-#ifdef TCL_THREADS
+#if TCL_THREADS
 static void		ReflectThread(ClientData clientData, int action);
 static int		ReflectEventRun(Tcl_Event *ev, int flags);
 static int		ReflectEventDelete(Tcl_Event *ev, ClientData cd);
@@ -76,7 +76,7 @@ static const Tcl_ChannelType tclRChannelType = {
     NULL,		   /* Flush channel. Not used by core.	NULL'able */
     NULL,		   /* Handle events.			NULL'able */
     ReflectSeekWide,	   /* Move access point (64 bit).	NULL'able */
-#ifdef TCL_THREADS
+#if TCL_THREADS
     ReflectThread,         /* thread action, tracking owner */
 #else
     NULL,		   /* thread action */
@@ -97,7 +97,7 @@ typedef struct {
 				 * interpreter/thread containing its Tcl
 				 * command is gone.
 				 */
-#ifdef TCL_THREADS
+#if TCL_THREADS
     Tcl_ThreadId thread;	/* Thread the 'interp' belongs to. == Handler thread */
     Tcl_ThreadId owner;         /* Thread owning the structure.    == Channel thread */
 #endif
@@ -201,7 +201,7 @@ typedef enum {
 #define NEGIMPL(a,b)
 #define HAS(x,f)	(x & FLAG(f))
 
-#ifdef TCL_THREADS
+#if TCL_THREADS
 /*
  * Thread specific types and structures.
  *
@@ -451,7 +451,7 @@ static const char *msg_read_toomuch = "{read delivered more than requested}";
 static const char *msg_write_toomuch = "{write wrote more than requested}";
 static const char *msg_write_nothing = "{write wrote nothing}";
 static const char *msg_seek_beforestart = "{Tried to seek before origin}";
-#ifdef TCL_THREADS
+#if TCL_THREADS
 static const char *msg_send_originlost = "{Channel thread lost}";
 #endif /* TCL_THREADS */
 static const char *msg_send_dstlost    = "{Owner lost}";
@@ -706,7 +706,7 @@ TclChanCreateObjCmd(
 	Tcl_Panic("TclChanCreateObjCmd: duplicate channel names");
     }
     Tcl_SetHashValue(hPtr, chan);
-#ifdef TCL_THREADS
+#if TCL_THREADS
     rcmPtr = GetThreadReflectedChannelMap();
     hPtr = Tcl_CreateHashEntry(&rcmPtr->map, chanPtr->state->channelName,
 	    &isNew);
@@ -750,7 +750,7 @@ TclChanCreateObjCmd(
  *----------------------------------------------------------------------
  */
 
-#ifdef TCL_THREADS
+#if TCL_THREADS
 typedef struct {
     Tcl_Event header;
     ReflectedChannel *rcPtr;
@@ -917,11 +917,11 @@ TclChanPostEventObjCmd(
      * We have the channel and the events to post.
      */
 
-#ifdef TCL_THREADS
+#if TCL_THREADS
     if (rcPtr->owner == rcPtr->thread) {
 #endif
         Tcl_NotifyChannel(chan, events);
-#ifdef TCL_THREADS
+#if TCL_THREADS
     } else {
         ReflectEvent *ev = ckalloc(sizeof(ReflectEvent));
 
@@ -1137,7 +1137,7 @@ ReflectClose(
 	 * if lost?
 	 */
 
-#ifdef TCL_THREADS
+#if TCL_THREADS
 	if (rcPtr->thread != Tcl_GetCurrentThread()) {
 	    ForwardParam p;
 
@@ -1169,7 +1169,7 @@ ReflectClose(
      * Are we in the correct thread?
      */
 
-#ifdef TCL_THREADS
+#if TCL_THREADS
     if (rcPtr->thread != Tcl_GetCurrentThread()) {
 	ForwardParam p;
 
@@ -1216,7 +1216,7 @@ ReflectClose(
 		Tcl_DeleteHashEntry(hPtr);
 	    }
 	}
-#ifdef TCL_THREADS
+#if TCL_THREADS
 	rcmPtr = GetThreadReflectedChannelMap();
 	hPtr = Tcl_FindHashEntry(&rcmPtr->map,
 		Tcl_GetChannelName(rcPtr->chan));
@@ -1267,7 +1267,7 @@ ReflectInput(
      * Are we in the correct thread?
      */
 
-#ifdef TCL_THREADS
+#if TCL_THREADS
     if (rcPtr->thread != Tcl_GetCurrentThread()) {
 	ForwardParam p;
 
@@ -1373,7 +1373,7 @@ ReflectOutput(
      * Are we in the correct thread?
      */
 
-#ifdef TCL_THREADS
+#if TCL_THREADS
     if (rcPtr->thread != Tcl_GetCurrentThread()) {
 	ForwardParam p;
 
@@ -1502,7 +1502,7 @@ ReflectSeekWide(
      * Are we in the correct thread?
      */
 
-#ifdef TCL_THREADS
+#if TCL_THREADS
     if (rcPtr->thread != Tcl_GetCurrentThread()) {
 	ForwardParam p;
 
@@ -1625,7 +1625,7 @@ ReflectWatch(
      * Are we in the correct thread?
      */
 
-#ifdef TCL_THREADS
+#if TCL_THREADS
     if (rcPtr->thread != Tcl_GetCurrentThread()) {
 	ForwardParam p;
 
@@ -1683,7 +1683,7 @@ ReflectBlock(
      * Are we in the correct thread?
      */
 
-#ifdef TCL_THREADS
+#if TCL_THREADS
     if (rcPtr->thread != Tcl_GetCurrentThread()) {
 	ForwardParam p;
 
@@ -1719,7 +1719,7 @@ ReflectBlock(
     return errorNum;
 }
 
-#ifdef TCL_THREADS
+#if TCL_THREADS
 /*
  *----------------------------------------------------------------------
  *
@@ -1789,7 +1789,7 @@ ReflectSetOption(
      * Are we in the correct thread?
      */
 
-#ifdef TCL_THREADS
+#if TCL_THREADS
     if (rcPtr->thread != Tcl_GetCurrentThread()) {
 	ForwardParam p;
 
@@ -1868,7 +1868,7 @@ ReflectGetOption(
      * Are we in the correct thread?
      */
 
-#ifdef TCL_THREADS
+#if TCL_THREADS
     if (rcPtr->thread != Tcl_GetCurrentThread()) {
 	int opcode;
 	ForwardParam p;
@@ -2131,7 +2131,7 @@ NewReflectedChannel(
     rcPtr->chan = NULL;
     rcPtr->interp = interp;
     rcPtr->dead = 0;
-#ifdef TCL_THREADS
+#if TCL_THREADS
     rcPtr->thread = Tcl_GetCurrentThread();
 #endif
     rcPtr->mode = mode;
@@ -2506,7 +2506,7 @@ DeleteReflectedChannelMap(
     Tcl_HashEntry *hPtr;	 /* Search variable. */
     ReflectedChannel *rcPtr;
     Tcl_Channel chan;
-#ifdef TCL_THREADS
+#if TCL_THREADS
     ForwardingResult *resultPtr;
     ForwardingEvent *evPtr;
     ForwardParam *paramPtr;
@@ -2536,7 +2536,7 @@ DeleteReflectedChannelMap(
     Tcl_DeleteHashTable(&rcmPtr->map);
     ckfree(&rcmPtr->map);
 
-#ifdef TCL_THREADS
+#if TCL_THREADS
     /*
      * The origin interpreter for one or more reflected channels is gone.
      */
@@ -2622,7 +2622,7 @@ DeleteReflectedChannelMap(
 #endif
 }
 
-#ifdef TCL_THREADS
+#if TCL_THREADS
 /*
  *----------------------------------------------------------------------
  *

generic/tclIORTrans.c

@@ -127,7 +127,7 @@ typedef struct {
 				 * in the argv, see below. The separate field
 				 * gives us direct access, needed when working
 				 * with the reflection maps. */
-#ifdef TCL_THREADS
+#if TCL_THREADS
     Tcl_ThreadId thread;	/* Thread the 'interp' belongs to. */
 #endif
 
@@ -220,7 +220,7 @@ typedef enum {
 #define NEGIMPL(a,b)
 #define HAS(x,f)	(x & FLAG(f))
 
-#ifdef TCL_THREADS
+#if TCL_THREADS
 /*
  * Thread specific types and structures.
  *
@@ -438,7 +438,7 @@ static void		DeleteReflectedTransformMap(ClientData clientData,
 
 static const char *msg_read_unsup = "{read not supported by Tcl driver}";
 static const char *msg_write_unsup = "{write not supported by Tcl driver}";
-#ifdef TCL_THREADS
+#if TCL_THREADS
 static const char *msg_send_originlost = "{Channel thread lost}";
 static const char *msg_send_dstlost = "{Owner lost}";
 #endif /* TCL_THREADS */
@@ -699,7 +699,7 @@ TclChanPushObjCmd(
 	Tcl_Panic("TclChanPushObjCmd: duplicate transformation handle");
     }
     Tcl_SetHashValue(hPtr, rtPtr);
-#ifdef TCL_THREADS
+#if TCL_THREADS
     rtmPtr = GetThreadReflectedTransformMap();
     hPtr = Tcl_CreateHashEntry(&rtmPtr->map, TclGetString(rtId), &isNew);
     Tcl_SetHashValue(hPtr, rtPtr);
@@ -911,7 +911,7 @@ ReflectClose(
 	 * if lost?
 	 */
 
-#ifdef TCL_THREADS
+#if TCL_THREADS
 	if (rtPtr->thread != Tcl_GetCurrentThread()) {
 	    ForwardParam p;
 
@@ -938,7 +938,7 @@ ReflectClose(
 
     if (HAS(rtPtr->methods, METH_DRAIN) && !rtPtr->readIsDrained) {
 	if (!TransformDrain(rtPtr, &errorCode)) {
-#ifdef TCL_THREADS
+#if TCL_THREADS
 	    if (rtPtr->thread != Tcl_GetCurrentThread()) {
 		Tcl_EventuallyFree(rtPtr,
 			(Tcl_FreeProc *) FreeReflectedTransform);
@@ -952,7 +952,7 @@ ReflectClose(
 
     if (HAS(rtPtr->methods, METH_FLUSH)) {
 	if (!TransformFlush(rtPtr, &errorCode, FLUSH_WRITE)) {
-#ifdef TCL_THREADS
+#if TCL_THREADS
 	    if (rtPtr->thread != Tcl_GetCurrentThread()) {
 		Tcl_EventuallyFree(rtPtr,
 			(Tcl_FreeProc *) FreeReflectedTransform);
@@ -968,7 +968,7 @@ ReflectClose(
      * Are we in the correct thread?
      */
 
-#ifdef TCL_THREADS
+#if TCL_THREADS
     if (rtPtr->thread != Tcl_GetCurrentThread()) {
 	ForwardParam p;
 
@@ -1025,7 +1025,7 @@ ReflectClose(
 	 * under a channel by deleting the owning thread.
 	 */
 
-#ifdef TCL_THREADS
+#if TCL_THREADS
 	rtmPtr = GetThreadReflectedTransformMap();
 	hPtr = Tcl_FindHashEntry(&rtmPtr->map, TclGetString(rtPtr->handle));
 	if (hPtr) {
@@ -1767,7 +1767,7 @@ NewReflectedTransform(
 
     rtPtr->chan = NULL;
     rtPtr->methods = 0;
-#ifdef TCL_THREADS
+#if TCL_THREADS
     rtPtr->thread = Tcl_GetCurrentThread();
 #endif
     rtPtr->parent = parentChan;
@@ -2152,7 +2152,7 @@ DeleteReflectedTransformMap(
     Tcl_HashSearch hSearch;	 /* Search variable. */
     Tcl_HashEntry *hPtr;	 /* Search variable. */
     ReflectedTransform *rtPtr;
-#ifdef TCL_THREADS
+#if TCL_THREADS
     ForwardingResult *resultPtr;
     ForwardingEvent *evPtr;
     ForwardParam *paramPtr;
@@ -2182,7 +2182,7 @@ DeleteReflectedTransformMap(
     Tcl_DeleteHashTable(&rtmPtr->map);
     ckfree(&rtmPtr->map);
 
-#ifdef TCL_THREADS
+#if TCL_THREADS
     /*
      * The origin interpreter for one or more reflected channels is gone.
      */
@@ -2254,7 +2254,7 @@ DeleteReflectedTransformMap(
 #endif /* TCL_THREADS */
 }
 
-#ifdef TCL_THREADS
+#if TCL_THREADS
 /*
  *----------------------------------------------------------------------
  *
@@ -3088,7 +3088,7 @@ TransformRead(
      * Are we in the correct thread?
      */
 
-#ifdef TCL_THREADS
+#if TCL_THREADS
     if (rtPtr->thread != Tcl_GetCurrentThread()) {
 	ForwardParam p;
 
@@ -3144,7 +3144,7 @@ TransformWrite(
      * Are we in the correct thread?
      */
 
-#ifdef TCL_THREADS
+#if TCL_THREADS
     if (rtPtr->thread != Tcl_GetCurrentThread()) {
 	ForwardParam p;
 
@@ -3210,7 +3210,7 @@ TransformDrain(
      * Are we in the correct thread?
      */
 
-#ifdef TCL_THREADS
+#if TCL_THREADS
     if (rtPtr->thread != Tcl_GetCurrentThread()) {
 	ForwardParam p;
 
@@ -3260,7 +3260,7 @@ TransformFlush(
      * Are we in the correct thread?
      */
 
-#ifdef TCL_THREADS
+#if TCL_THREADS
     if (rtPtr->thread != Tcl_GetCurrentThread()) {
 	ForwardParam p;
 
@@ -3315,7 +3315,7 @@ TransformClear(
      * Are we in the correct thread?
      */
 
-#ifdef TCL_THREADS
+#if TCL_THREADS
     if (rtPtr->thread != Tcl_GetCurrentThread()) {
 	ForwardParam p;
 
@@ -3347,7 +3347,7 @@ TransformLimit(
      * Are we in the correct thread?
      */
 
-#ifdef TCL_THREADS
+#if TCL_THREADS
     if (rtPtr->thread != Tcl_GetCurrentThread()) {
 	ForwardParam p;
 

generic/tclIOSock.c

@@ -11,7 +11,7 @@
 
 #include "tclInt.h"
 
-#if defined(_WIN32) && defined(UNICODE)
+#if defined(_WIN32)
 /*
  * On Windows, we need to do proper Unicode->UTF-8 conversion.
  */

generic/tclIOUtil.c

@@ -139,7 +139,6 @@ Tcl_FSRenameFileProc		TclpObjRenameFile;
 Tcl_FSCreateDirectoryProc	TclpObjCreateDirectory;
 Tcl_FSCopyDirectoryProc		TclpObjCopyDirectory;
 Tcl_FSRemoveDirectoryProc	TclpObjRemoveDirectory;
-Tcl_FSUnloadFileProc		TclpUnloadFile;
 Tcl_FSLinkProc			TclpObjLink;
 Tcl_FSListVolumesProc		TclpObjListVolumes;
 
@@ -3154,8 +3153,8 @@ Tcl_FSLoadFile(
  * present and set to true (any integer > 0) then the unlink is skipped.
  */
 
-int
-TclSkipUnlink(
+static int
+skipUnlink(
     Tcl_Obj *shlibFile)
 {
     /*
@@ -3197,8 +3196,8 @@ TclSkipUnlink(
 #ifndef AUFS_SUPER_MAGIC
 #define AUFS_SUPER_MAGIC ('a' << 24 | 'u' << 16 | 'f' << 8 | 's')
 #endif /* AUFS_SUPER_MAGIC */
-	if ((statfs(Tcl_GetString (shlibFile), &fs) == 0) &&
-	    (fs.f_type == AUFS_SUPER_MAGIC)) {
+	if ((statfs(Tcl_GetString(shlibFile), &fs) == 0)
+		&& (fs.f_type == AUFS_SUPER_MAGIC)) {
 	    return 1;
 	}
     }
@@ -3413,7 +3412,7 @@ Tcl_LoadFile(
      * avoids any worries about leaving the copy laying around on exit.
      */
 
-    if (!TclSkipUnlink(copyToPtr) &&
+    if (!skipUnlink(copyToPtr) &&
 	    (Tcl_FSDeleteFile(copyToPtr) == TCL_OK)) {
 	Tcl_DecrRefCount(copyToPtr);
 
@@ -3682,30 +3681,10 @@ Tcl_FSUnloadFile(
 	}
 	return TCL_ERROR;
     }
-    TclpUnloadFile(handle);
-    return TCL_OK;
-}
-
-/*
- *----------------------------------------------------------------------
- *
- * TclpUnloadFile --
- *
- *	Unloads a library given its handle
- *
- * This function was once filesystem-specific, but has been made portable by
- * having TclpDlopen return a structure that includes procedure pointers.
- *
- *----------------------------------------------------------------------
- */
-
-void
-TclpUnloadFile(
-    Tcl_LoadHandle handle)
-{
     if (handle->unloadFileProcPtr != NULL) {
 	handle->unloadFileProcPtr(handle);
     }
+    return TCL_OK;
 }
 
 /*

generic/tclInt.decls

@@ -1075,7 +1075,7 @@ declare 9 win {
 }
 # new for 8.4.20+/8.5.12+ Cygwin only
 declare 10 win {
-    Tcl_DirEntry *TclpReaddir(DIR *dir)
+    Tcl_DirEntry *TclpReaddir(TclDIR *dir)
 }
 # Removed in 8.3.1 (for Win32s only):
 #declare 10 win {
@@ -1212,7 +1212,7 @@ declare 9 unix {
 # Added in 8.4:
 
 declare 10 unix {
-    Tcl_DirEntry *TclpReaddir(DIR *dir)
+    Tcl_DirEntry *TclpReaddir(TclDIR *dir)
 }
 # Slots 11 and 12 are forwarders for functions that were promoted to
 # generic Stubs

generic/tclInt.h

@@ -38,6 +38,23 @@
 
 #define AVOID_HACKS_FOR_ITCL 1
 
+
+/*
+ * Used to tag functions that are only to be visible within the module being
+ * built and not outside it (where this is supported by the linker).
+ * Also used in the platform-specific *Port.h files.
+ */
+
+#ifndef MODULE_SCOPE
+#   ifdef __cplusplus
+#	define MODULE_SCOPE extern "C"
+#   else
+#	define MODULE_SCOPE extern
+#   endif
+#endif
+
+
+
 /*
  * Common include files needed by most of the Tcl source files are included
  * here, so that system-dependent personalizations for the include files only
@@ -94,19 +111,6 @@ typedef int ptrdiff_t;
 #    endif
 #endif
 
-/*
- * Used to tag functions that are only to be visible within the module being
- * built and not outside it (where this is supported by the linker).
- */
-
-#ifndef MODULE_SCOPE
-#   ifdef __cplusplus
-#	define MODULE_SCOPE extern "C"
-#   else
-#	define MODULE_SCOPE extern
-#   endif
-#endif
-
 /*
  * Macros used to cast between pointers and integers (e.g. when storing an int
  * in ClientData), on 64-bit architectures they avoid gcc warning about "cast
@@ -136,6 +140,26 @@ typedef int ptrdiff_t;
 #   define vsnprintf _vsnprintf
 #endif
 
+#if !defined(TCL_THREADS)
+#   define TCL_THREADS 1
+#endif
+#if !TCL_THREADS
+#   undef TCL_DECLARE_MUTEX
+#   define TCL_DECLARE_MUTEX(name)
+#   undef  Tcl_MutexLock
+#   define Tcl_MutexLock(mutexPtr)
+#   undef  Tcl_MutexUnlock
+#   define Tcl_MutexUnlock(mutexPtr)
+#   undef  Tcl_MutexFinalize
+#   define Tcl_MutexFinalize(mutexPtr)
+#   undef  Tcl_ConditionNotify
+#   define Tcl_ConditionNotify(condPtr)
+#   undef  Tcl_ConditionWait
+#   define Tcl_ConditionWait(condPtr, mutexPtr, timePtr)
+#   undef  Tcl_ConditionFinalize
+#   define Tcl_ConditionFinalize(condPtr)
+#endif
+
 /*
  * The following procedures allow namespaces to be customized to support
  * special name resolution rules for commands/variables.
@@ -1146,6 +1170,10 @@ typedef struct CallFrame {
 				 * field contains an Object reference that has
 				 * been confirmed to refer to a class. Part of
 				 * TIP#257. */
+#define FRAME_IS_PRIVATE_DEFINE 0x10
+				/* Marks this frame as being used for private
+				 * declarations with [oo::define]. Usually
+				 * OR'd with FRAME_IS_OO_DEFINE. TIP#500. */
 
 /*
  * TIP #280
@@ -2760,6 +2788,10 @@ MODULE_SCOPE long	tclObjsShared[TCL_MAX_SHARED_OBJ_STATS];
 
 MODULE_SCOPE char	tclEmptyString;
 
+enum CheckEmptyStringResult {
+	TCL_EMPTYSTRING_UNKNOWN = -1, TCL_EMPTYSTRING_NO, TCL_EMPTYSTRING_YES
+};
+
 /*
  *----------------------------------------------------------------
  * Procedures shared among Tcl modules but not used by the outside world,
@@ -2900,6 +2932,7 @@ MODULE_SCOPE int	TclCheckArrayTraces(Tcl_Interp *interp, Var *varPtr,
 			    Var *arrayPtr, Tcl_Obj *name, int index);
 MODULE_SCOPE int	TclCheckBadOctal(Tcl_Interp *interp,
 			    const char *value);
+MODULE_SCOPE int	TclCheckEmptyString(Tcl_Obj *objPtr);
 MODULE_SCOPE int	TclChanCaughtErrorBypass(Tcl_Interp *interp,
 			    Tcl_Channel chan);
 MODULE_SCOPE Tcl_ObjCmdProc TclChannelNamesCmd;
@@ -2915,19 +2948,13 @@ MODULE_SCOPE void	TclContinuationsCopy(Tcl_Obj *objPtr,
 			    Tcl_Obj *originObjPtr);
 MODULE_SCOPE int	TclConvertElement(const char *src, int length,
 			    char *dst, int flags);
-MODULE_SCOPE Tcl_Command TclCreateObjCommandInNs (
-			    Tcl_Interp *interp,
-			    const char *cmdName,
-			    Tcl_Namespace *nsPtr,
-			    Tcl_ObjCmdProc *proc,
-			    ClientData clientData,
+MODULE_SCOPE Tcl_Command TclCreateObjCommandInNs(Tcl_Interp *interp,
+			    const char *cmdName, Tcl_Namespace *nsPtr,
+			    Tcl_ObjCmdProc *proc, ClientData clientData,
 			    Tcl_CmdDeleteProc *deleteProc);
-MODULE_SCOPE Tcl_Command TclCreateEnsembleInNs(
-			    Tcl_Interp *interp,
-			    const char *name,
-			    Tcl_Namespace *nameNamespacePtr,
-			    Tcl_Namespace *ensembleNamespacePtr,
-			    int flags);
+MODULE_SCOPE Tcl_Command TclCreateEnsembleInNs(Tcl_Interp *interp,
+			    const char *name, Tcl_Namespace *nameNamespacePtr,
+			    Tcl_Namespace *ensembleNamespacePtr, int flags);
 MODULE_SCOPE void	TclDeleteNamespaceVars(Namespace *nsPtr);
 MODULE_SCOPE int	TclFindDictElement(Tcl_Interp *interp,
 			    const char *dict, int dictLength,
@@ -2954,9 +2981,9 @@ MODULE_SCOPE char *	TclDStringAppendObj(Tcl_DString *dsPtr,
 MODULE_SCOPE char *	TclDStringAppendDString(Tcl_DString *dsPtr,
 			    Tcl_DString *toAppendPtr);
 MODULE_SCOPE Tcl_Obj *	TclDStringToObj(Tcl_DString *dsPtr);
-MODULE_SCOPE Tcl_Obj *const *	TclFetchEnsembleRoot(Tcl_Interp *interp,
+MODULE_SCOPE Tcl_Obj *const *TclFetchEnsembleRoot(Tcl_Interp *interp,
 			    Tcl_Obj *const *objv, int objc, int *objcPtr);
-MODULE_SCOPE Tcl_Namespace * 	TclEnsureNamespace(Tcl_Interp *interp,
+MODULE_SCOPE Tcl_Namespace *TclEnsureNamespace(Tcl_Interp *interp,
 			    Tcl_Namespace *namespacePtr);
 MODULE_SCOPE void	TclFinalizeAllocSubsystem(void);
 MODULE_SCOPE void	TclFinalizeAsync(void);
@@ -2984,15 +3011,11 @@ MODULE_SCOPE double	TclFloor(const mp_int *a);
 MODULE_SCOPE void	TclFormatNaN(double value, char *buffer);
 MODULE_SCOPE int	TclFSFileAttrIndex(Tcl_Obj *pathPtr,
 			    const char *attributeName, int *indexPtr);
-MODULE_SCOPE Tcl_Command TclNRCreateCommandInNs (
-			    Tcl_Interp *interp,
-			    const char *cmdName,
-			    Tcl_Namespace *nsPtr,
-			    Tcl_ObjCmdProc *proc,
-			    Tcl_ObjCmdProc *nreProc,
+MODULE_SCOPE Tcl_Command TclNRCreateCommandInNs(Tcl_Interp *interp,
+			    const char *cmdName, Tcl_Namespace *nsPtr,
+			    Tcl_ObjCmdProc *proc, Tcl_ObjCmdProc *nreProc,
 			    ClientData clientData,
 			    Tcl_CmdDeleteProc *deleteProc);
-
 MODULE_SCOPE int	TclNREvalFile(Tcl_Interp *interp, Tcl_Obj *pathPtr,
 			    const char *encodingName);
 MODULE_SCOPE void	TclFSUnloadTempFile(Tcl_LoadHandle loadHandle);
@@ -3173,7 +3196,8 @@ MODULE_SCOPE void	TclSetBgErrorHandler(Tcl_Interp *interp,
 			    Tcl_Obj *cmdPrefix);
 MODULE_SCOPE void	TclSetBignumIntRep(Tcl_Obj *objPtr,
 			    mp_int *bignumValue);
-MODULE_SCOPE int	TclSetBooleanFromAny(Tcl_Interp *interp, Tcl_Obj *objPtr);
+MODULE_SCOPE int	TclSetBooleanFromAny(Tcl_Interp *interp,
+			    Tcl_Obj *objPtr);
 MODULE_SCOPE void	TclSetCmdNameObj(Tcl_Interp *interp, Tcl_Obj *objPtr,
 			    Command *cmdPtr);
 MODULE_SCOPE void	TclSetDuplicateObj(Tcl_Obj *dupPtr, Tcl_Obj *objPtr);
@@ -3185,6 +3209,12 @@ MODULE_SCOPE void	TclSpellFix(Tcl_Interp *interp,
 			    Tcl_Obj *bad, Tcl_Obj *fix);
 MODULE_SCOPE void *	TclStackRealloc(Tcl_Interp *interp, void *ptr,
 			    int numBytes);
+typedef int (*memCmpFn_t)(const void*, const void*, size_t);
+MODULE_SCOPE int	TclStringCmp(Tcl_Obj *value1Ptr, Tcl_Obj *value2Ptr,
+			    int checkEq, int nocase, int reqlength);
+MODULE_SCOPE int	TclStringCmpOpts(Tcl_Interp *interp, int objc,
+			    Tcl_Obj *const objv[], int *nocase,
+			    int *reqlength);
 MODULE_SCOPE int	TclStringMatch(const char *str, int strLen,
 			    const char *pattern, int ptnLen, int flags);
 MODULE_SCOPE int	TclStringMatchObj(Tcl_Obj *stringObj,
@@ -3233,8 +3263,8 @@ MODULE_SCOPE void *	TclpThreadCreateKey(void);
 MODULE_SCOPE void	TclpThreadDeleteKey(void *keyPtr);
 MODULE_SCOPE void	TclpThreadSetMasterTSD(void *tsdKeyPtr, void *ptr);
 MODULE_SCOPE void *	TclpThreadGetMasterTSD(void *tsdKeyPtr);
-
-MODULE_SCOPE void	TclErrorStackResetIf(Tcl_Interp *interp, const char *msg, int length);
+MODULE_SCOPE void	TclErrorStackResetIf(Tcl_Interp *interp,
+			    const char *msg, int length);
 
 /*
  *----------------------------------------------------------------
@@ -4087,7 +4117,7 @@ typedef enum TclProcessWaitStatus {
     TCL_PROCESS_EXITED = 1,	/* Process has exited. */
     TCL_PROCESS_SIGNALED = 2,	/* Child killed because of a signal. */
     TCL_PROCESS_STOPPED = 3,	/* Child suspended because of a signal. */
-    TCL_PROCESS_UNKNOWN_STATUS = 4 
+    TCL_PROCESS_UNKNOWN_STATUS = 4
 				/* Child wait status didn't make sense. */
 } TclProcessWaitStatus;
 
@@ -4198,6 +4228,10 @@ typedef const char *TclDTraceStr;
 	} \
     }
 
+#if TCL_THREADS && !defined(USE_THREAD_ALLOC)
+#   define USE_THREAD_ALLOC 1
+#endif
+
 #if defined(PURIFY)
 
 /*
@@ -4215,7 +4249,7 @@ typedef const char *TclDTraceStr;
 
 #undef USE_THREAD_ALLOC
 #undef USE_TCLALLOC
-#elif defined(TCL_THREADS) && defined(USE_THREAD_ALLOC)
+#elif TCL_THREADS && defined(USE_THREAD_ALLOC)
 
 /*
  * The TCL_THREADS mode is like the regular mode but allocates Tcl_Obj's from
@@ -4280,7 +4314,7 @@ MODULE_SCOPE void	TclpFreeAllocCache(void *);
 #   define USE_TCLALLOC 0
 #endif
 
-#ifdef TCL_THREADS
+#if TCL_THREADS
 /* declared in tclObj.c */
 MODULE_SCOPE Tcl_Mutex	tclObjMutex;
 #endif
@@ -4540,6 +4574,9 @@ MODULE_SCOPE void	TclDbInitNewObj(Tcl_Obj *objPtr, const char *file,
  */
 
 MODULE_SCOPE int	TclIsPureByteArray(Tcl_Obj *objPtr);
+#define TclIsPureDict(objPtr) \
+	(((objPtr)->bytes==NULL) && ((objPtr)->typePtr==&tclDictType))
+
 
 /*
  *----------------------------------------------------------------

generic/tclIntPlatDecls.h

@@ -13,11 +13,6 @@
 #ifndef _TCLINTPLATDECLS
 #define _TCLINTPLATDECLS
 
-#ifdef _WIN32
-#   define Tcl_DirEntry void
-#   define DIR void
-#endif
-
 #undef TCL_STORAGE_CLASS
 #ifdef BUILD_tcl
 #   define TCL_STORAGE_CLASS DLLEXPORT
@@ -72,7 +67,7 @@ EXTERN int		TclUnixWaitForFile(int fd, int mask, int timeout);
 /* 9 */
 EXTERN TclFile		TclpCreateTempFile(const char *contents);
 /* 10 */
-EXTERN Tcl_DirEntry *	TclpReaddir(DIR *dir);
+EXTERN Tcl_DirEntry *	TclpReaddir(TclDIR *dir);
 /* 11 */
 EXTERN struct tm *	TclpLocaltime_unix(const time_t *clock);
 /* 12 */
@@ -129,7 +124,7 @@ EXTERN int		TclpGetPid(Tcl_Pid pid);
 /* 9 */
 EXTERN int		TclWinGetPlatformId(void);
 /* 10 */
-EXTERN Tcl_DirEntry *	TclpReaddir(DIR *dir);
+EXTERN Tcl_DirEntry *	TclpReaddir(TclDIR *dir);
 /* 11 */
 EXTERN void		TclGetAndDetachPids(Tcl_Interp *interp,
 				Tcl_Channel chan);
@@ -206,7 +201,7 @@ EXTERN int		TclUnixWaitForFile(int fd, int mask, int timeout);
 /* 9 */
 EXTERN TclFile		TclpCreateTempFile(const char *contents);
 /* 10 */
-EXTERN Tcl_DirEntry *	TclpReaddir(DIR *dir);
+EXTERN Tcl_DirEntry *	TclpReaddir(TclDIR *dir);
 /* 11 */
 EXTERN struct tm *	TclpLocaltime_unix(const time_t *clock);
 /* 12 */
@@ -269,7 +264,7 @@ typedef struct TclIntPlatStubs {
     TclFile (*tclpOpenFile) (const char *fname, int mode); /* 7 */
     int (*tclUnixWaitForFile) (int fd, int mask, int timeout); /* 8 */
     TclFile (*tclpCreateTempFile) (const char *contents); /* 9 */
-    Tcl_DirEntry * (*tclpReaddir) (DIR *dir); /* 10 */
+    Tcl_DirEntry * (*tclpReaddir) (TclDIR *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 */
@@ -302,7 +297,7 @@ typedef struct TclIntPlatStubs {
     int (*tclWinSetSockOpt) (SOCKET s, int level, int optname, const char *optval, int optlen); /* 7 */
     int (*tclpGetPid) (Tcl_Pid pid); /* 8 */
     int (*tclWinGetPlatformId) (void); /* 9 */
-    Tcl_DirEntry * (*tclpReaddir) (DIR *dir); /* 10 */
+    Tcl_DirEntry * (*tclpReaddir) (TclDIR *dir); /* 10 */
     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 */
@@ -335,7 +330,7 @@ typedef struct TclIntPlatStubs {
     TclFile (*tclpOpenFile) (const char *fname, int mode); /* 7 */
     int (*tclUnixWaitForFile) (int fd, int mask, int timeout); /* 8 */
     TclFile (*tclpCreateTempFile) (const char *contents); /* 9 */
-    Tcl_DirEntry * (*tclpReaddir) (DIR *dir); /* 10 */
+    Tcl_DirEntry * (*tclpReaddir) (TclDIR *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 */

generic/tclOO.c

@@ -31,6 +31,7 @@ static const struct {
     {"export", TclOODefineExportObjCmd, 0},
     {"forward", TclOODefineForwardObjCmd, 0},
     {"method", TclOODefineMethodObjCmd, 0},
+    {"private", TclOODefinePrivateObjCmd, 0},
     {"renamemethod", TclOODefineRenameMethodObjCmd, 0},
     {"self", TclOODefineSelfObjCmd, 0},
     {"unexport", TclOODefineUnexportObjCmd, 0},
@@ -41,6 +42,7 @@ static const struct {
     {"export", TclOODefineExportObjCmd, 1},
     {"forward", TclOODefineForwardObjCmd, 1},
     {"method", TclOODefineMethodObjCmd, 1},
+    {"private", TclOODefinePrivateObjCmd, 1},
     {"renamemethod", TclOODefineRenameMethodObjCmd, 1},
     {"self", TclOODefineObjSelfObjCmd, 0},
     {"unexport", TclOODefineUnexportObjCmd, 1},
@@ -100,6 +102,13 @@ static int		PrivateObjectCmd(ClientData clientData,
 static int		PrivateNRObjectCmd(ClientData clientData,
 			    Tcl_Interp *interp, int objc,
 			    Tcl_Obj *const *objv);
+static int		MyClassObjCmd(ClientData clientData,
+			    Tcl_Interp *interp, int objc,
+			    Tcl_Obj *const *objv);
+static int		MyClassNRObjCmd(ClientData clientData,
+			    Tcl_Interp *interp, int objc,
+			    Tcl_Obj *const *objv);
+static void		MyClassDeleted(ClientData clientData);
 
 /*
  * Methods in the oo::object and oo::class classes. First, we define a helper
@@ -150,65 +159,10 @@ static const char *initScript =
 /* " tcloo.tcl OO_LIBRARY oo::library;"; */
 
 /*
- * The scripted part of the definitions of slots.
+ * The scripted part of the definitions of TclOO.
  */
 
-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;"
-"        }"
-"    }"
-"}";
+#include "tclOOScript.h"
 
 /*
  * The actual definition of the variable holding the TclOO stub table.
@@ -358,7 +312,7 @@ InitFoundation(
     ThreadLocalData *tsdPtr =
 	    Tcl_GetThreadData(&tsdKey, sizeof(ThreadLocalData));
     Foundation *fPtr = ckalloc(sizeof(Foundation));
-    Tcl_Obj *namePtr, *argsPtr, *bodyPtr;
+    Tcl_Obj *namePtr;
     Tcl_DString buffer;
     Command *cmdPtr;
     int i;
@@ -437,18 +391,6 @@ InitFoundation(
 	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);
-    TclDecrRefCount(argsPtr);
-
     /*
      * Finish setting up the class of classes by marking the 'new' method as
      * private; classes, unlike general objects, must have explicit names. We
@@ -489,7 +431,12 @@ InitFoundation(
     if (TclOODefineSlots(fPtr) != TCL_OK) {
 	return TCL_ERROR;
     }
-    return Tcl_EvalEx(interp, slotScript, -1, 0);
+
+    /*
+     * Evaluate the remaining definitions, which are a compiled-in Tcl script.
+     */
+
+    return Tcl_EvalEx(interp, tclOOSetupScript, -1, 0);
 }
 
 /*
@@ -795,6 +742,9 @@ AllocObject(
 
     oPtr->myCommand = TclNRCreateCommandInNs(interp, "my", oPtr->namespacePtr,
 	    PrivateObjectCmd, PrivateNRObjectCmd, oPtr, MyDeleted);
+    oPtr->myclassCommand = TclNRCreateCommandInNs(interp, "myclass",
+	    oPtr->namespacePtr, MyClassObjCmd, MyClassNRObjCmd, oPtr,
+            MyClassDeleted);
     return oPtr;
 }
 
@@ -822,12 +772,12 @@ SquelchCachedName(
 /*
  * ----------------------------------------------------------------------
  *
- * MyDeleted --
+ * MyDeleted, MyClassDeleted --
  *
- *	This callback is triggered when the object's [my] command is deleted
- *	by any mechanism. It just marks the object as not having a [my]
- *	command, and so prevents cleanup of that when the object itself is
- *	deleted.
+ *	These callbacks are triggered when the object's [my] or [myclass]
+ *	commands are deleted by any mechanism. They just mark the object as
+ *	not having a [my] command or [myclass] command, and so prevent cleanup
+ *	of those commands when the object itself is deleted.
  *
  * ----------------------------------------------------------------------
  */
@@ -841,6 +791,14 @@ MyDeleted(
 
     oPtr->myCommand = NULL;
 }
+
+static void
+MyClassDeleted(
+    ClientData clientData)
+{
+    Object *oPtr = clientData;
+    oPtr->myclassCommand = NULL;
+}
 
 /*
  * ----------------------------------------------------------------------
@@ -993,6 +951,7 @@ ReleaseClassContents(
     Method *mPtr;
     Foundation *fPtr = oPtr->fPtr;
     Tcl_Obj *variableObj;
+    PrivateVariableMapping *privateVariable;
 
     /*
      * Sanity check!
@@ -1099,6 +1058,14 @@ ReleaseClassContents(
 	ckfree(clsPtr->variables.list);
     }
 
+    FOREACH_STRUCT(privateVariable, clsPtr->privateVariables) {
+	TclDecrRefCount(privateVariable->variableObj);
+	TclDecrRefCount(privateVariable->fullNameObj);
+    }
+    if (i) {
+	ckfree(clsPtr->privateVariables.list);
+    }
+
     if (IsRootClass(oPtr) && !Deleted(fPtr->objectCls->thisPtr)) {
 	Tcl_DeleteCommandFromToken(interp, fPtr->objectCls->thisPtr->command);
     }
@@ -1128,6 +1095,7 @@ ObjectNamespaceDeleted(
     Class *mixinPtr;
     Method *mPtr;
     Tcl_Obj *filterObj, *variableObj;
+    PrivateVariableMapping *privateVariable;
     Tcl_Interp *interp = oPtr->fPtr->interp;
     int i;
 
@@ -1162,7 +1130,7 @@ ObjectNamespaceDeleted(
 
     if (!Tcl_InterpDeleted(interp) && !(oPtr->flags & DESTRUCTOR_CALLED)) {
 	CallContext *contextPtr =
-		TclOOGetCallContext(oPtr, NULL, DESTRUCTOR, NULL);
+		TclOOGetCallContext(oPtr, NULL, DESTRUCTOR, NULL, NULL, NULL);
 	int result;
 
 	Tcl_InterpState state;
@@ -1203,6 +1171,9 @@ ObjectNamespaceDeleted(
 	Tcl_DeleteCommandFromToken(oPtr->fPtr->interp, oPtr->command);
     }
 
+    if (oPtr->myclassCommand) {
+	Tcl_DeleteCommandFromToken(oPtr->fPtr->interp, oPtr->myclassCommand);
+    }
     if (oPtr->myCommand) {
 	Tcl_DeleteCommandFromToken(oPtr->fPtr->interp, oPtr->myCommand);
     }
@@ -1248,6 +1219,14 @@ ObjectNamespaceDeleted(
 	ckfree(oPtr->variables.list);
     }
 
+    FOREACH_STRUCT(privateVariable, oPtr->privateVariables) {
+	TclDecrRefCount(privateVariable->variableObj);
+	TclDecrRefCount(privateVariable->fullNameObj);
+    }
+    if (i) {
+	ckfree(oPtr->privateVariables.list);
+    }
+
     if (oPtr->chainCache) {
 	TclOODeleteChainCache(oPtr->chainCache);
     }
@@ -1631,7 +1610,7 @@ Tcl_NewObjectInstance(
 
     if (objc >= 0) {
 	CallContext *contextPtr =
-		TclOOGetCallContext(oPtr, NULL, CONSTRUCTOR, NULL);
+		TclOOGetCallContext(oPtr, NULL, CONSTRUCTOR, NULL, NULL, NULL);
 
 	if (contextPtr != NULL) {
 	    int isRoot, result;
@@ -1704,7 +1683,7 @@ TclNRNewObjectInstance(
 	*objectPtr = (Tcl_Object) oPtr;
 	return TCL_OK;
     }
-    contextPtr = TclOOGetCallContext(oPtr, NULL, CONSTRUCTOR, NULL);
+    contextPtr = TclOOGetCallContext(oPtr, NULL, CONSTRUCTOR, NULL, NULL, NULL);
     if (contextPtr == NULL) {
 	*objectPtr = (Tcl_Object) oPtr;
 	return TCL_OK;
@@ -1884,6 +1863,7 @@ Tcl_CopyObjectInstance(
     Class *mixinPtr;
     CallContext *contextPtr;
     Tcl_Obj *keyPtr, *filterObj, *variableObj, *args[3];
+    PrivateVariableMapping *privateVariable;
     int i, result;
 
     /*
@@ -1953,7 +1933,7 @@ Tcl_CopyObjectInstance(
     }
 
     /*
-     * Copy the object's variable resolution list to the new object.
+     * Copy the object's variable resolution lists to the new object.
      */
 
     DUPLICATE(o2Ptr->variables, oPtr->variables, Tcl_Obj *);
@@ -1961,6 +1941,13 @@ Tcl_CopyObjectInstance(
 	Tcl_IncrRefCount(variableObj);
     }
 
+    DUPLICATE(o2Ptr->privateVariables, oPtr->privateVariables,
+	    PrivateVariableMapping);
+    FOREACH_STRUCT(privateVariable, o2Ptr->privateVariables) {
+	Tcl_IncrRefCount(privateVariable->variableObj);
+	Tcl_IncrRefCount(privateVariable->fullNameObj);
+    }
+
     /*
      * 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
@@ -2049,7 +2036,7 @@ Tcl_CopyObjectInstance(
 	}
 
 	/*
-	 * Copy the source class's variable resolution list.
+	 * Copy the source class's variable resolution lists.
 	 */
 
 	DUPLICATE(cls2Ptr->variables, clsPtr->variables, Tcl_Obj *);
@@ -2057,6 +2044,13 @@ Tcl_CopyObjectInstance(
 	    Tcl_IncrRefCount(variableObj);
 	}
 
+	DUPLICATE(cls2Ptr->privateVariables, clsPtr->privateVariables,
+		PrivateVariableMapping);
+	FOREACH_STRUCT(privateVariable, cls2Ptr->privateVariables) {
+	    Tcl_IncrRefCount(privateVariable->variableObj);
+	    Tcl_IncrRefCount(privateVariable->fullNameObj);
+	}
+
 	/*
 	 * Duplicate the source class's mixins (which cannot be circular
 	 * references to the duplicate).
@@ -2129,7 +2123,8 @@ Tcl_CopyObjectInstance(
     }
 
     TclResetRewriteEnsemble(interp, 1);
-    contextPtr = TclOOGetCallContext(o2Ptr, oPtr->fPtr->clonedName, 0, NULL);
+    contextPtr = TclOOGetCallContext(o2Ptr, oPtr->fPtr->clonedName, 0, NULL,
+	    NULL, NULL);
     if (contextPtr) {
 	args[0] = TclOOObjectName(interp, o2Ptr);
 	args[1] = oPtr->fPtr->clonedName;
@@ -2499,6 +2494,43 @@ TclOOInvokeObject(
     }
 }
 
+/*
+ * ----------------------------------------------------------------------
+ *
+ * MyClassObjCmd, MyClassNRObjCmd --
+ *
+ *	Special trap door to allow an object to delegate simply to its class.
+ *
+ * ----------------------------------------------------------------------
+ */
+
+static int
+MyClassObjCmd(
+    ClientData clientData,
+    Tcl_Interp *interp,
+    int objc,
+    Tcl_Obj *const *objv)
+{
+    return Tcl_NRCallObjProc(interp, MyClassNRObjCmd, clientData, objc, objv);
+}
+
+static int
+MyClassNRObjCmd(
+    ClientData clientData,
+    Tcl_Interp *interp,
+    int objc,
+    Tcl_Obj *const *objv)
+{
+    Object *oPtr = clientData;
+
+    if (objc < 2) {
+	Tcl_WrongNumArgs(interp, 1, objv, "methodName ?arg ...?");
+	return TCL_ERROR;
+    }
+    return TclOOObjectCmdCore(oPtr->selfCls->thisPtr, interp, objc, objv, 0,
+	    NULL);
+}
+
 /*
  * ----------------------------------------------------------------------
  *
@@ -2526,6 +2558,9 @@ TclOOObjectCmdCore(
 {
     CallContext *contextPtr;
     Tcl_Obj *methodNamePtr;
+    CallFrame *framePtr = ((Interp *) interp)->varFramePtr;
+    Object *callerObjPtr = NULL;
+    Class *callerClsPtr = NULL;
     int result;
 
     /*
@@ -2539,6 +2574,24 @@ TclOOObjectCmdCore(
 	goto noMapping;
     }
 
+    /*
+     * Determine if we're in a context that can see the extra, private methods
+     * in this class.
+     */
+
+    if (framePtr->isProcCallFrame & FRAME_IS_METHOD) {
+	CallContext *callerContextPtr = framePtr->clientData;
+	Method *callerMethodPtr =
+		callerContextPtr->callPtr->chain[callerContextPtr->index].mPtr;
+
+	if (callerMethodPtr->declaringObjectPtr) {
+	    callerObjPtr = callerMethodPtr->declaringObjectPtr;
+	}
+	if (callerMethodPtr->declaringClassPtr) {
+	    callerClsPtr = callerMethodPtr->declaringClassPtr;
+	}
+    }
+
     /*
      * Give plugged in code a chance to remap the method name.
      */
@@ -2566,7 +2619,8 @@ TclOOObjectCmdCore(
 
 	Tcl_IncrRefCount(mappedMethodName);
 	contextPtr = TclOOGetCallContext(oPtr, mappedMethodName,
-		flags | (oPtr->flags & FILTER_HANDLING), methodNamePtr);
+		flags | (oPtr->flags & FILTER_HANDLING), callerObjPtr,
+		callerClsPtr, methodNamePtr);
 	TclDecrRefCount(mappedMethodName);
 	if (contextPtr == NULL) {
 	    Tcl_SetObjResult(interp, Tcl_ObjPrintf(
@@ -2583,7 +2637,8 @@ TclOOObjectCmdCore(
 
     noMapping:
 	contextPtr = TclOOGetCallContext(oPtr, methodNamePtr,
-		flags | (oPtr->flags & FILTER_HANDLING), NULL);
+		flags | (oPtr->flags & FILTER_HANDLING), callerObjPtr,
+		callerClsPtr, NULL);
 	if (contextPtr == NULL) {
 	    Tcl_SetObjResult(interp, Tcl_ObjPrintf(
 		    "impossible to invoke method \"%s\": no defined method or"

generic/tclOO.decls

@@ -58,12 +58,12 @@ declare 10 {
 }
 declare 11 {
     Tcl_Method Tcl_NewInstanceMethod(Tcl_Interp *interp, Tcl_Object object,
-	    Tcl_Obj *nameObj, int isPublic, const Tcl_MethodType *typePtr,
+	    Tcl_Obj *nameObj, int flags, const Tcl_MethodType *typePtr,
 	    ClientData clientData)
 }
 declare 12 {
     Tcl_Method Tcl_NewMethod(Tcl_Interp *interp, Tcl_Class cls,
-	    Tcl_Obj *nameObj, int isPublic, const Tcl_MethodType *typePtr,
+	    Tcl_Obj *nameObj, int flags, const Tcl_MethodType *typePtr,
 	    ClientData clientData)
 }
 declare 13 {
@@ -126,6 +126,9 @@ declare 27 {
 declare 28 {
     Tcl_Obj *Tcl_GetObjectName(Tcl_Interp *interp, Tcl_Object object)
 }
+declare 29 {
+    int Tcl_MethodIsPrivate(Tcl_Method method)
+}
 
 ######################################################################
 # Private API, exposed to support advanced OO systems that plug in on top of

generic/tclOO.h

@@ -99,6 +99,15 @@ typedef struct {
  */
 
 #define TCL_OO_METHOD_VERSION_CURRENT 1
+
+/*
+ * Visibility constants for the flags parameter to Tcl_NewMethod and
+ * Tcl_NewInstanceMethod.
+ */
+
+#define TCL_OO_METHOD_PUBLIC		1
+#define TCL_OO_METHOD_UNEXPORTED	0
+#define TCL_OO_METHOD_PRIVATE		0x20
 
 /*
  * The type of some object (or class) metadata. This describes how to delete

generic/tclOOBasic.c

@@ -83,7 +83,7 @@ TclOO_Class_Constructor(
     Tcl_Obj *const *objv)
 {
     Object *oPtr = (Object *) Tcl_ObjectContextObject(context);
-    Tcl_Obj **invoke;
+    Tcl_Obj **invoke, *nameObj;
 
     if (objc-1 > Tcl_ObjectContextSkippedArgs(context)) {
 	Tcl_WrongNumArgs(interp, Tcl_ObjectContextSkippedArgs(context), objv,
@@ -93,6 +93,17 @@ TclOO_Class_Constructor(
 	return TCL_OK;
     }
 
+    /*
+     * Make the class definition delegate. This is special; it doesn't reenter
+     * here (and the class definition delegate doesn't run any constructors).
+     */
+
+    nameObj = Tcl_NewStringObj(oPtr->namespacePtr->fullName, -1);
+    Tcl_AppendToObj(nameObj, ":: oo ::delegate", -1);
+    Tcl_NewObjectInstance(interp, (Tcl_Class) oPtr->fPtr->classCls,
+	    TclGetString(nameObj), NULL, -1, NULL, -1);
+    Tcl_DecrRefCount(nameObj);
+
     /*
      * Delegate to [oo::define] to do the work.
      */
@@ -111,7 +122,7 @@ TclOO_Class_Constructor(
     Tcl_IncrRefCount(invoke[1]);
     Tcl_IncrRefCount(invoke[2]);
     TclNRAddCallback(interp, DecrRefsPostClassConstructor,
-	    invoke, NULL, NULL, NULL);
+	    invoke, oPtr, NULL, NULL);
 
     /*
      * Tricky point: do not want the extra reported level in the Tcl stack
@@ -128,12 +139,27 @@ DecrRefsPostClassConstructor(
     int result)
 {
     Tcl_Obj **invoke = data[0];
+    Object *oPtr = data[1];
+    Tcl_InterpState saved;
+    int code;
 
     TclDecrRefCount(invoke[0]);
     TclDecrRefCount(invoke[1]);
     TclDecrRefCount(invoke[2]);
+    invoke[0] = Tcl_NewStringObj("::oo::MixinClassDelegates", -1);
+    invoke[1] = TclOOObjectName(interp, oPtr);
+    Tcl_IncrRefCount(invoke[0]);
+    Tcl_IncrRefCount(invoke[1]);
+    saved = Tcl_SaveInterpState(interp, result);
+    code = Tcl_EvalObjv(interp, 2, invoke, 0);
+    TclDecrRefCount(invoke[0]);
+    TclDecrRefCount(invoke[1]);
     ckfree(invoke);
-    return result;
+    if (code != TCL_OK) {
+	Tcl_DiscardInterpState(saved);
+	return code;
+    }
+    return Tcl_RestoreInterpState(interp, saved);
 }
 
 /*
@@ -347,7 +373,8 @@ TclOO_Object_Destroy(
     }
     if (!(oPtr->flags & DESTRUCTOR_CALLED)) {
 	oPtr->flags |= DESTRUCTOR_CALLED;
-	contextPtr = TclOOGetCallContext(oPtr, NULL, DESTRUCTOR, NULL);
+	contextPtr = TclOOGetCallContext(oPtr, NULL, DESTRUCTOR, NULL, NULL,
+		NULL);
 	if (contextPtr != NULL) {
 	    contextPtr->callPtr->flags |= DESTRUCTOR;
 	    contextPtr->skip = 0;
@@ -499,9 +526,12 @@ TclOO_Object_Unknown(
     Tcl_Obj *const *objv)	/* The actual arguments. */
 {
     CallContext *contextPtr = (CallContext *) context;
+    Object *callerObj = NULL;
+    Class *callerCls = NULL;
     Object *oPtr = contextPtr->oPtr;
     const char **methodNames;
     int numMethodNames, i, skip = Tcl_ObjectContextSkippedArgs(context);
+    CallFrame *framePtr = ((Interp *) interp)->varFramePtr;
     Tcl_Obj *errorMsg;
 
     /*
@@ -515,11 +545,32 @@ TclOO_Object_Unknown(
 	return TCL_ERROR;
     }
 
+    /*
+     * Determine if the calling context should know about extra private
+     * methods, and if so, which.
+     */
+
+    if (framePtr->isProcCallFrame & FRAME_IS_METHOD) {
+	CallContext *callerContext = framePtr->clientData;
+	Method *mPtr = callerContext->callPtr->chain[
+		    callerContext->index].mPtr;
+
+	if (mPtr->declaringObjectPtr) {
+	    if (oPtr == mPtr->declaringObjectPtr) {
+		callerObj = mPtr->declaringObjectPtr;
+	    }
+	} else {
+	    if (TclOOIsReachable(mPtr->declaringClassPtr, oPtr->selfCls)) {
+		callerCls = mPtr->declaringClassPtr;
+	    }
+	}
+    }
+
     /*
      * Get the list of methods that we want to know about.
      */
 
-    numMethodNames = TclOOGetSortedMethodList(oPtr,
+    numMethodNames = TclOOGetSortedMethodList(oPtr, callerObj, callerCls,
 	    contextPtr->callPtr->flags & PUBLIC_METHOD, &methodNames);
 
     /*
@@ -684,6 +735,7 @@ TclOO_Object_VarName(
 {
     Var *varPtr, *aryVar;
     Tcl_Obj *varNamePtr, *argPtr;
+    CallFrame *framePtr = ((Interp *) interp)->varFramePtr;
     const char *arg;
 
     if (Tcl_ObjectContextSkippedArgs(context)+1 != objc) {
@@ -709,6 +761,58 @@ TclOO_Object_VarName(
 	Tcl_Namespace *namespacePtr =
 		Tcl_GetObjectNamespace(Tcl_ObjectContextObject(context));
 
+	/*
+	 * Private method handling. [TIP 500]
+	 *
+	 * If we're in a context that can see some private methods of an
+	 * object, we may need to precede a variable name with its prefix.
+	 * This is a little tricky as we need to check through the inheritance
+	 * hierarchy when the method was declared by a class to see if the
+	 * current object is an instance of that class.
+	 */
+
+	if (framePtr->isProcCallFrame & FRAME_IS_METHOD) {
+	    Object *oPtr = (Object *) Tcl_ObjectContextObject(context);
+	    CallContext *callerContext = framePtr->clientData;
+	    Method *mPtr = callerContext->callPtr->chain[
+		    callerContext->index].mPtr;
+	    PrivateVariableMapping *pvPtr;
+	    int i;
+
+	    if (mPtr->declaringObjectPtr == oPtr) {
+		FOREACH_STRUCT(pvPtr, oPtr->privateVariables) {
+		    if (!strcmp(Tcl_GetString(pvPtr->variableObj),
+			    Tcl_GetString(argPtr))) {
+			argPtr = pvPtr->fullNameObj;
+			break;
+		    }
+		}
+	    } else if (mPtr->declaringClassPtr &&
+		    mPtr->declaringClassPtr->privateVariables.num) {
+		Class *clsPtr = mPtr->declaringClassPtr;
+		int isInstance = TclOOIsReachable(clsPtr, oPtr->selfCls);
+		Class *mixinCls;
+
+		if (!isInstance) {
+		    FOREACH(mixinCls, oPtr->mixins) {
+			if (TclOOIsReachable(clsPtr, mixinCls)) {
+			    isInstance = 1;
+			    break;
+			}
+		    }
+		}
+		if (isInstance) {
+		    FOREACH_STRUCT(pvPtr, clsPtr->privateVariables) {
+			if (!strcmp(Tcl_GetString(pvPtr->variableObj),
+				Tcl_GetString(argPtr))) {
+			    argPtr = pvPtr->fullNameObj;
+			    break;
+			}
+		    }
+		}
+	    }
+	}
+
 	varNamePtr = Tcl_NewStringObj(namespacePtr->fullName, -1);
 	Tcl_AppendToObj(varNamePtr, "::", 2);
 	Tcl_AppendObjToObj(varNamePtr, argPtr);
@@ -729,26 +833,16 @@ TclOO_Object_VarName(
 
     varNamePtr = Tcl_NewObj();
     if (aryVar != NULL) {
-	Tcl_HashEntry *hPtr;
-	Tcl_HashSearch search;
-
 	Tcl_GetVariableFullName(interp, (Tcl_Var) aryVar, varNamePtr);
 
 	/*
 	 * WARNING! This code pokes inside the implementation of hash tables!
 	 */
 
-	hPtr = Tcl_FirstHashEntry((Tcl_HashTable *) aryVar->value.tablePtr,
-		&search);
-	while (hPtr != NULL) {
-	    if (varPtr == Tcl_GetHashValue(hPtr)) {
-		Tcl_AppendToObj(varNamePtr, "(", -1);
-		Tcl_AppendObjToObj(varNamePtr, hPtr->key.objPtr);
-		Tcl_AppendToObj(varNamePtr, ")", -1);
-		break;
-	    }
-	    hPtr = Tcl_NextHashEntry(&search);
-	}
+	Tcl_AppendToObj(varNamePtr, "(", -1);
+	Tcl_AppendObjToObj(varNamePtr, ((VarInHash *)
+		varPtr)->entry.key.objPtr);
+	Tcl_AppendToObj(varNamePtr, ")", -1);
     } else {
 	Tcl_GetVariableFullName(interp, (Tcl_Var) varPtr, varNamePtr);
     }

generic/tclOODecls.h

@@ -59,11 +59,11 @@ TCLAPI Tcl_Obj *	Tcl_MethodName(Tcl_Method method);
 /* 11 */
 TCLAPI Tcl_Method	Tcl_NewInstanceMethod(Tcl_Interp *interp,
 				Tcl_Object object, Tcl_Obj *nameObj,
-				int isPublic, const Tcl_MethodType *typePtr,
+				int flags, const Tcl_MethodType *typePtr,
 				ClientData clientData);
 /* 12 */
 TCLAPI Tcl_Method	Tcl_NewMethod(Tcl_Interp *interp, Tcl_Class cls,
-				Tcl_Obj *nameObj, int isPublic,
+				Tcl_Obj *nameObj, int flags,
 				const Tcl_MethodType *typePtr,
 				ClientData clientData);
 /* 13 */
@@ -116,6 +116,8 @@ TCLAPI void		Tcl_ClassSetDestructor(Tcl_Interp *interp,
 /* 28 */
 TCLAPI Tcl_Obj *	Tcl_GetObjectName(Tcl_Interp *interp,
 				Tcl_Object object);
+/* 29 */
+TCLAPI int		Tcl_MethodIsPrivate(Tcl_Method method);
 
 typedef struct {
     const struct TclOOIntStubs *tclOOIntStubs;
@@ -136,8 +138,8 @@ typedef struct TclOOStubs {
     int (*tcl_MethodIsPublic) (Tcl_Method method); /* 8 */
     int (*tcl_MethodIsType) (Tcl_Method method, const Tcl_MethodType *typePtr, ClientData *clientDataPtr); /* 9 */
     Tcl_Obj * (*tcl_MethodName) (Tcl_Method method); /* 10 */
-    Tcl_Method (*tcl_NewInstanceMethod) (Tcl_Interp *interp, Tcl_Object object, Tcl_Obj *nameObj, int isPublic, const Tcl_MethodType *typePtr, ClientData clientData); /* 11 */
-    Tcl_Method (*tcl_NewMethod) (Tcl_Interp *interp, Tcl_Class cls, Tcl_Obj *nameObj, int isPublic, const Tcl_MethodType *typePtr, ClientData clientData); /* 12 */
+    Tcl_Method (*tcl_NewInstanceMethod) (Tcl_Interp *interp, Tcl_Object object, Tcl_Obj *nameObj, int flags, const Tcl_MethodType *typePtr, ClientData clientData); /* 11 */
+    Tcl_Method (*tcl_NewMethod) (Tcl_Interp *interp, Tcl_Class cls, Tcl_Obj *nameObj, int flags, const Tcl_MethodType *typePtr, ClientData clientData); /* 12 */
     Tcl_Object (*tcl_NewObjectInstance) (Tcl_Interp *interp, Tcl_Class cls, const char *nameStr, const char *nsNameStr, int objc, Tcl_Obj *const *objv, int skip); /* 13 */
     int (*tcl_ObjectDeleted) (Tcl_Object object); /* 14 */
     int (*tcl_ObjectContextIsFiltering) (Tcl_ObjectContext context); /* 15 */
@@ -154,6 +156,7 @@ typedef struct TclOOStubs {
     void (*tcl_ClassSetConstructor) (Tcl_Interp *interp, Tcl_Class clazz, Tcl_Method method); /* 26 */
     void (*tcl_ClassSetDestructor) (Tcl_Interp *interp, Tcl_Class clazz, Tcl_Method method); /* 27 */
     Tcl_Obj * (*tcl_GetObjectName) (Tcl_Interp *interp, Tcl_Object object); /* 28 */
+    int (*tcl_MethodIsPrivate) (Tcl_Method method); /* 29 */
 } TclOOStubs;
 
 extern const TclOOStubs *tclOOStubsPtr;
@@ -226,6 +229,8 @@ extern const TclOOStubs *tclOOStubsPtr;
 	(tclOOStubsPtr->tcl_ClassSetDestructor) /* 27 */
 #define Tcl_GetObjectName \
 	(tclOOStubsPtr->tcl_GetObjectName) /* 28 */
+#define Tcl_MethodIsPrivate \
+	(tclOOStubsPtr->tcl_MethodIsPrivate) /* 29 */
 
 #endif /* defined(USE_TCLOO_STUBS) */
 

generic/tclOODefineCmds.c

@@ -16,6 +16,12 @@
 #include "tclInt.h"
 #include "tclOOInt.h"
 
+/*
+ * The actual value used to mark private declaration frames.
+ */
+
+#define PRIVATE_FRAME (FRAME_IS_OO_DEFINE | FRAME_IS_PRIVATE_DEFINE)
+
 /*
  * The maximum length of fully-qualified object name to use in an errorinfo
  * message. Longer than this will be curtailed.
@@ -118,6 +124,35 @@ static const struct DeclaredSlot slots[] = {
     SLOT("objdefine::variable", ObjVarsGet,     ObjVarsSet),
     {NULL, {0, 0, 0, 0, 0}, {0, 0, 0, 0, 0}}
 };
+
+/*
+ * How to build the in-namespace name of a private variable. This is a pattern
+ * used with Tcl_ObjPrintf().
+ */
+
+#define PRIVATE_VARIABLE_PATTERN "%d : %s"
+
+/*
+ * ----------------------------------------------------------------------
+ *
+ * IsPrivateDefine --
+ *
+ *	Extracts whether the current context is handling private definitions.
+ *
+ * ----------------------------------------------------------------------
+ */
+
+static inline int
+IsPrivateDefine(
+    Tcl_Interp *interp)
+{
+    Interp *iPtr = (Interp *) interp;
+
+    if (!iPtr->varFramePtr) {
+	return 0;
+    }
+    return iPtr->varFramePtr->isProcCallFrame == PRIVATE_FRAME;
+}
 
 /*
  * ----------------------------------------------------------------------
@@ -416,6 +451,123 @@ TclOOClassSetMixins(
     BumpGlobalEpoch(interp, classPtr);
 }
 
+/*
+ * ----------------------------------------------------------------------
+ *
+ * InstallStandardVariableMapping, InstallPrivateVariableMapping --
+ *
+ *	Helpers for installing standard and private variable maps.
+ *
+ * ----------------------------------------------------------------------
+ */
+static inline void
+InstallStandardVariableMapping(
+    VariableNameList *vnlPtr,
+    int varc,
+    Tcl_Obj *const *varv)
+{
+    Tcl_Obj *variableObj;
+    int i, n, created;
+    Tcl_HashTable uniqueTable;
+
+    for (i=0 ; i<varc ; i++) {
+	Tcl_IncrRefCount(varv[i]);
+    }
+    FOREACH(variableObj, *vnlPtr) {
+	Tcl_DecrRefCount(variableObj);
+    }
+    if (i != varc) {
+	if (varc == 0) {
+	    ckfree(vnlPtr->list);
+	} else if (i) {
+	    vnlPtr->list = ckrealloc(vnlPtr->list, sizeof(Tcl_Obj *) * varc);
+	} else {
+	    vnlPtr->list = ckalloc(sizeof(Tcl_Obj *) * varc);
+	}
+    }
+    vnlPtr->num = 0;
+    if (varc > 0) {
+	Tcl_InitObjHashTable(&uniqueTable);
+	for (i=n=0 ; i<varc ; i++) {
+	    Tcl_CreateHashEntry(&uniqueTable, varv[i], &created);
+	    if (created) {
+		vnlPtr->list[n++] = varv[i];
+	    } else {
+		Tcl_DecrRefCount(varv[i]);
+	    }
+	}
+	vnlPtr->num = n;
+
+	/*
+	 * Shouldn't be necessary, but maintain num/list invariant.
+	 */
+
+	if (n != varc) {
+	    vnlPtr->list = ckrealloc(vnlPtr->list, sizeof(Tcl_Obj *) * n);
+	}
+	Tcl_DeleteHashTable(&uniqueTable);
+    }
+}
+
+static inline void
+InstallPrivateVariableMapping(
+    PrivateVariableList *pvlPtr,
+    int varc,
+    Tcl_Obj *const *varv,
+    int creationEpoch)
+{
+    PrivateVariableMapping *privatePtr;
+    int i, n, created;
+    Tcl_HashTable uniqueTable;
+
+    for (i=0 ; i<varc ; i++) {
+	Tcl_IncrRefCount(varv[i]);
+    }
+    FOREACH_STRUCT(privatePtr, *pvlPtr) {
+	Tcl_DecrRefCount(privatePtr->variableObj);
+	Tcl_DecrRefCount(privatePtr->fullNameObj);
+    }
+    if (i != varc) {
+	if (varc == 0) {
+	    ckfree(pvlPtr->list);
+	} else if (i) {
+	    pvlPtr->list = ckrealloc(pvlPtr->list,
+		    sizeof(PrivateVariableMapping) * varc);
+	} else {
+	    pvlPtr->list = ckalloc(sizeof(PrivateVariableMapping) * varc);
+	}
+    }
+
+    pvlPtr->num = 0;
+    if (varc > 0) {
+	Tcl_InitObjHashTable(&uniqueTable);
+	for (i=n=0 ; i<varc ; i++) {
+	    Tcl_CreateHashEntry(&uniqueTable, varv[i], &created);
+	    if (created) {
+		privatePtr = &(pvlPtr->list[n++]);
+		privatePtr->variableObj = varv[i];
+		privatePtr->fullNameObj = Tcl_ObjPrintf(
+			PRIVATE_VARIABLE_PATTERN,
+			creationEpoch, Tcl_GetString(varv[i]));
+		Tcl_IncrRefCount(privatePtr->fullNameObj);
+	    } else {
+		Tcl_DecrRefCount(varv[i]);
+	    }
+	}
+	pvlPtr->num = n;
+
+	/*
+	 * Shouldn't be necessary, but maintain num/list invariant.
+	 */
+
+	if (n != varc) {
+	    pvlPtr->list = ckrealloc(pvlPtr->list,
+		    sizeof(PrivateVariableMapping) * n);
+	}
+	Tcl_DeleteHashTable(&uniqueTable);
+    }
+}
+
 /*
  * ----------------------------------------------------------------------
  *
@@ -708,7 +860,8 @@ TclOOGetDefineCmdContext(
     Tcl_Object object;
 
     if ((iPtr->varFramePtr == NULL)
-	    || (iPtr->varFramePtr->isProcCallFrame != FRAME_IS_OO_DEFINE)) {
+	    || (iPtr->varFramePtr->isProcCallFrame != FRAME_IS_OO_DEFINE
+	    && iPtr->varFramePtr->isProcCallFrame != PRIVATE_FRAME)) {
 	Tcl_SetObjResult(interp, Tcl_NewStringObj(
 		"this command may only be called from within the context of"
 		" an ::oo::define or ::oo::objdefine command", -1));
@@ -749,7 +902,8 @@ GetClassInOuterContext(
     Object *oPtr;
     CallFrame *savedFramePtr = iPtr->varFramePtr;
 
-    while (iPtr->varFramePtr->isProcCallFrame == FRAME_IS_OO_DEFINE) {
+    while (iPtr->varFramePtr->isProcCallFrame == FRAME_IS_OO_DEFINE
+	    || iPtr->varFramePtr->isProcCallFrame == PRIVATE_FRAME) {
 	if (iPtr->varFramePtr->callerVarPtr == NULL) {
 	    Tcl_Panic("getting outer context when already in global context");
 	}
@@ -1038,7 +1192,7 @@ TclOODefineSelfObjCmd(
 {
     Foundation *fPtr = TclOOGetFoundation(interp);
     Object *oPtr;
-    int result;
+    int result, private;
 
     oPtr = (Object *) TclOOGetDefineCmdContext(interp);
     if (oPtr == NULL) {
@@ -1050,6 +1204,8 @@ TclOODefineSelfObjCmd(
 	return TCL_OK;
     }
 
+    private = IsPrivateDefine(interp);
+
     /*
      * Make the oo::objdefine namespace the current namespace and evaluate the
      * command(s).
@@ -1058,6 +1214,9 @@ TclOODefineSelfObjCmd(
     if (InitDefineContext(interp, fPtr->objdefNs, oPtr, objc,objv) != TCL_OK){
 	return TCL_ERROR;
     }
+    if (private) {
+	((Interp *) interp)->varFramePtr->isProcCallFrame = PRIVATE_FRAME;
+    }
 
     AddRef(oPtr);
     if (objc == 2) {
@@ -1065,7 +1224,7 @@ TclOODefineSelfObjCmd(
 
 	Tcl_IncrRefCount(objNameObj);
 	result = TclEvalObjEx(interp, objv[1], 0,
-		((Interp *)interp)->cmdFramePtr, 2);
+		((Interp *)interp)->cmdFramePtr, 1);
 	if (result == TCL_ERROR) {
 	    GenerateErrorInfo(interp, oPtr, objNameObj, "class object");
 	}
@@ -1117,6 +1276,79 @@ TclOODefineObjSelfObjCmd(
     return TCL_OK;
 }
 
+/*
+ * ----------------------------------------------------------------------
+ *
+ * TclOODefinePrivateObjCmd --
+ *
+ *	Implementation of the "private" subcommand of the "oo::define"
+ *	and "oo::objdefine" commands.
+ *
+ * ----------------------------------------------------------------------
+ */
+
+int
+TclOODefinePrivateObjCmd(
+    ClientData clientData,
+    Tcl_Interp *interp,
+    int objc,
+    Tcl_Obj *const *objv)
+{
+    int isInstancePrivate = (clientData != NULL);
+				/* Just so that we can generate the correct
+				 * error message depending on the context of
+				 * usage of this function. */
+    Interp *iPtr = (Interp *) interp;
+    Object *oPtr = (Object *) TclOOGetDefineCmdContext(interp);
+    int saved;			/* The saved flag. We restore it on exit so
+				 * that [private private ...] doesn't make
+				 * things go weird. */
+    int result;
+
+    if (oPtr == NULL) {
+	return TCL_ERROR;
+    }
+    if (objc == 1) {
+	Tcl_SetObjResult(interp, Tcl_NewBooleanObj(IsPrivateDefine(interp)));
+	return TCL_OK;
+    }
+
+    /*
+     * Change the frame type flag while evaluating the body.
+     */
+
+    saved = iPtr->varFramePtr->isProcCallFrame;
+    iPtr->varFramePtr->isProcCallFrame = PRIVATE_FRAME;
+
+    /*
+     * Evaluate the body; standard pattern.
+     */
+
+    AddRef(oPtr);
+    if (objc == 2) {
+	Tcl_Obj *objNameObj = TclOOObjectName(interp, oPtr);
+
+	Tcl_IncrRefCount(objNameObj);
+	result = TclEvalObjEx(interp, objv[1], 0, iPtr->cmdFramePtr, 1);
+	if (result == TCL_ERROR) {
+	    GenerateErrorInfo(interp, oPtr, objNameObj,
+		    isInstancePrivate ? "object" : "class");
+	}
+	TclDecrRefCount(objNameObj);
+    } else {
+	result = MagicDefinitionInvoke(interp, TclGetCurrentNamespace(interp),
+		1, objc, objv);
+    }
+    TclOODecrRefCount(oPtr);
+
+    /*
+     * Restore the frame type flag to what it was previously.
+     */
+
+    iPtr->varFramePtr->isProcCallFrame = saved;
+    return result;
+}
+
 /*
  * ----------------------------------------------------------------------
  *
@@ -1460,8 +1692,9 @@ TclOODefineExportObjCmd(
 	} else {
 	    mPtr = Tcl_GetHashValue(hPtr);
 	}
-	if (isNew || !(mPtr->flags & PUBLIC_METHOD)) {
+	if (isNew || !(mPtr->flags & (PUBLIC_METHOD | PRIVATE_METHOD))) {
 	    mPtr->flags |= PUBLIC_METHOD;
+	    mPtr->flags &= ~TRUE_PRIVATE_METHOD;
 	    changed = 1;
 	}
     }
@@ -1521,6 +1754,9 @@ TclOODefineForwardObjCmd(
     }
     isPublic = Tcl_StringMatch(TclGetString(objv[1]), "[a-z]*")
 	    ? PUBLIC_METHOD : 0;
+    if (IsPrivateDefine(interp)) {
+	isPublic = TRUE_PRIVATE_METHOD;
+    }
 
     /*
      * Create the method structure.
@@ -1580,6 +1816,9 @@ TclOODefineMethodObjCmd(
     }
     isPublic = Tcl_StringMatch(TclGetString(objv[1]), "[a-z]*")
 	    ? PUBLIC_METHOD : 0;
+    if (IsPrivateDefine(interp)) {
+	isPublic = TRUE_PRIVATE_METHOD;
+    }
 
     /*
      * Create the method by using the right back-end API.
@@ -1599,70 +1838,6 @@ TclOODefineMethodObjCmd(
     return TCL_OK;
 }
 
-/*
- * ----------------------------------------------------------------------
- *
- * TclOODefineMixinObjCmd --
- *
- *	Implementation of the "mixin" subcommand of the "oo::define" and
- *	"oo::objdefine" commands.
- *
- * ----------------------------------------------------------------------
- */
-
-int
-TclOODefineMixinObjCmd(
-    ClientData clientData,
-    Tcl_Interp *interp,
-    const int objc,
-    Tcl_Obj *const *objv)
-{
-    int isInstanceMixin = (clientData != NULL);
-    Object *oPtr = (Object *) TclOOGetDefineCmdContext(interp);
-    Class **mixins;
-    int i;
-
-    if (oPtr == NULL) {
-	return TCL_ERROR;
-    }
-    if (!isInstanceMixin && !oPtr->classPtr) {
-	Tcl_SetObjResult(interp, Tcl_NewStringObj(
-		"attempt to misuse API", -1));
-	Tcl_SetErrorCode(interp, "TCL", "OO", "MONKEY_BUSINESS", NULL);
-	return TCL_ERROR;
-    }
-    mixins = TclStackAlloc(interp, sizeof(Class *) * (objc-1));
-
-    for (i=1 ; i<objc ; i++) {
-	Class *clsPtr = GetClassInOuterContext(interp, objv[i],
-		"may only mix in classes");
-
-	if (clsPtr == NULL) {
-	    goto freeAndError;
-	}
-	if (!isInstanceMixin && TclOOIsReachable(oPtr->classPtr, clsPtr)) {
-	    Tcl_SetObjResult(interp, Tcl_NewStringObj(
-		    "may not mix a class into itself", -1));
-	    Tcl_SetErrorCode(interp, "TCL", "OO", "SELF_MIXIN", NULL);
-	    goto freeAndError;
-	}
-	mixins[i-1] = clsPtr;
-    }
-
-    if (isInstanceMixin) {
-	TclOOObjectSetMixins(oPtr, objc-1, mixins);
-    } else {
-	TclOOClassSetMixins(interp, oPtr->classPtr, objc-1, mixins);
-    }
-
-    TclStackFree(interp, mixins);
-    return TCL_OK;
-
-  freeAndError:
-    TclStackFree(interp, mixins);
-    return TCL_ERROR;
-}
-
 /*
  * ----------------------------------------------------------------------
  *
@@ -1795,8 +1970,8 @@ TclOODefineUnexportObjCmd(
 	} else {
 	    mPtr = Tcl_GetHashValue(hPtr);
 	}
-	if (isNew || mPtr->flags & PUBLIC_METHOD) {
-	    mPtr->flags &= ~PUBLIC_METHOD;
+	if (isNew || mPtr->flags & (PUBLIC_METHOD | TRUE_PRIVATE_METHOD)) {
+	    mPtr->flags &= ~(PUBLIC_METHOD | TRUE_PRIVATE_METHOD);
 	    changed = 1;
 	}
     }
@@ -2288,7 +2463,7 @@ ClassVarsGet(
     Tcl_Obj *const *objv)
 {
     Object *oPtr = (Object *) TclOOGetDefineCmdContext(interp);
-    Tcl_Obj *resultObj, *variableObj;
+    Tcl_Obj *resultObj;
     int i;
 
     if (Tcl_ObjectContextSkippedArgs(context) != objc) {
@@ -2306,8 +2481,18 @@ ClassVarsGet(
     }
 
     resultObj = Tcl_NewObj();
-    FOREACH(variableObj, oPtr->classPtr->variables) {
-	Tcl_ListObjAppendElement(NULL, resultObj, variableObj);
+    if (IsPrivateDefine(interp)) {
+	PrivateVariableMapping *privatePtr;
+
+	FOREACH_STRUCT(privatePtr, oPtr->classPtr->privateVariables) {
+	    Tcl_ListObjAppendElement(NULL, resultObj, privatePtr->variableObj);
+	}
+    } else {
+	Tcl_Obj *variableObj;
+
+	FOREACH(variableObj, oPtr->classPtr->variables) {
+	    Tcl_ListObjAppendElement(NULL, resultObj, variableObj);
+	}
     }
     Tcl_SetObjResult(interp, resultObj);
     return TCL_OK;
@@ -2323,7 +2508,7 @@ ClassVarsSet(
 {
     Object *oPtr = (Object *) TclOOGetDefineCmdContext(interp);
     int varc;
-    Tcl_Obj **varv, *variableObj;
+    Tcl_Obj **varv;
     int i;
 
     if (Tcl_ObjectContextSkippedArgs(context)+1 != objc) {
@@ -2364,49 +2549,11 @@ ClassVarsSet(
 	}
     }
 
-    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(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);
-	}
-    }
-
-    oPtr->classPtr->variables.num = 0;
-    if (varc > 0) {
-	int created, n;
-	Tcl_HashTable uniqueTable;
-
-	Tcl_InitObjHashTable(&uniqueTable);
-	for (i=n=0 ; i<varc ; i++) {
-	    Tcl_CreateHashEntry(&uniqueTable, varv[i], &created);
-	    if (created) {
-		oPtr->classPtr->variables.list[n++] = varv[i];
-	    } else {
-		Tcl_DecrRefCount(varv[i]);
-	    }
-	}
-	oPtr->classPtr->variables.num = n;
-
-	/*
-	 * Shouldn't be necessary, but maintain num/list invariant.
-	 */
-
-	oPtr->classPtr->variables.list = (Tcl_Obj **)
-		ckrealloc((char *) oPtr->classPtr->variables.list,
-		sizeof(Tcl_Obj *) * n);
-	Tcl_DeleteHashTable(&uniqueTable);
+    if (IsPrivateDefine(interp)) {
+	InstallPrivateVariableMapping(&oPtr->classPtr->privateVariables,
+		varc, varv, oPtr->classPtr->thisPtr->creationEpoch);
+    } else {
+	InstallStandardVariableMapping(&oPtr->classPtr->variables, varc, varv);
     }
     return TCL_OK;
 }
@@ -2585,7 +2732,7 @@ ObjVarsGet(
     Tcl_Obj *const *objv)
 {
     Object *oPtr = (Object *) TclOOGetDefineCmdContext(interp);
-    Tcl_Obj *resultObj, *variableObj;
+    Tcl_Obj *resultObj;
     int i;
 
     if (Tcl_ObjectContextSkippedArgs(context) != objc) {
@@ -2597,8 +2744,18 @@ ObjVarsGet(
     }
 
     resultObj = Tcl_NewObj();
-    FOREACH(variableObj, oPtr->variables) {
-	Tcl_ListObjAppendElement(NULL, resultObj, variableObj);
+    if (IsPrivateDefine(interp)) {
+	PrivateVariableMapping *privatePtr;
+
+	FOREACH_STRUCT(privatePtr, oPtr->privateVariables) {
+	    Tcl_ListObjAppendElement(NULL, resultObj, privatePtr->variableObj);
+	}
+    } else {
+	Tcl_Obj *variableObj;
+
+	FOREACH(variableObj, oPtr->variables) {
+	    Tcl_ListObjAppendElement(NULL, resultObj, variableObj);
+	}
     }
     Tcl_SetObjResult(interp, resultObj);
     return TCL_OK;
@@ -2614,7 +2771,7 @@ ObjVarsSet(
 {
     Object *oPtr = (Object *) TclOOGetDefineCmdContext(interp);
     int varc, i;
-    Tcl_Obj **varv, *variableObj;
+    Tcl_Obj **varv;
 
     if (Tcl_ObjectContextSkippedArgs(context)+1 != objc) {
 	Tcl_WrongNumArgs(interp, Tcl_ObjectContextSkippedArgs(context), objv,
@@ -2647,49 +2804,12 @@ ObjVarsSet(
 	    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(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);
-	}
-    }
-    oPtr->variables.num = 0;
-    if (varc > 0) {
-	int created, n;
-	Tcl_HashTable uniqueTable;
-
-	Tcl_InitObjHashTable(&uniqueTable);
-	for (i=n=0 ; i<varc ; i++) {
-	    Tcl_CreateHashEntry(&uniqueTable, varv[i], &created);
-	    if (created) {
-		oPtr->variables.list[n++] = varv[i];
-	    } else {
-		Tcl_DecrRefCount(varv[i]);
-	    }
-	}
-	oPtr->variables.num = n;
-
-	/*
-	 * Shouldn't be necessary, but maintain num/list invariant.
-	 */
-
-	oPtr->variables.list = (Tcl_Obj **)
-		ckrealloc((char *) oPtr->variables.list,
-		sizeof(Tcl_Obj *) * n);
-	Tcl_DeleteHashTable(&uniqueTable);
+    if (IsPrivateDefine(interp)) {
+	InstallPrivateVariableMapping(&oPtr->privateVariables, varc, varv,
+		oPtr->creationEpoch);
+    } else {
+	InstallStandardVariableMapping(&oPtr->variables, varc, varv);
     }
     return TCL_OK;
 }

generic/tclOOInfo.c

@@ -22,6 +22,7 @@ static Tcl_ObjCmdProc InfoObjectClassCmd;
 static Tcl_ObjCmdProc InfoObjectDefnCmd;
 static Tcl_ObjCmdProc InfoObjectFiltersCmd;
 static Tcl_ObjCmdProc InfoObjectForwardCmd;
+static Tcl_ObjCmdProc InfoObjectIdCmd;
 static Tcl_ObjCmdProc InfoObjectIsACmd;
 static Tcl_ObjCmdProc InfoObjectMethodsCmd;
 static Tcl_ObjCmdProc InfoObjectMethodTypeCmd;
@@ -50,6 +51,7 @@ static Tcl_ObjCmdProc InfoClassVariablesCmd;
 static const EnsembleImplMap infoObjectCmds[] = {
     {"call",	   InfoObjectCallCmd,	    TclCompileBasic2ArgCmd, NULL, NULL, 0},
     {"class",	   InfoObjectClassCmd,	    TclCompileInfoObjectClassCmd, NULL, NULL, 0},
+    {"creationid", InfoObjectIdCmd,	    TclCompileBasic1ArgCmd, NULL, NULL, 0},
     {"definition", InfoObjectDefnCmd,	    TclCompileBasic2ArgCmd, NULL, NULL, 0},
     {"filters",	   InfoObjectFiltersCmd,    TclCompileBasic1ArgCmd, NULL, NULL, 0},
     {"forward",	   InfoObjectForwardCmd,    TclCompileBasic2ArgCmd, NULL, NULL, 0},
@@ -58,7 +60,7 @@ static const EnsembleImplMap infoObjectCmds[] = {
     {"methodtype", InfoObjectMethodTypeCmd, TclCompileBasic2ArgCmd, NULL, NULL, 0},
     {"mixins",	   InfoObjectMixinsCmd,	    TclCompileBasic1ArgCmd, NULL, NULL, 0},
     {"namespace",  InfoObjectNsCmd,	    TclCompileInfoObjectNamespaceCmd, NULL, NULL, 0},
-    {"variables",  InfoObjectVariablesCmd,  TclCompileBasic1ArgCmd, NULL, NULL, 0},
+    {"variables",  InfoObjectVariablesCmd,  TclCompileBasic1Or2ArgCmd, NULL, NULL, 0},
     {"vars",	   InfoObjectVarsCmd,	    TclCompileBasic1Or2ArgCmd, NULL, NULL, 0},
     {NULL, NULL, NULL, NULL, NULL, 0}
 };
@@ -80,7 +82,7 @@ static const EnsembleImplMap infoClassCmds[] = {
     {"mixins",	     InfoClassMixinsCmd,	TclCompileBasic1ArgCmd, NULL, NULL, 0},
     {"subclasses",   InfoClassSubsCmd,		TclCompileBasic1Or2ArgCmd, NULL, NULL, 0},
     {"superclasses", InfoClassSupersCmd,	TclCompileBasic1ArgCmd, NULL, NULL, 0},
-    {"variables",    InfoClassVariablesCmd,	TclCompileBasic1ArgCmd, NULL, NULL, 0},
+    {"variables",    InfoClassVariablesCmd,	TclCompileBasic1Or2ArgCmd, NULL, NULL, 0},
     {NULL, NULL, NULL, NULL, NULL, 0}
 };
 
@@ -517,15 +519,22 @@ InfoObjectMethodsCmd(
     Tcl_Obj *const objv[])
 {
     Object *oPtr;
-    int flag = PUBLIC_METHOD, recurse = 0;
+    int flag = PUBLIC_METHOD, recurse = 0, scope = -1;
     FOREACH_HASH_DECLS;
     Tcl_Obj *namePtr, *resultObj;
     Method *mPtr;
     static const char *const options[] = {
-	"-all", "-localprivate", "-private", NULL
+	"-all", "-localprivate", "-private", "-scope", NULL
     };
     enum Options {
-	OPT_ALL, OPT_LOCALPRIVATE, OPT_PRIVATE
+	OPT_ALL, OPT_LOCALPRIVATE, OPT_PRIVATE, OPT_SCOPE
+    };
+    static const char *const scopes[] = {
+	"private", "public", "unexported"
+    };
+    enum Scopes {
+	SCOPE_PRIVATE, SCOPE_PUBLIC, SCOPE_UNEXPORTED,
+	SCOPE_LOCALPRIVATE
     };
 
     if (objc < 2) {
@@ -554,14 +563,45 @@ InfoObjectMethodsCmd(
 	    case OPT_PRIVATE:
 		flag = 0;
 		break;
+	    case OPT_SCOPE:
+		if (++i >= objc) {
+		    Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+			    "missing option for -scope"));
+		    Tcl_SetErrorCode(interp, "TCL", "ARGUMENT", "MISSING",
+			    NULL);
+		    return TCL_ERROR;
+		}
+		if (Tcl_GetIndexFromObj(interp, objv[i], scopes, "scope", 0,
+			&scope) != TCL_OK) {
+		    return TCL_ERROR;
+		}
+		break;
 	    }
 	}
     }
+    if (scope != -1) {
+	recurse = 0;
+	switch (scope) {
+	case SCOPE_PRIVATE:
+	    flag = TRUE_PRIVATE_METHOD;
+	    break;
+	case SCOPE_PUBLIC:
+	    flag = PUBLIC_METHOD;
+	    break;
+	case SCOPE_LOCALPRIVATE:
+	    flag = PRIVATE_METHOD;
+	    break;
+	case SCOPE_UNEXPORTED:
+	    flag = 0;
+	    break;
+	}
+    }
 
     resultObj = Tcl_NewObj();
     if (recurse) {
 	const char **names;
-	int i, numNames = TclOOGetSortedMethodList(oPtr, flag, &names);
+	int i, numNames = TclOOGetSortedMethodList(oPtr, NULL, NULL, flag,
+		&names);
 
 	for (i=0 ; i<numNames ; i++) {
 	    Tcl_ListObjAppendElement(NULL, resultObj,
@@ -572,7 +612,7 @@ InfoObjectMethodsCmd(
 	}
     } else if (oPtr->methodsPtr) {
 	FOREACH_HASH(namePtr, mPtr, oPtr->methodsPtr) {
-	    if (mPtr->typePtr != NULL && (mPtr->flags & flag) == flag) {
+	    if (mPtr->typePtr && (mPtr->flags & SCOPE_FLAGS) == flag) {
 		Tcl_ListObjAppendElement(NULL, resultObj, namePtr);
 	    }
 	}
@@ -681,6 +721,38 @@ InfoObjectMixinsCmd(
     return TCL_OK;
 }
 
+/*
+ * ----------------------------------------------------------------------
+ *
+ * InfoObjectIdCmd --
+ *
+ *	Implements [info object creationid $objName]
+ *
+ * ----------------------------------------------------------------------
+ */
+
+static int
+InfoObjectIdCmd(
+    ClientData clientData,
+    Tcl_Interp *interp,
+    int objc,
+    Tcl_Obj *const objv[])
+{
+    Object *oPtr;
+
+    if (objc != 2) {
+	Tcl_WrongNumArgs(interp, 1, objv, "objName");
+	return TCL_ERROR;
+    }
+    oPtr = (Object *) Tcl_GetObjectFromObj(interp, objv[1]);
+    if (oPtr == NULL) {
+	return TCL_ERROR;
+    }
+
+    Tcl_SetObjResult(interp, Tcl_NewIntObj(oPtr->creationEpoch));
+    return TCL_OK;
+}
+
 /*
  * ----------------------------------------------------------------------
  *
@@ -719,7 +791,7 @@ InfoObjectNsCmd(
  *
  * InfoObjectVariablesCmd --
  *
- *	Implements [info object variables $objName]
+ *	Implements [info object variables $objName ?-private?]
  *
  * ----------------------------------------------------------------------
  */
@@ -732,21 +804,37 @@ InfoObjectVariablesCmd(
     Tcl_Obj *const objv[])
 {
     Object *oPtr;
-    Tcl_Obj *variableObj, *resultObj;
-    int i;
+    Tcl_Obj *resultObj;
+    int i, private = 0;
 
-    if (objc != 2) {
-	Tcl_WrongNumArgs(interp, 1, objv, "objName");
+    if (objc != 2 && objc != 3) {
+	Tcl_WrongNumArgs(interp, 1, objv, "objName ?-private?");
 	return TCL_ERROR;
     }
+    if (objc == 3) {
+	if (strcmp("-private", Tcl_GetString(objv[2])) != 0) {
+	    return TCL_ERROR;
+	}
+	private = 1;
+    }
     oPtr = (Object *) Tcl_GetObjectFromObj(interp, objv[1]);
     if (oPtr == NULL) {
 	return TCL_ERROR;
     }
 
     resultObj = Tcl_NewObj();
-    FOREACH(variableObj, oPtr->variables) {
-	Tcl_ListObjAppendElement(NULL, resultObj, variableObj);
+    if (private) {
+	PrivateVariableMapping *privatePtr;
+
+	FOREACH_STRUCT(privatePtr, oPtr->privateVariables) {
+	    Tcl_ListObjAppendElement(NULL, resultObj, privatePtr->variableObj);
+	}
+    } else {
+	Tcl_Obj *variableObj;
+
+	FOREACH(variableObj, oPtr->variables) {
+	    Tcl_ListObjAppendElement(NULL, resultObj, variableObj);
+	}
     }
     Tcl_SetObjResult(interp, resultObj);
     return TCL_OK;
@@ -1128,7 +1216,7 @@ InfoClassInstancesCmd(
  *
  * InfoClassMethodsCmd --
  *
- *	Implements [info class methods $clsName ?-private?]
+ *	Implements [info class methods $clsName ?options...?]
  *
  * ----------------------------------------------------------------------
  */
@@ -1140,15 +1228,21 @@ InfoClassMethodsCmd(
     int objc,
     Tcl_Obj *const objv[])
 {
-    int flag = PUBLIC_METHOD, recurse = 0;
+    int flag = PUBLIC_METHOD, recurse = 0, scope = -1;
     Tcl_Obj *namePtr, *resultObj;
     Method *mPtr;
     Class *clsPtr;
     static const char *const options[] = {
-	"-all", "-localprivate", "-private", NULL
+	"-all", "-localprivate", "-private", "-scope", NULL
     };
     enum Options {
-	OPT_ALL, OPT_LOCALPRIVATE, OPT_PRIVATE
+	OPT_ALL, OPT_LOCALPRIVATE, OPT_PRIVATE, OPT_SCOPE
+    };
+    static const char *const scopes[] = {
+	"private", "public", "unexported"
+    };
+    enum Scopes {
+	SCOPE_PRIVATE, SCOPE_PUBLIC, SCOPE_UNEXPORTED
     };
 
     if (objc < 2) {
@@ -1177,9 +1271,36 @@ InfoClassMethodsCmd(
 	    case OPT_PRIVATE:
 		flag = 0;
 		break;
+	    case OPT_SCOPE:
+		if (++i >= objc) {
+		    Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+			    "missing option for -scope"));
+		    Tcl_SetErrorCode(interp, "TCL", "ARGUMENT", "MISSING",
+			    NULL);
+		    return TCL_ERROR;
+		}
+		if (Tcl_GetIndexFromObj(interp, objv[i], scopes, "scope", 0,
+			&scope) != TCL_OK) {
+		    return TCL_ERROR;
+		}
+		break;
 	    }
 	}
     }
+    if (scope != -1) {
+	recurse = 0;
+	switch (scope) {
+	case SCOPE_PRIVATE:
+	    flag = TRUE_PRIVATE_METHOD;
+	    break;
+	case SCOPE_PUBLIC:
+	    flag = PUBLIC_METHOD;
+	    break;
+	case SCOPE_UNEXPORTED:
+	    flag = 0;
+	    break;
+	}
+    }
 
     resultObj = Tcl_NewObj();
     if (recurse) {
@@ -1197,7 +1318,7 @@ InfoClassMethodsCmd(
 	FOREACH_HASH_DECLS;
 
 	FOREACH_HASH(namePtr, mPtr, &clsPtr->classMethods) {
-	    if (mPtr->typePtr != NULL && (mPtr->flags & flag) == flag) {
+	    if (mPtr->typePtr && (mPtr->flags & SCOPE_FLAGS) == flag) {
 		Tcl_ListObjAppendElement(NULL, resultObj, namePtr);
 	    }
 	}
@@ -1399,7 +1520,7 @@ InfoClassSupersCmd(
  *
  * InfoClassVariablesCmd --
  *
- *	Implements [info class variables $clsName]
+ *	Implements [info class variables $clsName ?-private?]
  *
  * ----------------------------------------------------------------------
  */
@@ -1412,21 +1533,37 @@ InfoClassVariablesCmd(
     Tcl_Obj *const objv[])
 {
     Class *clsPtr;
-    Tcl_Obj *variableObj, *resultObj;
-    int i;
+    Tcl_Obj *resultObj;
+    int i, private = 0;
 
-    if (objc != 2) {
-	Tcl_WrongNumArgs(interp, 1, objv, "className");
+    if (objc != 2 && objc != 3) {
+	Tcl_WrongNumArgs(interp, 1, objv, "className ?-private?");
 	return TCL_ERROR;
     }
+    if (objc == 3) {
+	if (strcmp("-private", Tcl_GetString(objv[2])) != 0) {
+	    return TCL_ERROR;
+	}
+	private = 1;
+    }
     clsPtr = GetClassFromObj(interp, objv[1]);
     if (clsPtr == NULL) {
 	return TCL_ERROR;
     }
 
     resultObj = Tcl_NewObj();
-    FOREACH(variableObj, clsPtr->variables) {
-	Tcl_ListObjAppendElement(NULL, resultObj, variableObj);
+    if (private) {
+	PrivateVariableMapping *privatePtr;
+
+	FOREACH_STRUCT(privatePtr, clsPtr->privateVariables) {
+	    Tcl_ListObjAppendElement(NULL, resultObj, privatePtr->variableObj);
+	}
+    } else {
+	Tcl_Obj *variableObj;
+
+	FOREACH(variableObj, clsPtr->variables) {
+	    Tcl_ListObjAppendElement(NULL, resultObj, variableObj);
+	}
     }
     Tcl_SetObjResult(interp, resultObj);
     return TCL_OK;
@@ -1465,7 +1602,8 @@ InfoObjectCallCmd(
      * Get the call context and render its call chain.
      */
 
-    contextPtr = TclOOGetCallContext(oPtr, objv[2], PUBLIC_METHOD, NULL);
+    contextPtr = TclOOGetCallContext(oPtr, objv[2], PUBLIC_METHOD, NULL, NULL,
+	    NULL);
     if (contextPtr == NULL) {
 	Tcl_SetObjResult(interp, Tcl_NewStringObj(
 		"cannot construct any call chain", -1));

generic/tclOOInt.h

@@ -124,6 +124,18 @@ typedef struct ForwardMethod {
 				 * non-empty list. */
 } ForwardMethod;
 
+/*
+ * Structure used in private variable mappings. Describes the mapping of a
+ * single variable from the user's local name to the system's storage name.
+ * [TIP #500]
+ */
+
+typedef struct {
+    Tcl_Obj *variableObj;	/* Name used within methods. This is the part
+				 * that is properly under user control. */
+    Tcl_Obj *fullNameObj;	/* Name used at the instance namespace level. */
+} PrivateVariableMapping;
+
 /*
  * Helper definitions that declare a "list" array. The two varieties are
  * either optimized for simplicity (in the case that the whole array is
@@ -141,6 +153,13 @@ typedef struct ForwardMethod {
 #define LIST_DYNAMIC(listType_t) \
     struct { int num, size; listType_t *list; }
 
+/*
+ * These types are needed in function arguments.
+ */
+
+typedef LIST_STATIC(Tcl_Obj *) VariableNameList;
+typedef LIST_STATIC(PrivateVariableMapping) PrivateVariableList;
+
 /*
  * Now, the definition of what an object actually is.
  */
@@ -186,7 +205,12 @@ typedef struct Object {
     Tcl_ObjectMapMethodNameProc *mapMethodNameProc;
 				/* Function to allow remapping of method
 				 * names. For itcl-ng. */
-    LIST_STATIC(Tcl_Obj *) variables;
+    VariableNameList variables;
+    PrivateVariableList privateVariables;
+				/* Configurations for the variable resolver
+				 * used inside methods. */
+    Tcl_Command myclassCommand;	/* Reference to this object's class dispatcher
+				 * command. */
 } Object;
 
 #define OBJECT_DELETED	1	/* Flag to say that an object has been
@@ -214,6 +238,10 @@ typedef struct Object {
 				 * other spots). */
 #define FORCE_UNKNOWN 0x10000	/* States that we are *really* looking up the
 				 * unknown method handler at that point. */
+#define HAS_PRIVATE_METHODS 0x20000
+				/* Object/class has (or had) private methods,
+				 * and so shouldn't be cached so
+				 * aggressively. */
 
 /*
  * And the definition of a class. Note that every class also has an associated
@@ -268,7 +296,10 @@ typedef struct Class {
 				 * object doesn't override with its own mixins
 				 * (and filters and method implementations for
 				 * when getting method chains). */
-    LIST_STATIC(Tcl_Obj *) variables;
+    VariableNameList variables;
+    PrivateVariableList privateVariables;
+				/* Configurations for the variable resolver
+				 * used inside methods. */
 } Class;
 
 /*
@@ -370,10 +401,15 @@ typedef struct CallContext {
 
 #define PUBLIC_METHOD     0x01	/* This is a public (exported) method. */
 #define PRIVATE_METHOD    0x02	/* This is a private (class's direct instances
-				 * only) method. */
+				 * only) method. Supports itcl. */
 #define OO_UNKNOWN_METHOD 0x04	/* This is an unknown method. */
 #define CONSTRUCTOR	  0x08	/* This is a constructor. */
 #define DESTRUCTOR	  0x10	/* This is a destructor. */
+#define TRUE_PRIVATE_METHOD 0x20
+				/* This is a private method only accessible
+				 * from other methods defined on this class
+				 * or instance. [TIP #500] */
+#define SCOPE_FLAGS (PUBLIC_METHOD | PRIVATE_METHOD | TRUE_PRIVATE_METHOD)
 
 /*
  * Structure containing definition information about basic class methods.
@@ -431,6 +467,9 @@ MODULE_SCOPE int	TclOODefineSelfObjCmd(ClientData clientData,
 MODULE_SCOPE int	TclOODefineObjSelfObjCmd(ClientData clientData,
 			    Tcl_Interp *interp, int objc,
 			    Tcl_Obj *const *objv);
+MODULE_SCOPE int	TclOODefinePrivateObjCmd(ClientData clientData,
+			    Tcl_Interp *interp, int objc,
+			    Tcl_Obj *const *objv);
 MODULE_SCOPE int	TclOOUnknownDefinition(ClientData clientData,
 			    Tcl_Interp *interp, int objc,
 			    Tcl_Obj *const *objv);
@@ -504,6 +543,7 @@ MODULE_SCOPE void	TclOODeleteContext(CallContext *contextPtr);
 MODULE_SCOPE void	TclOODelMethodRef(Method *method);
 MODULE_SCOPE CallContext *TclOOGetCallContext(Object *oPtr,
 			    Tcl_Obj *methodNameObj, int flags,
+			    Object *contextObjPtr, Class *contextClsPtr,
 			    Tcl_Obj *cacheInThisObj);
 MODULE_SCOPE CallChain *TclOOGetStereotypeCallChain(Class *clsPtr,
 			    Tcl_Obj *methodNameObj, int flags);
@@ -513,7 +553,8 @@ MODULE_SCOPE Proc *	TclOOGetProcFromMethod(Method *mPtr);
 MODULE_SCOPE Tcl_Obj *	TclOOGetMethodBody(Method *mPtr);
 MODULE_SCOPE int	TclOOGetSortedClassMethodList(Class *clsPtr,
 			    int flags, const char ***stringsPtr);
-MODULE_SCOPE int	TclOOGetSortedMethodList(Object *oPtr, int flags,
+MODULE_SCOPE int	TclOOGetSortedMethodList(Object *oPtr,
+			    Object *contextObj, Class *contextCls, int flags,
 			    const char ***stringsPtr);
 MODULE_SCOPE int	TclOOInit(Tcl_Interp *interp);
 MODULE_SCOPE void	TclOOInitInfo(Tcl_Interp *interp);
@@ -558,13 +599,24 @@ MODULE_SCOPE void	TclOOSetupVariableResolver(Tcl_Namespace *nsPtr);
 #define FOREACH(var,ary) \
     for(i=0 ; i<(ary).num; i++) if ((ary).list[i] == NULL) { \
 	continue; \
-    } else if (var = (ary).list[i], 1) 
+    } else if (var = (ary).list[i], 1)
+
+/*
+ * A variation where the array is an array of structs. There's no issue with
+ * possible NULLs; every element of the array will be iterated over and the
+ * varable set to a pointer to each of those elements in turn.
+ * REQUIRES DECLARATION: int i;
+ */
+
+#define FOREACH_STRUCT(var,ary) \
+    for(i=0 ; var=&((ary).list[i]), i<(ary).num; i++)
 
 /*
  * Convenience macros for iterating through hash tables. FOREACH_HASH_DECLS
  * sets up the declarations needed for the main macro, FOREACH_HASH, which
  * does the actual iteration. FOREACH_HASH_VALUE is a restricted version that
  * only iterates over values.
+ * REQUIRES DECLARATION: FOREACH_HASH_DECLS;
  */
 
 #define FOREACH_HASH_DECLS \

generic/tclOOMethod.c

@@ -186,7 +186,11 @@ Tcl_NewInstanceMethod(
     mPtr->declaringObjectPtr = oPtr;
     mPtr->declaringClassPtr = NULL;
     if (flags) {
-	mPtr->flags |= flags & (PUBLIC_METHOD | PRIVATE_METHOD);
+	mPtr->flags |= flags &
+		(PUBLIC_METHOD | PRIVATE_METHOD | TRUE_PRIVATE_METHOD);
+	if (flags & TRUE_PRIVATE_METHOD) {
+	    oPtr->flags |= HAS_PRIVATE_METHODS;
+	}
     }
     oPtr->epoch++;
     return (Tcl_Method) mPtr;
@@ -250,7 +254,11 @@ Tcl_NewMethod(
     mPtr->declaringObjectPtr = NULL;
     mPtr->declaringClassPtr = clsPtr;
     if (flags) {
-	mPtr->flags |= flags & (PUBLIC_METHOD | PRIVATE_METHOD);
+	mPtr->flags |= flags &
+		(PUBLIC_METHOD | PRIVATE_METHOD | TRUE_PRIVATE_METHOD);
+	if (flags & TRUE_PRIVATE_METHOD) {
+	    clsPtr->flags |= HAS_PRIVATE_METHODS;
+	}
     }
 
     return (Tcl_Method) mPtr;
@@ -928,7 +936,7 @@ PushMethodCallFrame(
  *	variables used in methods. The compiled variable resolver is more
  *	important, but both are needed as it is possible to have a variable
  *	that is only referred to in ways that aren't compilable and we can't
- *	force LVT presence. [TIP #320]
+ *	force LVT presence. [TIP #320, #500]
  *
  * ----------------------------------------------------------------------
  */
@@ -986,6 +994,7 @@ ProcedureMethodCompiledVarConnect(
     CallFrame *framePtr = iPtr->varFramePtr;
     CallContext *contextPtr;
     Tcl_Obj *variableObj;
+    PrivateVariableMapping *privateVar;
     Tcl_HashEntry *hPtr;
     int i, isNew, cacheIt, varLen, len;
     const char *match, *varName;
@@ -1019,6 +1028,15 @@ ProcedureMethodCompiledVarConnect(
     varName = TclGetStringFromObj(infoPtr->variableObj, &varLen);
     if (contextPtr->callPtr->chain[contextPtr->index]
 	    .mPtr->declaringClassPtr != NULL) {
+	FOREACH_STRUCT(privateVar, contextPtr->callPtr->chain[contextPtr->index]
+		.mPtr->declaringClassPtr->privateVariables) {
+	    match = TclGetStringFromObj(privateVar->variableObj, &len);
+	    if ((len == varLen) && !memcmp(match, varName, len)) {
+		variableObj = privateVar->fullNameObj;
+		cacheIt = 0;
+		goto gotMatch;
+	    }
+	}
 	FOREACH(variableObj, contextPtr->callPtr->chain[contextPtr->index]
 		.mPtr->declaringClassPtr->variables) {
 	    match = TclGetStringFromObj(variableObj, &len);
@@ -1028,6 +1046,14 @@ ProcedureMethodCompiledVarConnect(
 	    }
 	}
     } else {
+	FOREACH_STRUCT(privateVar, contextPtr->oPtr->privateVariables) {
+	    match = TclGetStringFromObj(privateVar->variableObj, &len);
+	    if ((len == varLen) && !memcmp(match, varName, len)) {
+		variableObj = privateVar->fullNameObj;
+		cacheIt = 1;
+		goto gotMatch;
+	    }
+	}
 	FOREACH(variableObj, contextPtr->oPtr->variables) {
 	    match = TclGetStringFromObj(variableObj, &len);
 	    if ((len == varLen) && !memcmp(match, varName, len)) {
@@ -1673,6 +1699,13 @@ Tcl_MethodIsPublic(
 {
     return (((Method *)method)->flags & PUBLIC_METHOD) ? 1 : 0;
 }
+
+int
+Tcl_MethodIsPrivate(
+    Tcl_Method method)
+{
+    return (((Method *)method)->flags & TRUE_PRIVATE_METHOD) ? 1 : 0;
+}
 
 /*
  * Extended method construction for itcl-ng.

generic/tclOOScript.h

@@ -0,0 +1,240 @@
+/*
+ * tclOOScript.h --
+ *
+ *	This file contains support scripts for TclOO. They are defined here so
+ *	that the code can be definitely run even in safe interpreters; TclOO's
+ *	core setup is safe.
+ *
+ * Copyright (c) 2012-2018 Donal K. Fellows
+ * Copyright (c) 2013 Andreas Kupries
+ * Copyright (c) 2017 Gerald Lester
+ *
+ * See the file "license.terms" for information on usage and redistribution of
+ * this file, and for a DISCLAIMER OF ALL WARRANTIES.
+ */
+
+#ifndef TCL_OO_SCRIPT_H
+#define TCL_OO_SCRIPT_H
+
+/*
+ * The scripted part of the definitions of TclOO.
+ *
+ * Compiled from generic/tclOOScript.tcl by tools/makeHeader.tcl, which
+ * contains the commented version of everything; *this* file is automatically
+ * generated.
+ */
+
+static const char *tclOOSetupScript =
+/* !BEGIN!: Do not edit below this line. */
+"::namespace eval ::oo {\n"
+"\t::namespace path {}\n"
+"\tnamespace eval Helpers {\n"
+"\t\t::namespace path {}\n"
+"\t\tproc callback {method args} {\n"
+"\t\t\tlist [uplevel 1 {::namespace which my}] $method {*}$args\n"
+"\t\t}\n"
+"\t\tnamespace export callback\n"
+"\t\tnamespace eval tmp {namespace import ::oo::Helpers::callback}\n"
+"\t\tnamespace export -clear\n"
+"\t\trename tmp::callback mymethod\n"
+"\t\tnamespace delete tmp\n"
+"\t\tproc classvariable {name args} {\n"
+"\t\t\tset ns [info object namespace [uplevel 1 {self class}]]\n"
+"\t\t\tforeach v [list $name {*}$args] {\n"
+"\t\t\t\tif {[string match *(*) $v]} {\n"
+"\t\t\t\t\tset reason \"can\'t create a scalar variable that looks like an array element\"\n"
+"\t\t\t\t\treturn -code error -errorcode {TCL UPVAR LOCAL_ELEMENT} \\\n"
+"\t\t\t\t\t\t[format {bad variable name \"%s\": %s} $v $reason]\n"
+"\t\t\t\t}\n"
+"\t\t\t\tif {[string match *::* $v]} {\n"
+"\t\t\t\t\tset reason \"can\'t create a local variable with a namespace separator in it\"\n"
+"\t\t\t\t\treturn -code error -errorcode {TCL UPVAR INVERTED} \\\n"
+"\t\t\t\t\t\t[format {bad variable name \"%s\": %s} $v $reason]\n"
+"\t\t\t\t}\n"
+"\t\t\t\tlappend vs $v $v\n"
+"\t\t\t}\n"
+"\t\t\ttailcall namespace upvar $ns {*}$vs\n"
+"\t\t}\n"
+"\t\tproc link {args} {\n"
+"\t\t\tset ns [uplevel 1 {::namespace current}]\n"
+"\t\t\tforeach link $args {\n"
+"\t\t\t\tif {[llength $link] == 2} {\n"
+"\t\t\t\t\tlassign $link src dst\n"
+"\t\t\t\t} elseif {[llength $link] == 1} {\n"
+"\t\t\t\t\tlassign $link src\n"
+"\t\t\t\t\tset dst $src\n"
+"\t\t\t\t} else {\n"
+"\t\t\t\t\treturn -code error -errorcode {TCLOO CMDLINK FORMAT} \\\n"
+"\t\t\t\t\t\t\"bad link description; must only have one or two elements\"\n"
+"\t\t\t\t}\n"
+"\t\t\t\tif {![string match ::* $src]} {\n"
+"\t\t\t\t\tset src [string cat $ns :: $src]\n"
+"\t\t\t\t}\n"
+"\t\t\t\tinterp alias {} $src {} ${ns}::my $dst\n"
+"\t\t\t\ttrace add command ${ns}::my delete [list \\\n"
+"\t\t\t\t\t::oo::UnlinkLinkedCommand $src]\n"
+"\t\t\t}\n"
+"\t\t\treturn\n"
+"\t\t}\n"
+"\t}\n"
+"\tproc UnlinkLinkedCommand {cmd args} {\n"
+"\t\tif {[namespace which $cmd] ne {}} {\n"
+"\t\t\trename $cmd {}\n"
+"\t\t}\n"
+"\t}\n"
+"\tproc DelegateName {class} {\n"
+"\t\tstring cat [info object namespace $class] {:: oo ::delegate}\n"
+"\t}\n"
+"\tproc MixinClassDelegates {class} {\n"
+"\t\tif {![info object isa class $class]} {\n"
+"\t\t\treturn\n"
+"\t\t}\n"
+"\t\tset delegate [DelegateName $class]\n"
+"\t\tif {![info object isa class $delegate]} {\n"
+"\t\t\treturn\n"
+"\t\t}\n"
+"\t\tforeach c [info class superclass $class] {\n"
+"\t\t\tset d [DelegateName $c]\n"
+"\t\t\tif {![info object isa class $d]} {\n"
+"\t\t\t\tcontinue\n"
+"\t\t\t}\n"
+"\t\t\tdefine $delegate superclass -append $d\n"
+"\t\t}\n"
+"\t\tobjdefine $class mixin -append $delegate\n"
+"\t}\n"
+"\tproc UpdateClassDelegatesAfterClone {originObject targetObject} {\n"
+"\t\tset originDelegate [DelegateName $originObject]\n"
+"\t\tset targetDelegate [DelegateName $targetObject]\n"
+"\t\tif {\n"
+"\t\t\t[info object isa class $originDelegate]\n"
+"\t\t\t&& ![info object isa class $targetDelegate]\n"
+"\t\t} then {\n"
+"\t\t\tcopy $originDelegate $targetDelegate\n"
+"\t\t\tobjdefine $targetObject mixin -set \\\n"
+"\t\t\t\t{*}[lmap c [info object mixin $targetObject] {\n"
+"\t\t\t\t\tif {$c eq $originDelegate} {set targetDelegate} {set c}\n"
+"\t\t\t\t}]\n"
+"\t\t}\n"
+"\t}\n"
+"\tproc define::classmethod {name {args {}} {body {}}} {\n"
+"\t\t::set argc [::llength [::info level 0]]\n"
+"\t\t::if {$argc == 3} {\n"
+"\t\t\t::return -code error -errorcode {TCL WRONGARGS} [::format \\\n"
+"\t\t\t\t{wrong # args: should be \"%s name \?args body\?\"} \\\n"
+"\t\t\t\t[::lindex [::info level 0] 0]]\n"
+"\t\t}\n"
+"\t\t::set cls [::uplevel 1 self]\n"
+"\t\t::if {$argc == 4} {\n"
+"\t\t\t::oo::define [::oo::DelegateName $cls] method $name $args $body\n"
+"\t\t}\n"
+"\t\t::tailcall forward $name myclass $name\n"
+"\t}\n"
+"\tproc define::initialise {body} {\n"
+"\t\t::set clsns [::info object namespace [::uplevel 1 self]]\n"
+"\t\t::tailcall apply [::list {} $body $clsns]\n"
+"\t}\n"
+"\tnamespace eval define {\n"
+"\t\t::namespace export initialise\n"
+"\t\t::namespace eval tmp {::namespace import ::oo::define::initialise}\n"
+"\t\t::namespace export -clear\n"
+"\t\t::rename tmp::initialise initialize\n"
+"\t\t::namespace delete tmp\n"
+"\t}\n"
+"\tdefine Slot {\n"
+"\t\tmethod Get {} {\n"
+"\t\t\treturn -code error -errorcode {TCLOO ABSTRACT_SLOT} \"unimplemented\"\n"
+"\t\t}\n"
+"\t\tmethod Set list {\n"
+"\t\t\treturn -code error -errorcode {TCLOO ABSTRACT_SLOT} \"unimplemented\"\n"
+"\t\t}\n"
+"\t\tmethod -set args {tailcall my Set $args}\n"
+"\t\tmethod -append args {\n"
+"\t\t\tset current [uplevel 1 [list [namespace which my] Get]]\n"
+"\t\t\ttailcall my Set [list {*}$current {*}$args]\n"
+"\t\t}\n"
+"\t\tmethod -clear {} {tailcall my Set {}}\n"
+"\t\tforward --default-operation my -append\n"
+"\t\tmethod unknown {args} {\n"
+"\t\t\tset def --default-operation\n"
+"\t\t\tif {[llength $args] == 0} {\n"
+"\t\t\t\ttailcall my $def\n"
+"\t\t\t} elseif {![string match -* [lindex $args 0]]} {\n"
+"\t\t\t\ttailcall my $def {*}$args\n"
+"\t\t\t}\n"
+"\t\t\tnext {*}$args\n"
+"\t\t}\n"
+"\t\texport -set -append -clear\n"
+"\t\tunexport unknown destroy\n"
+"\t}\n"
+"\tobjdefine define::superclass forward --default-operation my -set\n"
+"\tobjdefine define::mixin forward --default-operation my -set\n"
+"\tobjdefine objdefine::mixin forward --default-operation my -set\n"
+"\tdefine object method <cloned> {originObject} {\n"
+"\t\tforeach p [info procs [info object namespace $originObject]::*] {\n"
+"\t\t\tset args [info args $p]\n"
+"\t\t\tset idx -1\n"
+"\t\t\tforeach a $args {\n"
+"\t\t\t\tif {[info default $p $a d]} {\n"
+"\t\t\t\t\tlset args [incr idx] [list $a $d]\n"
+"\t\t\t\t} else {\n"
+"\t\t\t\t\tlset args [incr idx] [list $a]\n"
+"\t\t\t\t}\n"
+"\t\t\t}\n"
+"\t\t\tset b [info body $p]\n"
+"\t\t\tset p [namespace tail $p]\n"
+"\t\t\tproc $p $args $b\n"
+"\t\t}\n"
+"\t\tforeach v [info vars [info object namespace $originObject]::*] {\n"
+"\t\t\tupvar 0 $v vOrigin\n"
+"\t\t\tnamespace upvar [namespace current] [namespace tail $v] vNew\n"
+"\t\t\tif {[info exists vOrigin]} {\n"
+"\t\t\t\tif {[array exists vOrigin]} {\n"
+"\t\t\t\t\tarray set vNew [array get vOrigin]\n"
+"\t\t\t\t} else {\n"
+"\t\t\t\t\tset vNew $vOrigin\n"
+"\t\t\t\t}\n"
+"\t\t\t}\n"
+"\t\t}\n"
+"\t}\n"
+"\tdefine class method <cloned> {originObject} {\n"
+"\t\tnext $originObject\n"
+"\t\t::oo::UpdateClassDelegatesAfterClone $originObject [self]\n"
+"\t}\n"
+"\tclass create singleton {\n"
+"\t\tsuperclass class\n"
+"\t\tvariable object\n"
+"\t\tunexport create createWithNamespace\n"
+"\t\tmethod new args {\n"
+"\t\t\tif {![info exists object] || ![info object isa object $object]} {\n"
+"\t\t\t\tset object [next {*}$args]\n"
+"\t\t\t\t::oo::objdefine $object {\n"
+"\t\t\t\t\tmethod destroy {} {\n"
+"\t\t\t\t\t\t::return -code error -errorcode {TCLOO SINGLETON} \\\n"
+"\t\t\t\t\t\t\t\"may not destroy a singleton object\"\n"
+"\t\t\t\t\t}\n"
+"\t\t\t\t\tmethod <cloned> {originObject} {\n"
+"\t\t\t\t\t\t::return -code error -errorcode {TCLOO SINGLETON} \\\n"
+"\t\t\t\t\t\t\t\"may not clone a singleton object\"\n"
+"\t\t\t\t\t}\n"
+"\t\t\t\t}\n"
+"\t\t\t}\n"
+"\t\t\treturn $object\n"
+"\t\t}\n"
+"\t}\n"
+"\tclass create abstract {\n"
+"\t\tsuperclass class\n"
+"\t\tunexport create createWithNamespace new\n"
+"\t}\n"
+"}\n"
+/* !END!: Do not edit above this line. */
+;
+
+#endif /* TCL_OO_SCRIPT_H */
+
+/*
+ * Local Variables:
+ * mode: c
+ * c-basic-offset: 4
+ * fill-column: 78
+ * End:
+ */

generic/tclOOScript.tcl

@@ -0,0 +1,422 @@
+# tclOOScript.h --
+#
+# 	This file contains support scripts for TclOO. They are defined here so
+# 	that the code can be definitely run even in safe interpreters; TclOO's
+# 	core setup is safe.
+#
+# Copyright (c) 2012-2018 Donal K. Fellows
+# Copyright (c) 2013 Andreas Kupries
+# Copyright (c) 2017 Gerald Lester
+#
+# See the file "license.terms" for information on usage and redistribution of
+# this file, and for a DISCLAIMER OF ALL WARRANTIES.
+
+::namespace eval ::oo {
+    ::namespace path {}
+
+    #
+    # Commands that are made available to objects by default.
+    #
+    namespace eval Helpers {
+	::namespace path {}
+
+	# ------------------------------------------------------------------
+	#
+	# callback, mymethod --
+	#
+	#	Create a script prefix that calls a method on the current
+	#	object. Same operation, two names.
+	#
+	# ------------------------------------------------------------------
+
+	proc callback {method args} {
+	    list [uplevel 1 {::namespace which my}] $method {*}$args
+	}
+
+	# Make the [callback] command appear as [mymethod] too.
+	namespace export callback
+	namespace eval tmp {namespace import ::oo::Helpers::callback}
+	namespace export -clear
+	rename tmp::callback mymethod
+	namespace delete tmp
+
+	# ------------------------------------------------------------------
+	#
+	# classvariable --
+	#
+	#	Link to a variable in the class of the current object.
+	#
+	# ------------------------------------------------------------------
+
+	proc classvariable {name args} {
+	    # Get a reference to the class's namespace
+	    set ns [info object namespace [uplevel 1 {self class}]]
+	    # Double up the list of variable names
+	    foreach v [list $name {*}$args] {
+		if {[string match *(*) $v]} {
+		    set reason "can't create a scalar variable that looks like an array element"
+		    return -code error -errorcode {TCL UPVAR LOCAL_ELEMENT} \
+			[format {bad variable name "%s": %s} $v $reason]
+		}
+		if {[string match *::* $v]} {
+		    set reason "can't create a local variable with a namespace separator in it"
+		    return -code error -errorcode {TCL UPVAR INVERTED} \
+			[format {bad variable name "%s": %s} $v $reason]
+		}
+		lappend vs $v $v
+	    }
+	    # Lastly, link the caller's local variables to the class's variables
+	    tailcall namespace upvar $ns {*}$vs
+	}
+
+	# ------------------------------------------------------------------
+	#
+	# link --
+	#
+	#	Make a command that invokes a method on the current object.
+	#	The name of the command and the name of the method match by
+	#	default.
+	#
+	# ------------------------------------------------------------------
+
+	proc link {args} {
+	    set ns [uplevel 1 {::namespace current}]
+	    foreach link $args {
+		if {[llength $link] == 2} {
+		    lassign $link src dst
+		} elseif {[llength $link] == 1} {
+		    lassign $link src
+		    set dst $src
+		} else {
+		    return -code error -errorcode {TCLOO CMDLINK FORMAT} \
+			"bad link description; must only have one or two elements"
+		}
+		if {![string match ::* $src]} {
+		    set src [string cat $ns :: $src]
+		}
+		interp alias {} $src {} ${ns}::my $dst
+		trace add command ${ns}::my delete [list \
+		    ::oo::UnlinkLinkedCommand $src]
+	    }
+	    return
+	}
+    }
+
+    # ----------------------------------------------------------------------
+    #
+    # UnlinkLinkedCommand --
+    #
+    #	Callback used to remove linked command when the underlying mechanism
+    #	that supports it is deleted.
+    #
+    # ----------------------------------------------------------------------
+
+    proc UnlinkLinkedCommand {cmd args} {
+	if {[namespace which $cmd] ne {}} {
+	    rename $cmd {}
+	}
+    }
+
+    # ----------------------------------------------------------------------
+    #
+    # DelegateName --
+    #
+    #	Utility that gets the name of the class delegate for a class. It's
+    #	trivial, but makes working with them much easier as delegate names are
+    #	intentionally hard to create by accident.
+    #
+    # ----------------------------------------------------------------------
+
+    proc DelegateName {class} {
+	string cat [info object namespace $class] {:: oo ::delegate}
+    }
+
+    # ----------------------------------------------------------------------
+    #
+    # MixinClassDelegates --
+    #
+    #	Support code called *after* [oo::define] inside the constructor of a
+    #	class that patches in the appropriate class delegates.
+    #
+    # ----------------------------------------------------------------------
+
+    proc MixinClassDelegates {class} {
+	if {![info object isa class $class]} {
+	    return
+	}
+	set delegate [DelegateName $class]
+	if {![info object isa class $delegate]} {
+	    return
+	}
+	foreach c [info class superclass $class] {
+	    set d [DelegateName $c]
+	    if {![info object isa class $d]} {
+		continue
+	    }
+	    define $delegate superclass -append $d
+	}
+	objdefine $class mixin -append $delegate
+    }
+
+    # ----------------------------------------------------------------------
+    #
+    # UpdateClassDelegatesAfterClone --
+    #
+    #	Support code that is like [MixinClassDelegates] except for when a
+    #	class is cloned.
+    #
+    # ----------------------------------------------------------------------
+
+    proc UpdateClassDelegatesAfterClone {originObject targetObject} {
+	# Rebuild the class inheritance delegation class
+	set originDelegate [DelegateName $originObject]
+	set targetDelegate [DelegateName $targetObject]
+	if {
+	    [info object isa class $originDelegate]
+	    && ![info object isa class $targetDelegate]
+	} then {
+	    copy $originDelegate $targetDelegate
+	    objdefine $targetObject mixin -set \
+		{*}[lmap c [info object mixin $targetObject] {
+		    if {$c eq $originDelegate} {set targetDelegate} {set c}
+		}]
+	}
+    }
+
+    # ----------------------------------------------------------------------
+    #
+    # oo::define::classmethod --
+    #
+    #	Defines a class method. See define(n) for details.
+    #
+    # Note that the ::oo::define namespace is semi-public and a bit weird
+    # anyway, so we don't regard the namespace path as being under control:
+    # fully qualified names are used for everything.
+    #
+    # ----------------------------------------------------------------------
+
+    proc define::classmethod {name {args {}} {body {}}} {
+        # Create the method on the class if the caller gave arguments and body
+        ::set argc [::llength [::info level 0]]
+        ::if {$argc == 3} {
+            ::return -code error -errorcode {TCL WRONGARGS} [::format \
+		{wrong # args: should be "%s name ?args body?"} \
+                [::lindex [::info level 0] 0]]
+        }
+        ::set cls [::uplevel 1 self]
+        ::if {$argc == 4} {
+            ::oo::define [::oo::DelegateName $cls] method $name $args $body
+        }
+        # Make the connection by forwarding
+        ::tailcall forward $name myclass $name
+    }
+
+    # ----------------------------------------------------------------------
+    #
+    # oo::define::initialise, oo::define::initialize --
+    #
+    #	Do specific initialisation for a class. See define(n) for details.
+    #
+    # Note that the ::oo::define namespace is semi-public and a bit weird
+    # anyway, so we don't regard the namespace path as being under control:
+    # fully qualified names are used for everything.
+    #
+    # ----------------------------------------------------------------------
+
+    proc define::initialise {body} {
+        ::set clsns [::info object namespace [::uplevel 1 self]]
+        ::tailcall apply [::list {} $body $clsns]
+    }
+
+    # Make the [initialise] definition appear as [initialize] too
+    namespace eval define {
+	::namespace export initialise
+	::namespace eval tmp {::namespace import ::oo::define::initialise}
+	::namespace export -clear
+	::rename tmp::initialise initialize
+	::namespace delete tmp
+    }
+
+    # ----------------------------------------------------------------------
+    #
+    # Slot --
+    #
+    #	The class of slot operations, which are basically lists at the low
+    #	level of TclOO; this provides a more consistent interface to them.
+    #
+    # ----------------------------------------------------------------------
+
+    define Slot {
+	# ------------------------------------------------------------------
+	#
+	# Slot Get --
+	#
+	#	Basic slot getter. Retrieves the contents of the slot.
+	#	Particular slots must provide concrete non-erroring
+	#	implementation.
+	#
+	# ------------------------------------------------------------------
+
+	method Get {} {
+	    return -code error -errorcode {TCLOO ABSTRACT_SLOT} "unimplemented"
+	}
+
+	# ------------------------------------------------------------------
+	#
+	# Slot Set --
+	#
+	#	Basic slot setter. Sets the contents of the slot.  Particular
+	#	slots must provide concrete non-erroring implementation.
+	#
+	# ------------------------------------------------------------------
+
+	method Set list {
+	    return -code error -errorcode {TCLOO ABSTRACT_SLOT} "unimplemented"
+	}
+
+	# ------------------------------------------------------------------
+	#
+	# Slot -set, -append, -clear, --default-operation --
+	#
+	#	Standard public slot operations. If a slot can't figure out
+	#	what method to call directly, it uses --default-operation.
+	#
+	# ------------------------------------------------------------------
+
+	method -set args {tailcall my Set $args}
+	method -append args {
+	    set current [uplevel 1 [list [namespace which my] Get]]
+	    tailcall my Set [list {*}$current {*}$args]
+	}
+	method -clear {} {tailcall my Set {}}
+
+	# Default handling
+	forward --default-operation my -append
+	method unknown {args} {
+	    set def --default-operation
+	    if {[llength $args] == 0} {
+		tailcall my $def
+	    } elseif {![string match -* [lindex $args 0]]} {
+		tailcall my $def {*}$args
+	    }
+	    next {*}$args
+	}
+
+	# Set up what is exported and what isn't
+	export -set -append -clear
+	unexport unknown destroy
+    }
+
+    # Set the default operation differently for these slots
+    objdefine define::superclass forward --default-operation my -set
+    objdefine define::mixin forward --default-operation my -set
+    objdefine objdefine::mixin forward --default-operation my -set
+
+    # ----------------------------------------------------------------------
+    #
+    # oo::object <cloned> --
+    #
+    #	Handler for cloning objects that clones basic bits (only!) of the
+    #	object's namespace. Non-procedures, traces, sub-namespaces, etc. need
+    #	more complex (and class-specific) handling.
+    #
+    # ----------------------------------------------------------------------
+
+    define object method <cloned> {originObject} {
+	# Copy over the procedures from the original namespace
+	foreach p [info procs [info object namespace $originObject]::*] {
+	    set args [info args $p]
+	    set idx -1
+	    foreach a $args {
+		if {[info default $p $a d]} {
+		    lset args [incr idx] [list $a $d]
+		} else {
+		    lset args [incr idx] [list $a]
+		}
+	    }
+	    set b [info body $p]
+	    set p [namespace tail $p]
+	    proc $p $args $b
+	}
+	# Copy over the variables from the original namespace
+	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
+		}
+	    }
+	}
+	# General commands, sub-namespaces and advancd variable config (traces,
+	# etc) are *not* copied over. Classes that want that should do it
+	# themselves.
+    }
+
+    # ----------------------------------------------------------------------
+    #
+    # oo::class <cloned> --
+    #
+    #	Handler for cloning classes, which fixes up the delegates.
+    #
+    # ----------------------------------------------------------------------
+
+    define class method <cloned> {originObject} {
+	next $originObject
+	# Rebuild the class inheritance delegation class
+	::oo::UpdateClassDelegatesAfterClone $originObject [self]
+    }
+
+    # ----------------------------------------------------------------------
+    #
+    # oo::singleton --
+    #
+    #	A metaclass that is used to make classes that only permit one instance
+    #	of them to exist. See singleton(n).
+    #
+    # ----------------------------------------------------------------------
+
+    class create singleton {
+	superclass class
+	variable object
+	unexport create createWithNamespace
+	method new args {
+	    if {![info exists object] || ![info object isa object $object]} {
+		set object [next {*}$args]
+		::oo::objdefine $object {
+		    method destroy {} {
+			::return -code error -errorcode {TCLOO SINGLETON} \
+			    "may not destroy a singleton object"
+		    }
+		    method <cloned> {originObject} {
+			::return -code error -errorcode {TCLOO SINGLETON} \
+			    "may not clone a singleton object"
+		    }
+		}
+	    }
+	    return $object
+	}
+    }
+
+    # ----------------------------------------------------------------------
+    #
+    # oo::abstract --
+    #
+    #	A metaclass that is used to make classes that can't be directly
+    #	instantiated. See abstract(n).
+    #
+    # ----------------------------------------------------------------------
+
+    class create abstract {
+	superclass class
+	unexport create createWithNamespace new
+    }
+}
+
+# Local Variables:
+# mode: tcl
+# c-basic-offset: 4
+# fill-column: 78
+# End:

generic/tclOOStubInit.c

@@ -73,6 +73,7 @@ const TclOOStubs tclOOStubs = {
     Tcl_ClassSetConstructor, /* 26 */
     Tcl_ClassSetDestructor, /* 27 */
     Tcl_GetObjectName, /* 28 */
+    Tcl_MethodIsPrivate, /* 29 */
 };
 
 /* !END!: Do not edit above this line. */

generic/tclObj.c

@@ -37,7 +37,7 @@ Tcl_Obj *tclFreeObjList = NULL;
  * TclNewObj macro, however, so must be visible.
  */
 
-#ifdef TCL_THREADS
+#if TCL_THREADS
 MODULE_SCOPE Tcl_Mutex tclObjMutex;
 Tcl_Mutex tclObjMutex;
 #endif
@@ -50,7 +50,7 @@ Tcl_Mutex tclObjMutex;
 
 char tclEmptyString = '\0';
 
-#if defined(TCL_MEM_DEBUG) && defined(TCL_THREADS)
+#if TCL_THREADS && defined(TCL_MEM_DEBUG)
 /*
  * Structure for tracking the source file and line number where a given
  * Tcl_Obj was allocated.  We also track the pointer to the Tcl_Obj itself,
@@ -87,7 +87,7 @@ typedef struct {
                                  * tclCompile.h for the definition of this
                                  * structure, and for references to all
                                  * related places in the core. */
-#if defined(TCL_MEM_DEBUG) && defined(TCL_THREADS)
+#if TCL_THREADS && defined(TCL_MEM_DEBUG)
     Tcl_HashTable *objThreadMap;/* Thread local table that is used to check
                                  * that a Tcl_Obj was not allocated by some
                                  * other thread. */
@@ -156,7 +156,7 @@ typedef struct PendingObjData {
 /*
  * Macro to set up the local reference to the deletion context.
  */
-#ifndef TCL_THREADS
+#if !TCL_THREADS
 static PendingObjData pendingObjData;
 #define ObjInitDeletionContext(contextPtr) \
     PendingObjData *const contextPtr = &pendingObjData
@@ -452,7 +452,7 @@ TclInitObjSubsystem(void)
 void
 TclFinalizeThreadObjects(void)
 {
-#if defined(TCL_MEM_DEBUG) && defined(TCL_THREADS)
+#if TCL_THREADS && defined(TCL_MEM_DEBUG)
     Tcl_HashEntry *hPtr;
     Tcl_HashSearch hSearch;
     ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
@@ -1009,7 +1009,7 @@ void
 TclDbDumpActiveObjects(
     FILE *outFile)
 {
-#if defined(TCL_MEM_DEBUG) && defined(TCL_THREADS)
+#if TCL_THREADS && defined(TCL_MEM_DEBUG)
     Tcl_HashSearch hSearch;
     Tcl_HashEntry *hPtr;
     Tcl_HashTable *tablePtr;
@@ -1069,7 +1069,7 @@ TclDbInitNewObj(
     objPtr->length = 0;
     objPtr->typePtr = NULL;
 
-#ifdef TCL_THREADS
+#if TCL_THREADS
     /*
      * Add entry to a thread local map used to check if a Tcl_Obj was
      * allocated by the currently executing thread.
@@ -1305,7 +1305,7 @@ TclFreeObj(
 
     ObjInitDeletionContext(context);
 
-# ifdef TCL_THREADS
+#if TCL_THREADS
     /*
      * Check to make sure that the Tcl_Obj was allocated by the current
      * thread. Don't do this check when shutting down since thread local
@@ -1632,32 +1632,30 @@ Tcl_GetString(
     register Tcl_Obj *objPtr)	/* Object whose string rep byte pointer should
 				 * be returned. */
 {
-    if (objPtr->bytes != NULL) {
-	return objPtr->bytes;
-    }
-
-    /*
-     * Note we do not check for objPtr->typePtr == NULL.  An invariant of
-     * a properly maintained Tcl_Obj is that at least  one of objPtr->bytes
-     * and objPtr->typePtr must not be NULL.  If broken extensions fail to
-     * maintain that invariant, we can crash here.
-     */
-
-    if (objPtr->typePtr->updateStringProc == NULL) {
+    if (objPtr->bytes == NULL) {
 	/*
-	 * Those Tcl_ObjTypes which choose not to define an updateStringProc
-	 * must be written in such a way that (objPtr->bytes) never becomes
-	 * NULL.  This panic was added in Tcl 8.1.
+	 * Note we do not check for objPtr->typePtr == NULL.  An invariant
+	 * of a properly maintained Tcl_Obj is that at least  one of
+	 * objPtr->bytes and objPtr->typePtr must not be NULL.  If broken
+	 * extensions fail to maintain that invariant, we can crash here.
 	 */
 
-	Tcl_Panic("UpdateStringProc should not be invoked for type %s",
-		objPtr->typePtr->name);
-    }
-    objPtr->typePtr->updateStringProc(objPtr);
-    if (objPtr->bytes == NULL || objPtr->length < 0
-	    || objPtr->bytes[objPtr->length] != '\0') {
-	Tcl_Panic("UpdateStringProc for type '%s' "
-		"failed to create a valid string rep", objPtr->typePtr->name);
+	if (objPtr->typePtr->updateStringProc == NULL) {
+	    /*
+	     * Those Tcl_ObjTypes which choose not to define an
+	     * updateStringProc must be written in such a way that
+	     * (objPtr->bytes) never becomes NULL.
+	     */
+	    Tcl_Panic("UpdateStringProc should not be invoked for type %s",
+		    objPtr->typePtr->name);
+	}
+	objPtr->typePtr->updateStringProc(objPtr);
+	if (objPtr->bytes == NULL || objPtr->length < 0
+		|| objPtr->bytes[objPtr->length] != '\0') {
+	    Tcl_Panic("UpdateStringProc for type '%s' "
+		    "failed to create a valid string rep",
+		    objPtr->typePtr->name);
+	}
     }
     return objPtr->bytes;
 }
@@ -1693,8 +1691,31 @@ Tcl_GetStringFromObj(
 				 * rep's byte array length should * be stored.
 				 * If NULL, no length is stored. */
 {
-    (void) TclGetString(objPtr);
+    if (objPtr->bytes == NULL) {
+	/*
+	 * Note we do not check for objPtr->typePtr == NULL.  An invariant
+	 * of a properly maintained Tcl_Obj is that at least  one of
+	 * objPtr->bytes and objPtr->typePtr must not be NULL.  If broken
+	 * extensions fail to maintain that invariant, we can crash here.
+	 */
 
+	if (objPtr->typePtr->updateStringProc == NULL) {
+	    /*
+	     * Those Tcl_ObjTypes which choose not to define an
+	     * updateStringProc must be written in such a way that
+	     * (objPtr->bytes) never becomes NULL.
+	     */
+	    Tcl_Panic("UpdateStringProc should not be invoked for type %s",
+		    objPtr->typePtr->name);
+	}
+	objPtr->typePtr->updateStringProc(objPtr);
+	if (objPtr->bytes == NULL || objPtr->length < 0
+		|| objPtr->bytes[objPtr->length] != '\0') {
+	    Tcl_Panic("UpdateStringProc for type '%s' "
+		    "failed to create a valid string rep",
+		    objPtr->typePtr->name);
+	}
+    }
     if (lengthPtr != NULL) {
 	*lengthPtr = objPtr->length;
     }
@@ -3598,7 +3619,7 @@ Tcl_DbIncrRefCount(
 	Tcl_Panic("incrementing refCount of previously disposed object");
     }
 
-# ifdef TCL_THREADS
+#if TCL_THREADS
     /*
      * Check to make sure that the Tcl_Obj was allocated by the current
      * thread. Don't do this check when shutting down since thread local
@@ -3661,7 +3682,7 @@ Tcl_DbDecrRefCount(
 	Tcl_Panic("decrementing refCount of previously disposed object");
     }
 
-# ifdef TCL_THREADS
+#if TCL_THREADS
     /*
      * Check to make sure that the Tcl_Obj was allocated by the current
      * thread. Don't do this check when shutting down since thread local
@@ -3726,7 +3747,7 @@ Tcl_DbIsShared(
 	Tcl_Panic("checking whether previously disposed object is shared");
     }
 
-# ifdef TCL_THREADS
+#if TCL_THREADS
     /*
      * Check to make sure that the Tcl_Obj was allocated by the current
      * thread. Don't do this check when shutting down since thread local

generic/tclPanic.c

@@ -23,8 +23,8 @@
  * procedure.
  */
 
-#if defined(__CYGWIN__)
-static TCL_NORETURN Tcl_PanicProc *panicProc = tclWinDebugPanic;
+#if defined(__CYGWIN__) || (defined(_WIN32) && (defined(TCL_NO_DEPRECATED) || TCL_MAJOR_VERSION > 8))
+static TCL_NORETURN1 Tcl_PanicProc *panicProc = tclWinDebugPanic;
 #else
 static TCL_NORETURN1 Tcl_PanicProc *panicProc = NULL;
 #endif
@@ -45,6 +45,7 @@ static TCL_NORETURN1 Tcl_PanicProc *panicProc = NULL;
  *----------------------------------------------------------------------
  */
 
+#undef Tcl_SetPanicProc
 void
 Tcl_SetPanicProc(
     TCL_NORETURN1 Tcl_PanicProc *proc)

generic/tclParse.c

@@ -979,7 +979,12 @@ TclParseBackslash(
     if (readPtr != NULL) {
 	*readPtr = count;
     }
-    return Tcl_UniCharToUtf(result, dst);
+    count = Tcl_UniCharToUtf(result, dst);
+    if (!count) {
+	/* Special case for handling upper surrogates. */
+	count = Tcl_UniCharToUtf(-1, dst);
+    }
+    return count;
 }
 
 /*

generic/tclPkg.c

@@ -577,7 +577,7 @@ SelectPackage(ClientData data[], Tcl_Interp *interp, int result) {
     PkgAvail *availPtr, *bestPtr, *bestStablePtr;
     char *availVersion, *bestVersion, *bestStableVersion;
 				/* Internal rep. of versions */
-    int availStable, satisfies; 
+    int availStable, satisfies;
     Require *reqPtr = data[0];
     int reqc = PTR2INT(data[1]);
     Tcl_Obj **const reqv = data[2];

generic/tclPkgConfig.c

@@ -40,7 +40,7 @@
  * configuration information.
  */
 
-#ifdef TCL_THREADS
+#if TCL_THREADS
 #  define  CFG_THREADED		"1"
 #else
 #  define  CFG_THREADED		"0"

generic/tclProcess.c

@@ -1,7 +1,7 @@
 /*
  * tclProcess.c --
  *
- *	This file implements the "tcl::process" ensemble for subprocess 
+ *	This file implements the "tcl::process" ensemble for subprocess
  *	management as defined by TIP #462.
  *
  * Copyright (c) 2017 Frederic Bonnet.
@@ -13,14 +13,14 @@
 #include "tclInt.h"
 
 /*
- * Autopurge flag. Process-global because of the way Tcl manages child 
+ * Autopurge flag. Process-global because of the way Tcl manages child
  * processes (see tclPipe.c).
  */
 
 static int autopurge = 1;	/* Autopurge flag. */
 
 /*
- * Hash tables that keeps track of all child process statuses. Keys are the 
+ * Hash tables that keeps track of all child process statuses. Keys are the
  * child process ids and resolved pids, values are (ProcessInfo *).
  */
 
@@ -29,7 +29,7 @@ typedef struct ProcessInfo {
     int resolvedPid;		/* Resolved process id. */
     int purge;			/* Purge eventualy. */
     TclProcessWaitStatus status;/* Process status. */
-    int code;			/* Error code, exit status or signal 
+    int code;			/* Error code, exit status or signal
 				   number. */
     Tcl_Obj *msg;		/* Error message. */
     Tcl_Obj *error;		/* Error code. */
@@ -47,7 +47,7 @@ static void		InitProcessInfo(ProcessInfo *info, Tcl_Pid pid,
 			    int resolvedPid);
 static void		FreeProcessInfo(ProcessInfo *info);
 static int		RefreshProcessInfo(ProcessInfo *info, int options);
-static TclProcessWaitStatus WaitProcessStatus(Tcl_Pid pid, int resolvedPid, 
+static TclProcessWaitStatus WaitProcessStatus(Tcl_Pid pid, int resolvedPid,
 			    int options, int *codePtr, Tcl_Obj **msgPtr,
 			    Tcl_Obj **errorObjPtr);
 static Tcl_Obj *	BuildProcessStatusObj(ProcessInfo *info);
@@ -160,7 +160,7 @@ RefreshProcessInfo(
 	 * Refresh & store status.
 	 */
 
-	info->status = WaitProcessStatus(info->pid, info->resolvedPid, 
+	info->status = WaitProcessStatus(info->pid, info->resolvedPid,
 		options, &info->code, &info->msg, &info->error);
 	if (info->msg) Tcl_IncrRefCount(info->msg);
 	if (info->error) Tcl_IncrRefCount(info->error);
@@ -214,7 +214,7 @@ WaitProcessStatus(
 	/*
 	 * No change.
 	 */
-	
+
 	return TCL_PROCESS_UNCHANGED;
     }
 
@@ -370,7 +370,7 @@ BuildProcessStatusObj(
 	/*
 	 * Normal exit, return TCL_OK.
 	 */
-	
+
 	return Tcl_NewIntObj(TCL_OK);
     }
 
@@ -388,7 +388,7 @@ BuildProcessStatusObj(
  *
  * ProcessListObjCmd --
  *
- *	This function implements the 'tcl::process list' Tcl command. 
+ *	This function implements the 'tcl::process list' Tcl command.
  *	Refer to the user documentation for details on what it does.
  *
  * Results:
@@ -423,10 +423,10 @@ ProcessListObjCmd(
 
     list = Tcl_NewListObj(0, NULL);
     Tcl_MutexLock(&infoTablesMutex);
-    for (entry = Tcl_FirstHashEntry(&infoTablePerResolvedPid, &search); 
+    for (entry = Tcl_FirstHashEntry(&infoTablePerResolvedPid, &search);
 	    entry != NULL; entry = Tcl_NextHashEntry(&search)) {
 	info = (ProcessInfo *) Tcl_GetHashValue(entry);
-	Tcl_ListObjAppendElement(interp, list, 
+	Tcl_ListObjAppendElement(interp, list,
 		Tcl_NewIntObj(info->resolvedPid));
     }
     Tcl_MutexUnlock(&infoTablesMutex);
@@ -438,7 +438,7 @@ ProcessListObjCmd(
  *
  * ProcessStatusObjCmd --
  *
- *	This function implements the 'tcl::process status' Tcl command. 
+ *	This function implements the 'tcl::process status' Tcl command.
  *	Refer to the user documentation for details on what it does.
  *
  * Results:
@@ -504,7 +504,7 @@ ProcessStatusObjCmd(
 
 	dict = Tcl_NewDictObj();
 	Tcl_MutexLock(&infoTablesMutex);
-	for (entry = Tcl_FirstHashEntry(&infoTablePerResolvedPid, &search); 
+	for (entry = Tcl_FirstHashEntry(&infoTablePerResolvedPid, &search);
 		entry != NULL; entry = Tcl_NextHashEntry(&search)) {
 	    info = (ProcessInfo *) Tcl_GetHashValue(entry);
 	    RefreshProcessInfo(info, options);
@@ -513,7 +513,7 @@ ProcessStatusObjCmd(
 		/*
 		 * Purge entry.
 		 */
-		
+
 		Tcl_DeleteHashEntry(entry);
 		entry = Tcl_FindHashEntry(&infoTablePerPid, info->pid);
 		Tcl_DeleteHashEntry(entry);
@@ -523,7 +523,7 @@ ProcessStatusObjCmd(
 		 * Add to result.
 		 */
 
-		Tcl_DictObjPut(interp, dict, Tcl_NewIntObj(info->resolvedPid), 
+		Tcl_DictObjPut(interp, dict, Tcl_NewIntObj(info->resolvedPid),
 			BuildProcessStatusObj(info));
 	    }
 	}
@@ -532,7 +532,7 @@ ProcessStatusObjCmd(
 	/*
 	 * Only return statuses of provided processes.
 	 */
-	
+
 	result = Tcl_ListObjGetElements(interp, objv[1], &numPids, &pidObjs);
 	if (result != TCL_OK) {
 	    return result;
@@ -552,10 +552,10 @@ ProcessStatusObjCmd(
 		/*
 		 * Skip unknown process.
 		 */
-		
+
 		continue;
 	    }
-	    
+
 	    info = (ProcessInfo *) Tcl_GetHashValue(entry);
 	    RefreshProcessInfo(info, options);
 
@@ -563,7 +563,7 @@ ProcessStatusObjCmd(
 		/*
 		 * Purge entry.
 		 */
-		
+
 		Tcl_DeleteHashEntry(entry);
 		entry = Tcl_FindHashEntry(&infoTablePerPid, info->pid);
 		Tcl_DeleteHashEntry(entry);
@@ -573,7 +573,7 @@ ProcessStatusObjCmd(
 		 * Add to result.
 		 */
 
-		Tcl_DictObjPut(interp, dict, Tcl_NewIntObj(info->resolvedPid), 
+		Tcl_DictObjPut(interp, dict, Tcl_NewIntObj(info->resolvedPid),
 			BuildProcessStatusObj(info));
 	    }
 	}
@@ -587,7 +587,7 @@ ProcessStatusObjCmd(
  *
  * ProcessPurgeObjCmd --
  *
- *	This function implements the 'tcl::process purge' Tcl command. 
+ *	This function implements the 'tcl::process purge' Tcl command.
  *	Refer to the user documentation for details on what it does.
  *
  * Results:
@@ -632,7 +632,7 @@ ProcessPurgeObjCmd(
 	 */
 
 	Tcl_MutexLock(&infoTablesMutex);
-	for (entry = Tcl_FirstHashEntry(&infoTablePerResolvedPid, &search); 
+	for (entry = Tcl_FirstHashEntry(&infoTablePerResolvedPid, &search);
 		entry != NULL; entry = Tcl_NextHashEntry(&search)) {
 	    info = (ProcessInfo *) Tcl_GetHashValue(entry);
 	    if (info->purge) {
@@ -647,7 +647,7 @@ ProcessPurgeObjCmd(
 	/*
 	 * Purge only provided processes.
 	 */
-	
+
 	result = Tcl_ListObjGetElements(interp, objv[1], &numPids, &pidObjs);
 	if (result != TCL_OK) {
 	    return result;
@@ -665,7 +665,7 @@ ProcessPurgeObjCmd(
 		/*
 		 * Skip unknown process.
 		 */
-		
+
 		continue;
 	    }
 
@@ -687,7 +687,7 @@ ProcessPurgeObjCmd(
  *
  * ProcessAutopurgeObjCmd --
  *
- *	This function implements the 'tcl::process autopurge' Tcl command. 
+ *	This function implements the 'tcl::process autopurge' Tcl command.
  *	Refer to the user documentation for details on what it does.
  *
  * Results:
@@ -715,7 +715,7 @@ ProcessAutopurgeObjCmd(
 	/*
 	 * Set given value.
 	 */
-	
+
 	int flag;
 	int result = Tcl_GetBooleanFromObj(interp, objv[1], &flag);
 	if (result != TCL_OK) {
@@ -725,8 +725,8 @@ ProcessAutopurgeObjCmd(
 	autopurge = !!flag;
     }
 
-    /* 
-     * Return current value. 
+    /*
+     * Return current value.
      */
 
     Tcl_SetObjResult(interp, Tcl_NewBooleanObj(autopurge));
@@ -821,9 +821,9 @@ TclProcessCreated(
 	/*
 	 * Pid was reused, free old info and reuse structure.
 	 */
-	
+
 	info = (ProcessInfo *) Tcl_GetHashValue(entry);
-	entry2 = Tcl_FindHashEntry(&infoTablePerResolvedPid, 
+	entry2 = Tcl_FindHashEntry(&infoTablePerResolvedPid,
 		INT2PTR(resolvedPid));
 	if (entry2) Tcl_DeleteHashEntry(entry2);
 	FreeProcessInfo(info);
@@ -893,8 +893,8 @@ TclProcessWait(
 	/*
 	 * Unknown process, just call WaitProcessStatus and return.
 	 */
-	
-	result = WaitProcessStatus(pid, TclpGetPid(pid), options, codePtr, 
+
+	result = WaitProcessStatus(pid, TclpGetPid(pid), options, codePtr,
 		msgObjPtr, errorObjPtr);
 	if (msgObjPtr && *msgObjPtr) Tcl_IncrRefCount(*msgObjPtr);
 	if (errorObjPtr && *errorObjPtr) Tcl_IncrRefCount(*errorObjPtr);
@@ -909,7 +909,7 @@ TclProcessWait(
 	 * so report no change.
 	 */
     Tcl_MutexUnlock(&infoTablesMutex);
-	
+
 	return TCL_PROCESS_UNCHANGED;
     }
 
@@ -919,7 +919,7 @@ TclProcessWait(
 	 * No change, stop there.
 	 */
     Tcl_MutexUnlock(&infoTablesMutex);
-	
+
 	return TCL_PROCESS_UNCHANGED;
     }
 
@@ -940,7 +940,7 @@ TclProcessWait(
 	 */
 
 	Tcl_DeleteHashEntry(entry);
-	entry = Tcl_FindHashEntry(&infoTablePerResolvedPid, 
+	entry = Tcl_FindHashEntry(&infoTablePerResolvedPid,
 		INT2PTR(info->resolvedPid));
 	Tcl_DeleteHashEntry(entry);
 	FreeProcessInfo(info);

generic/tclStrToD.c

@@ -4543,7 +4543,7 @@ Tcl_InitBignumFromDouble(
 	return TCL_ERROR;
     }
 
-    fract = frexp(d,&expt);
+    fract = frexp(d, &expt);
     if (expt <= 0) {
 	mp_init(b);
 	mp_zero(b);
@@ -4883,7 +4883,7 @@ Pow10TimesFrExp(
 	 * Multiply by 10**exponent.
 	 */
 
-	retval = frexp(retval * pow10vals[exponent&0xf], &j);
+	retval = frexp(retval * pow10vals[exponent & 0xf], &j);
 	expt += j;
 	for (i=4; i<9; ++i) {
 	    if (exponent & (1<<i)) {

generic/tclStringObj.c

@@ -455,6 +455,48 @@ Tcl_GetCharLength(
     return numChars;
 }
 
+/*
+ *----------------------------------------------------------------------
+ *
+ * TclCheckEmptyString --
+ *
+ *	Determine whether the string value of an object is or would be the
+ *	empty string, without generating a string representation.
+ *
+ * Results:
+ *	Returns 1 if empty, 0 if not, and -1 if unknown.
+ *
+ * Side effects:
+ *	None.
+ *
+ *----------------------------------------------------------------------
+ */
+int
+TclCheckEmptyString(
+    Tcl_Obj *objPtr)
+{
+    int length = -1;
+
+    if (objPtr->bytes == &tclEmptyString) {
+	return TCL_EMPTYSTRING_YES;
+    }
+
+    if (TclListObjIsCanonical(objPtr)) {
+	Tcl_ListObjLength(NULL, objPtr, &length);
+	return length == 0;
+    }
+
+    if (TclIsPureDict(objPtr)) {
+	Tcl_DictObjSize(NULL, objPtr, &length);
+	return length == 0;
+    }
+
+    if (objPtr->bytes == NULL) {
+	return TCL_EMPTYSTRING_UNKNOWN;
+    }
+    return objPtr->length == 0;
+}
+
 /*
  *----------------------------------------------------------------------
  *
@@ -525,20 +567,22 @@ Tcl_GetUniChar(
     if (index >= stringPtr->numChars) {
 	return -1;
     }
-	ch = stringPtr->unicode[index];
+    ch = stringPtr->unicode[index];
 #if TCL_UTF_MAX <= 4
-	/* See: bug [11ae2be95dac9417] */
-	if ((ch&0xF800) == 0xD800) {
-	    if (ch&0x400) {
-		if ((index > 0) && ((stringPtr->unicode[index-1]&0xFC00) == 0xD800)) {
-		    ch = -1; /* low surrogate preceded by high surrogate */
-		}
-	    } else if ((++index < stringPtr->numChars)
-		    && ((stringPtr->unicode[index]&0xFC00) == 0xDC00)) {
-		/* high surrogate followed by low surrogate */
-		ch = (((ch & 0x3FF) << 10) | (stringPtr->unicode[index] & 0x3FF)) + 0x10000;
+    /* See: bug [11ae2be95dac9417] */
+    if ((ch & 0xF800) == 0xD800) {
+	if (ch & 0x400) {
+	    if ((index > 0)
+		    && ((stringPtr->unicode[index-1] & 0xFC00) == 0xD800)) {
+		ch = -1; /* low surrogate preceded by high surrogate */
 	    }
+	} else if ((++index < stringPtr->numChars)
+		&& ((stringPtr->unicode[index] & 0xFC00) == 0xDC00)) {
+	    /* high surrogate followed by low surrogate */
+	    ch = (((ch & 0x3FF) << 10) |
+			(stringPtr->unicode[index] & 0x3FF)) + 0x10000;
 	}
+    }
 #endif
     return ch;
 }
@@ -562,6 +606,8 @@ Tcl_GetUniChar(
  *----------------------------------------------------------------------
  */
 
+#ifndef TCL_NO_DEPRECATED
+#undef Tcl_GetUnicode
 Tcl_UniChar *
 Tcl_GetUnicode(
     Tcl_Obj *objPtr)		/* The object to find the unicode string
@@ -569,6 +615,7 @@ Tcl_GetUnicode(
 {
     return Tcl_GetUnicodeFromObj(objPtr, NULL);
 }
+#endif /* TCL_NO_DEPRECATED */
 
 /*
  *----------------------------------------------------------------------
@@ -644,7 +691,8 @@ Tcl_GetRange(
 
     if (first < 0) {
 	first = 0;
-	}
+    }
+
     /*
      * Optimize the case where we're really dealing with a bytearray object
      * we don't need to convert to a string to perform the substring operation.
@@ -652,13 +700,14 @@ Tcl_GetRange(
 
     if (TclIsPureByteArray(objPtr)) {
 	unsigned char *bytes = Tcl_GetByteArrayFromObj(objPtr, &length);
+
 	if (last >= length) {
 	    last = length - 1;
 	}
 	if (last < first) {
 	    return Tcl_NewObj();
 	}
-	return Tcl_NewByteArrayObj(bytes+first, last-first+1);
+	return Tcl_NewByteArrayObj(bytes + first, last - first + 1);
     }
 
     /*
@@ -697,24 +746,25 @@ Tcl_GetRange(
 	FillUnicodeRep(objPtr);
 	stringPtr = GET_STRING(objPtr);
     }
-	if (last > stringPtr->numChars) {
-	    last = stringPtr->numChars;
-	}
-	if (last < first) {
-	    return Tcl_NewObj();
-	}
+    if (last > stringPtr->numChars) {
+	last = stringPtr->numChars;
+    }
+    if (last < first) {
+	return Tcl_NewObj();
+    }
 #if TCL_UTF_MAX <= 4
-	/* See: bug [11ae2be95dac9417] */
-	if ((first>0) && ((stringPtr->unicode[first]&0xFC00) == 0xDC00)
-		&& ((stringPtr->unicode[first-1]&0xFC00) == 0xD800)) {
-	    ++first;
-	}
-	if ((last+1<stringPtr->numChars) && ((stringPtr->unicode[last+1]&0xFC00) == 0xDC00)
-		&& ((stringPtr->unicode[last]&0xFC00) == 0xD800)) {
-	    ++last;
-	}
+    /* See: bug [11ae2be95dac9417] */
+    if ((first > 0) && ((stringPtr->unicode[first] & 0xFC00) == 0xDC00)
+	    && ((stringPtr->unicode[first-1] & 0xFC00) == 0xD800)) {
+	++first;
+    }
+    if ((last + 1 < stringPtr->numChars)
+	    && ((stringPtr->unicode[last+1] & 0xFC00) == 0xDC00)
+	    && ((stringPtr->unicode[last] & 0xFC00) == 0xD800)) {
+	++last;
+    }
 #endif
-    return Tcl_NewUnicodeObj(stringPtr->unicode + first, last-first+1);
+    return Tcl_NewUnicodeObj(stringPtr->unicode + first, last - first + 1);
 }
 
 /*
@@ -1272,45 +1322,51 @@ Tcl_AppendObjToObj(
     /*
      * Handle append of one bytearray object to another as a special case.
      * Note that we only do this when the objects are pure so that the
-     * bytearray faithfully represent the true value; Otherwise
-     * appending the byte arrays together could lose information;
+     * bytearray faithfully represent the true value; Otherwise appending the
+     * byte arrays together could lose information;
      */
 
     if ((TclIsPureByteArray(objPtr) || objPtr->bytes == &tclEmptyString)
 	    && TclIsPureByteArray(appendObjPtr)) {
-
 	/*
 	 * You might expect the code here to be
 	 *
 	 *  bytes = Tcl_GetByteArrayFromObj(appendObjPtr, &length);
 	 *  TclAppendBytesToByteArray(objPtr, bytes, length);
 	 *
-	 * and essentially all of the time that would be fine.  However,
-	 * it would run into trouble in the case where objPtr and
-	 * appendObjPtr point to the same thing.  That may never be a
-	 * good idea.  It seems to violate Copy On Write, and we don't
-	 * have any tests for the situation, since making any Tcl commands
-	 * that call Tcl_AppendObjToObj() do that appears impossible
-	 * (They honor Copy On Write!).  For the sake of extensions that
-	 * go off into that realm, though, here's a more complex approach
-	 * that can handle all the cases.
+	 * and essentially all of the time that would be fine. However, it
+	 * would run into trouble in the case where objPtr and appendObjPtr
+	 * point to the same thing. That may never be a good idea. It seems to
+	 * violate Copy On Write, and we don't have any tests for the
+	 * situation, since making any Tcl commands that call
+	 * Tcl_AppendObjToObj() do that appears impossible (They honor Copy On
+	 * Write!). For the sake of extensions that go off into that realm,
+	 * though, here's a more complex approach that can handle all the
+	 * cases.
+	 *
+	 * First, get the lengths.
 	 */
 
-	/* Get lengths */
 	int lengthSrc;
 
 	(void) Tcl_GetByteArrayFromObj(objPtr, &length);
 	(void) Tcl_GetByteArrayFromObj(appendObjPtr, &lengthSrc);
 
-	/* Grow buffer enough for the append */
+	/*
+	 * Grow buffer enough for the append.
+	 */
+
 	TclAppendBytesToByteArray(objPtr, NULL, lengthSrc);
 
-	/* Reset objPtr back to the original value */
+	/*
+	 * Reset objPtr back to the original value.
+	 */
+
 	Tcl_SetByteArrayLength(objPtr, length);
 
 	/*
-	 * Now do the append knowing that buffer growth cannot cause
-	 * any trouble.
+	 * Now do the append knowing that buffer growth cannot cause any
+	 * trouble.
 	 */
 
 	TclAppendBytesToByteArray(objPtr,
@@ -1358,6 +1414,7 @@ Tcl_AppendObjToObj(
     numChars = stringPtr->numChars;
     if ((numChars >= 0) && (appendObjPtr->typePtr == &tclStringType)) {
 	String *appendStringPtr = GET_STRING(appendObjPtr);
+
 	appendNumChars = appendStringPtr->numChars;
     }
 
@@ -1847,6 +1904,11 @@ Tcl_AppendFormatToObj(
 	width = 0;
 	if (isdigit(UCHAR(ch))) {
 	    width = strtoul(format, &end, 10);
+	    if (width < 0) {
+		msg = overflow;
+		errCode = "OVERFLOW";
+		goto errorMsg;
+	    }
 	    format = end;
 	    step = TclUtfToUniChar(format, &ch);
 	} else if (ch == '*') {
@@ -1943,7 +2005,8 @@ Tcl_AppendFormatToObj(
 		format += step;
 		step = TclUtfToUniChar(format, &ch);
 	    }
-	} else if ((ch == 't') || (ch == 'z') || (ch == 'q') || (ch == 'j') || (ch == 'L')) {
+	} else if ((ch == 't') || (ch == 'z') || (ch == 'q') || (ch == 'j')
+		|| (ch == 'L')) {
 	    format += step;
 	    step = TclUtfToUniChar(format, &ch);
 	    useBig = 1;
@@ -1985,6 +2048,10 @@ Tcl_AppendFormatToObj(
 		goto error;
 	    }
 	    length = Tcl_UniCharToUtf(code, buf);
+	    if (!length) {
+		/* Special case for handling upper surrogates. */
+		length = Tcl_UniCharToUtf(-1, buf);
+	    }
 	    segment = Tcl_NewStringObj(buf, length);
 	    Tcl_IncrRefCount(segment);
 	    allocSegment = 1;
@@ -2468,7 +2535,7 @@ Tcl_AppendFormatToObj(
 /*
  *---------------------------------------------------------------------------
  *
- * Tcl_Format--
+ * Tcl_Format --
  *
  * Results:
  *	A refcount zero Tcl_Obj.
@@ -2859,7 +2926,10 @@ TclStringRepeat(
 		Tcl_GetByteArrayFromObj(objResultPtr, NULL),
 		(count - done) * length);
     } else if (unichar) {
-	/* Efficiently produce a pure Tcl_UniChar array result */
+	/*
+	 * Efficiently produce a pure Tcl_UniChar array result.
+	 */
+
 	if (!inPlace || Tcl_IsShared(objPtr)) {
 	    objResultPtr = Tcl_NewUnicodeObj(Tcl_GetUnicode(objPtr), length);
 	} else {
@@ -2885,7 +2955,10 @@ TclStringRepeat(
 	Tcl_AppendUnicodeToObj(objResultPtr, Tcl_GetUnicode(objResultPtr),
 		(count - done) * length);
     } else {
-	/* Efficiently concatenate string reps */
+	/*
+	 * Efficiently concatenate string reps.
+	 */
+
 	if (!inPlace || Tcl_IsShared(objPtr)) {
 	    objResultPtr = Tcl_NewStringObj(Tcl_GetString(objPtr), length);
 	} else {
@@ -2969,9 +3042,10 @@ TclStringCat(
 	    /* Value has a string rep. */
 	    if (objPtr->length) {
 		/*
-		 * Non-empty string rep. Not a pure bytearray, so we
-		 * won't create a pure bytearray
+		 * Non-empty string rep. Not a pure bytearray, so we won't
+		 * create a pure bytearray.
 		 */
+
 	 	binary = 0;
 		if ((objPtr->typePtr) && (objPtr->typePtr != &tclStringType)) {
 		    /* Prevent shimmer of non-string types. */
@@ -2992,15 +3066,25 @@ TclStringCat(
     } while (--oc && (binary || allowUniChar));
 
     if (binary) {
-	/* Result will be pure byte array. Pre-size it */
-	ov = objv; oc = objc;
+	/*
+	 * Result will be pure byte array. Pre-size it
+	 */
+
+	int numBytes;
+	ov = objv;
+	oc = objc;
 	do {
 	    Tcl_Obj *objPtr = *ov++;
 
-	    if (objPtr->bytes == NULL) {
-		int numBytes;
+	    /*
+	     * Every argument is either a bytearray with a ("pure")
+	     * value we know we can safely use, or it is an empty string.
+	     * We don't need to count bytes for the empty strings.
+	     */
 
+	    if (TclIsPureByteArray(objPtr)) {
 		Tcl_GetByteArrayFromObj(objPtr, &numBytes); /* PANIC? */
+
 		if (numBytes) {
 		    last = objc - oc;
 		    if (length == 0) {
@@ -3013,8 +3097,12 @@ TclStringCat(
 	    }
 	} while (--oc);
     } else if (allowUniChar && requestUniChar) {
-	/* Result will be pure Tcl_UniChar array. Pre-size it. */
-	ov = objv; oc = objc;
+	/*
+	 * Result will be pure Tcl_UniChar array. Pre-size it.
+	 */
+
+	ov = objv;
+	oc = objc;
 	do {
 	    Tcl_Obj *objPtr = *ov++;
 
@@ -3059,9 +3147,9 @@ TclStringCat(
 	    } while (--oc && (length == 0) && (pendingPtr == NULL));
 
 	    /*
- 	     * Either we found a possibly non-empty value, and we
- 	     * remember this index as the first and last such value so
- 	     * far seen, or (oc == 0) and all values are known empty,
+ 	     * Either we found a possibly non-empty value, and we remember
+ 	     * this index as the first and last such value so far seen,
+	     * or (oc == 0) and all values are known empty,
  	     * so first = last = objc - 1 signals the right quick return.
  	     */
 
@@ -3073,10 +3161,9 @@ TclStringCat(
 		/* assert ( pendingPtr != NULL ) */
 
 		/*
-		 * There's a pending value followed by more values.
-		 * Loop over remaining values generating strings until
-		 * a non-empty value is found, or the pending value gets
-		 * its string generated.
+		 * There's a pending value followed by more values.  Loop over
+		 * remaining values generating strings until a non-empty value
+		 * is found, or the pending value gets its string generated.
 		 */
 
 		do {
@@ -3132,10 +3219,10 @@ TclStringCat(
 	unsigned char *dst;
 
 	/*
-	 * Broken interface! Byte array value routines offer no way
-	 * to handle failure to allocate enough space. Following
-	 * stanza may panic.
+	 * Broken interface! Byte array value routines offer no way to handle
+	 * failure to allocate enough space. Following stanza may panic.
 	 */
+
 	if (inPlace && !Tcl_IsShared(*objv)) {
 	    int start;
 
@@ -3149,7 +3236,13 @@ TclStringCat(
 	while (objc--) {
 	    Tcl_Obj *objPtr = *objv++;
 
-	    if (objPtr->bytes == NULL) {
+	    /*
+	     * Every argument is either a bytearray with a ("pure")
+	     * value we know we can safely use, or it is an empty string.
+	     * We don't need to copy bytes from the empty strings.
+	     */
+
+	    if (TclIsPureByteArray(objPtr)) {
 		int more;
 		unsigned char *src = Tcl_GetByteArrayFromObj(objPtr, &more);
 		memcpy(dst, src, (size_t) more);
@@ -3250,6 +3343,7 @@ TclStringCat(
 	    if ((objPtr->bytes == NULL) || (objPtr->length)) {
 		int more;
 		char *src = Tcl_GetStringFromObj(objPtr, &more);
+
 		memcpy(dst, src, (size_t) more);
 		dst += more;
 	    }
@@ -3268,6 +3362,187 @@ TclStringCat(
     return NULL;
 }
 
+/*
+ *---------------------------------------------------------------------------
+ *
+ * TclStringCmp --
+ *	Compare two Tcl_Obj values as strings.
+ *
+ * Results:
+ *	Like memcmp, return -1, 0, or 1.
+ *
+ * Side effects:
+ *	String representations may be generated.  Internal representation may
+ *	be changed.
+ *
+ *---------------------------------------------------------------------------
+ */
+
+int TclStringCmp(
+    Tcl_Obj *value1Ptr,
+    Tcl_Obj *value2Ptr,
+    int checkEq,		/* comparison is only for equality */
+    int nocase,			/* comparison is not case sensitive */
+    int reqlength)		/* requested length */
+{
+    char *s1, *s2;
+    int empty, length, match, s1len, s2len;
+    memCmpFn_t memCmpFn;
+
+    if ((reqlength == 0) || (value1Ptr == value2Ptr)) {
+	/*
+	 * Always match at 0 chars of if it is the same obj.
+	 */
+	match = 0;
+    } else {
+
+	if (!nocase && TclIsPureByteArray(value1Ptr)
+		&& TclIsPureByteArray(value2Ptr)) {
+	    /*
+	     * Use binary versions of comparisons since that won't cause undue
+	     * type conversions and it is much faster. Only do this if we're
+	     * case-sensitive (which is all that really makes sense with byte
+	     * arrays anyway, and we have no memcasecmp() for some reason... :^)
+	     */
+
+	    s1 = (char *) Tcl_GetByteArrayFromObj(value1Ptr, &s1len);
+	    s2 = (char *) Tcl_GetByteArrayFromObj(value2Ptr, &s2len);
+	    memCmpFn = memcmp;
+	} else if ((value1Ptr->typePtr == &tclStringType)
+		&& (value2Ptr->typePtr == &tclStringType)) {
+	    /*
+	     * Do a unicode-specific comparison if both of the args are of
+	     * String type. If the char length == byte length, we can do a
+	     * memcmp. In benchmark testing this proved the most efficient
+	     * check between the unicode and string comparison operations.
+	     */
+
+	    if (nocase) {
+		s1 = (char *) Tcl_GetUnicodeFromObj(value1Ptr, &s1len);
+		s2 = (char *) Tcl_GetUnicodeFromObj(value2Ptr, &s2len);
+		memCmpFn = (memCmpFn_t)Tcl_UniCharNcasecmp;
+	    } else {
+		s1len = Tcl_GetCharLength(value1Ptr);
+		s2len = Tcl_GetCharLength(value2Ptr);
+		if ((s1len == value1Ptr->length)
+			&& (value1Ptr->bytes != NULL)
+			&& (s2len == value2Ptr->length)
+			&& (value2Ptr->bytes != NULL)) {
+		    s1 = value1Ptr->bytes;
+		    s2 = value2Ptr->bytes;
+		    memCmpFn = memcmp;
+		} else {
+		    s1 = (char *) Tcl_GetUnicode(value1Ptr);
+		    s2 = (char *) Tcl_GetUnicode(value2Ptr);
+		    if (
+#ifdef WORDS_BIGENDIAN
+			1
+#else
+			checkEq
+#endif
+			) {
+			memCmpFn = memcmp;
+			s1len *= sizeof(Tcl_UniChar);
+			s2len *= sizeof(Tcl_UniChar);
+		    } else {
+			memCmpFn = (memCmpFn_t) Tcl_UniCharNcmp;
+		    }
+		}
+	    }
+	} else {
+	    if ((empty = TclCheckEmptyString(value1Ptr)) > 0) {
+		switch (TclCheckEmptyString(value2Ptr)) {
+		case -1:
+		    s1 = 0;
+		    s1len = 0;
+		    s2 = TclGetStringFromObj(value2Ptr, &s2len);
+		    break;
+		case 0:
+		    match = -1;
+		    goto matchdone;
+		case 1:
+		default: /* avoid warn: `s2` may be used uninitialized */
+		    match = 0;
+		    goto matchdone;
+		}
+	    } else if (TclCheckEmptyString(value2Ptr) > 0) {
+		switch (empty) {
+		case -1:
+		    s2 = 0;
+		    s2len = 0;
+		    s1 = TclGetStringFromObj(value1Ptr, &s1len);
+		    break;
+		case 0:
+		    match = 1;
+		    goto matchdone;
+		case 1:
+		default: /* avoid warn: `s1` may be used uninitialized */
+		    match = 0;
+		    goto matchdone;
+		}
+	    } else {
+		s1 = TclGetStringFromObj(value1Ptr, &s1len);
+		s2 = TclGetStringFromObj(value2Ptr, &s2len);
+	    }
+	    if (!nocase && checkEq) {
+		/*
+		 * When we have equal-length we can check only for
+		 * (in)equality. We can use memcmp in all (n)eq cases because
+		 * we don't need to worry about lexical LE/BE variance.
+		 */
+
+		memCmpFn = memcmp;
+	    } else {
+		/*
+		 * As a catch-all we will work with UTF-8. We cannot use
+		 * memcmp() as that is unsafe with any string containing NUL
+		 * (\xC0\x80 in Tcl's utf rep). We can use the more efficient
+		 * TclpUtfNcmp2 if we are case-sensitive and no specific
+		 * length was requested.
+		 */
+
+		if ((reqlength < 0) && !nocase) {
+		    memCmpFn = (memCmpFn_t) TclpUtfNcmp2;
+		} else {
+		    s1len = Tcl_NumUtfChars(s1, s1len);
+		    s2len = Tcl_NumUtfChars(s2, s2len);
+		    memCmpFn = (memCmpFn_t)
+			    (nocase ? Tcl_UtfNcasecmp : Tcl_UtfNcmp);
+		}
+	    }
+	}
+
+	length = (s1len < s2len) ? s1len : s2len;
+	if (reqlength > 0 && reqlength < length) {
+	    length = reqlength;
+	} else if (reqlength < 0) {
+	    /*
+	     * The requested length is negative, so we ignore it by setting it
+	     * to length + 1 so we correct the match var.
+	     */
+
+	    reqlength = length + 1;
+	}
+
+	if (checkEq && (s1len != s2len)) {
+	    match = 1;		/* This will be reversed below. */
+	} else {
+	    /*
+	     * The comparison function should compare up to the minimum byte
+	     * length only.
+	     */
+
+	    match = memCmpFn(s1, s2, (size_t) length);
+	}
+	if ((match == 0) && (reqlength > length)) {
+	    match = s1len - s2len;
+	}
+	match = (match > 0) ? 1 : (match < 0) ? -1 : 0;
+    }
+  matchdone:
+    return match;
+}
+
 /*
  *---------------------------------------------------------------------------
  *
@@ -3298,7 +3573,7 @@ TclStringFirst(
 	start = 0;
     }
     if (ln == 0) {
-	/* We don't find empty substrings.  Bizarre! 
+	/* We don't find empty substrings.  Bizarre!
 	 * Whenever this routine is turned into a proper substring
 	 * finder, change to `return start` after limits imposed. */
 	return -1;
@@ -3462,18 +3737,20 @@ static void
 ReverseBytes(
     unsigned char *to,		/* Copy bytes into here... */
     unsigned char *from,	/* ...from here... */
-    int count)		/* Until this many are copied, */
+    int count)			/* Until this many are copied, */
 				/* reversing as you go. */
 {
     unsigned char *src = from + count;
+
     if (to == from) {
 	/* Reversing in place */
 	while (--src > to) {
 	    unsigned char c = *src;
+
 	    *src = *to;
 	    *to++ = c;
 	}
-    }  else {
+    } else {
 	while (--src >= from) {
 	    *to++ = *src;
 	}
@@ -3522,7 +3799,10 @@ TclStringReverse(
 		*to++ = *src;
 	    }
 	} else {
-	    /* Reversing in place */
+	    /*
+	     * Reversing in place.
+	     */
+
 	    while (--src > from) {
 		ch = *src;
 		*src = *from;
@@ -3546,20 +3826,22 @@ TclStringReverse(
 	    /*
 	     * Either numChars == -1 and we don't know how many chars are
 	     * represented by objPtr->bytes and we need Pass 1 just in case,
-	     * or numChars >= 0 and we know we have fewer chars than bytes,
-	     * so we know there's a multibyte character needing Pass 1.
+	     * or numChars >= 0 and we know we have fewer chars than bytes, so
+	     * we know there's a multibyte character needing Pass 1.
 	     *
 	     * Pass 1. Reverse the bytes of each multi-byte character.
 	     */
+
 	    int charCount = 0;
 	    int bytesLeft = numBytes;
 
 	    while (bytesLeft) {
 		/*
-		 * NOTE: We know that the from buffer is NUL-terminated.
-		 * It's part of the contract for objPtr->bytes values.
-		 * Thus, we can skip calling Tcl_UtfCharComplete() here.
+		 * NOTE: We know that the from buffer is NUL-terminated. It's
+		 * part of the contract for objPtr->bytes values. Thus, we can
+		 * skip calling Tcl_UtfCharComplete() here.
 		 */
+
 		int bytesInChar = TclUtfToUniChar(from, &ch);
 
 		ReverseBytes((unsigned char *)to, (unsigned char *)from,
@@ -3589,19 +3871,18 @@ TclStringReverse(
  *
  *	The result is a concatenation of a prefix from objPtr, characters
  *	0 through first-1, the insertPtr string value, and a suffix from
- *	objPtr, characters from first + count to the end. The effect is
- *	as if the inner substring of characters first through first+count-1
- *	are removed and replaced with insertPtr.
- *	If insertPtr is NULL, it is treated as an empty string.
- *	When passed the flag TCL_STRING_IN_PLACE, this routine will try
- *	to do the work within objPtr, so long as no sharing forbids it.
- *	Without that request, or as needed, a new Tcl value will be allocated
- *	to be the result.
+ *	objPtr, characters from first + count to the end. The effect is as if
+ *	the inner substring of characters first through first+count-1 are
+ *	removed and replaced with insertPtr. If insertPtr is NULL, it is
+ *	treated as an empty string. When passed the flag TCL_STRING_IN_PLACE,
+ *	this routine will try to do the work within objPtr, so long as no
+ *	sharing forbids it. Without that request, or as needed, a new Tcl
+ *	value will be allocated to be the result.
  *
  * Results:
- *	A Tcl value that is the result of the substring replacement.
- *	May return NULL in case of an error. When NULL is returned and
- *	interp is non-NULL, error information is left in interp
+ *	A Tcl value that is the result of the substring replacement. May
+ *	return NULL in case of an error. When NULL is returned and interp is
+ *	non-NULL, error information is left in interp
  *
  *---------------------------------------------------------------------------
  */
@@ -3689,7 +3970,7 @@ TclStringReplace(
 	    result = Tcl_NewByteArrayObj(NULL, numBytes - count + newBytes);
 								/* PANIC? */
 	    Tcl_SetByteArrayLength(result, 0);
-	    TclAppendBytesToByteArray(result, bytes, first);	
+	    TclAppendBytesToByteArray(result, bytes, first);
 	    TclAppendBytesToByteArray(result, iBytes, newBytes);
 	    TclAppendBytesToByteArray(result, bytes + first + count,
 		    numBytes - count - first);
@@ -3711,7 +3992,7 @@ TclStringReplace(
 	Tcl_UniChar *ustring = Tcl_GetUnicodeFromObj(objPtr, &numChars);
 
 	/* TODO: Is there an in-place option worth pursuing here? */
-	
+
 	result = Tcl_NewUnicodeObj(ustring, first);
 	if (insertPtr) {
 	    Tcl_AppendObjToObj(result, insertPtr);

generic/tclStubInit.c

@@ -34,12 +34,14 @@
 #undef Tcl_DbNewLongObj
 #undef Tcl_NewObj
 #undef Tcl_NewStringObj
+#undef Tcl_GetUnicode
 #undef Tcl_DumpActiveMemory
 #undef Tcl_ValidateAllMemory
 #undef Tcl_FindHashEntry
 #undef Tcl_CreateHashEntry
 #undef Tcl_Panic
 #undef Tcl_FindExecutable
+#undef Tcl_SetPanicProc
 #undef TclpGetPid
 #undef TclSockMinimumBuffers
 #undef Tcl_SetIntObj
@@ -401,6 +403,7 @@ static int uniCharNcasecmp(const Tcl_UniChar *ucs, const Tcl_UniChar *uct, unsig
 #   define TclpGmtime 0
 #   define TclpLocaltime_unix 0
 #   define TclpGmtime_unix 0
+#   define Tcl_GetUnicode 0
 #else /* TCL_NO_DEPRECATED */
 #   define Tcl_SeekOld seekOld
 #   define Tcl_TellOld tellOld
@@ -454,6 +457,15 @@ tellOld(
 MODULE_SCOPE const TclStubs tclStubs;
 MODULE_SCOPE const TclTomMathStubs tclTomMathStubs;
 
+#ifdef __GNUC__
+/*
+ * The rest of this file shouldn't warn about deprecated functions; they're
+ * there because we intend them to be so and know that this file is OK to
+ * touch those fields.
+ */
+#pragma GCC diagnostic ignored "-Wdeprecated-declarations"
+#endif
+
 /* !BEGIN!: Do not edit below this line. */
 
 static const TclIntStubs tclIntStubs = {
@@ -910,6 +922,7 @@ const TclTomMathStubs tclTomMathStubs = {
     TclBN_mp_get_long_long, /* 69 */
     TclBN_mp_set_long, /* 70 */
     TclBN_mp_get_long, /* 71 */
+    TclBN_mp_get_int, /* 72 */
 };
 
 static const TclStubHooks tclStubHooks = {

generic/tclTest.c

@@ -161,7 +161,7 @@ static TestChannel *firstDetached;
 
 static int		AsyncHandlerProc(ClientData clientData,
 			    Tcl_Interp *interp, int code);
-#ifdef TCL_THREADS
+#if TCL_THREADS
 static Tcl_ThreadCreateType AsyncThreadProc(ClientData);
 #endif
 static void		CleanupTestSetassocdataTests(
@@ -722,7 +722,7 @@ Tcltest_Init(
     if (Procbodytest_Init(interp) != TCL_OK) {
 	return TCL_ERROR;
     }
-#ifdef TCL_THREADS
+#if TCL_THREADS
     if (TclThread_Init(interp) != TCL_OK) {
 	return TCL_ERROR;
     }
@@ -902,7 +902,7 @@ TestasyncCmd(
 	Tcl_SetObjResult(interp, Tcl_NewStringObj(argv[3], -1));
 	Tcl_MutexUnlock(&asyncTestMutex);
 	return code;
-#ifdef TCL_THREADS
+#if TCL_THREADS
     } else if (strcmp(argv[1], "marklater") == 0) {
 	if (argc != 3) {
 	    goto wrongNumArgs;
@@ -999,7 +999,7 @@ AsyncHandlerProc(
  *----------------------------------------------------------------------
  */
 
-#ifdef TCL_THREADS
+#if TCL_THREADS
 static Tcl_ThreadCreateType
 AsyncThreadProc(
     ClientData clientData)	/* Parameter is the id of a

generic/tclThread.c

@@ -40,21 +40,6 @@ static void		ForgetSyncObject(void *objPtr, SyncObjRecord *recPtr);
 static void		RememberSyncObject(void *objPtr,
 			    SyncObjRecord *recPtr);
 
-/*
- * Several functions are #defined to nothing in tcl.h if TCL_THREADS is not
- * specified. Here we undo that so the functions are defined in the stubs
- * table.
- */
-
-#ifndef TCL_THREADS
-#undef Tcl_MutexLock
-#undef Tcl_MutexUnlock
-#undef Tcl_MutexFinalize
-#undef Tcl_ConditionNotify
-#undef Tcl_ConditionWait
-#undef Tcl_ConditionFinalize
-#endif
-
 /*
  *----------------------------------------------------------------------
  *
@@ -79,7 +64,7 @@ Tcl_GetThreadData(
     int size)			/* Size of storage block */
 {
     void *result;
-#ifdef TCL_THREADS
+#if TCL_THREADS
     /*
      * Initialize the key for this thread.
      */
@@ -126,7 +111,7 @@ TclThreadDataKeyGet(
     Tcl_ThreadDataKey *keyPtr)	/* Identifier for the data chunk. */
 
 {
-#ifdef TCL_THREADS
+#if TCL_THREADS
     return TclThreadStorageKeyGet(keyPtr);
 #else /* TCL_THREADS */
     return *keyPtr;
@@ -269,11 +254,12 @@ TclRememberMutex(
  *----------------------------------------------------------------------
  */
 
+#undef Tcl_MutexFinalize
 void
 Tcl_MutexFinalize(
     Tcl_Mutex *mutexPtr)
 {
-#ifdef TCL_THREADS
+#if TCL_THREADS
     TclpFinalizeMutex(mutexPtr);
 #endif
     TclpMasterLock();
@@ -322,11 +308,12 @@ TclRememberCondition(
  *----------------------------------------------------------------------
  */
 
+#undef Tcl_ConditionFinalize
 void
 Tcl_ConditionFinalize(
     Tcl_Condition *condPtr)
 {
-#ifdef TCL_THREADS
+#if TCL_THREADS
     TclpFinalizeCondition(condPtr);
 #endif
     TclpMasterLock();
@@ -356,7 +343,7 @@ void
 TclFinalizeThreadData(int quick)
 {
     TclFinalizeThreadDataThread();
-#if defined(TCL_THREADS) && defined(USE_THREAD_ALLOC)
+#if TCL_THREADS && defined(USE_THREAD_ALLOC)
     if (!quick) {
 	/*
 	 * Quick exit principle makes it useless to terminate allocators
@@ -389,7 +376,7 @@ TclFinalizeSynchronization(void)
     int i;
     void *blockPtr;
     Tcl_ThreadDataKey *keyPtr;
-#ifdef TCL_THREADS
+#if TCL_THREADS
     Tcl_Mutex *mutexPtr;
     Tcl_Condition *condPtr;
 
@@ -413,7 +400,7 @@ TclFinalizeSynchronization(void)
     keyRecord.max = 0;
     keyRecord.num = 0;
 
-#ifdef TCL_THREADS
+#if TCL_THREADS
     /*
      * Call thread storage master cleanup.
      */
@@ -473,12 +460,10 @@ Tcl_ExitThread(
     int status)
 {
     Tcl_FinalizeThread();
-#ifdef TCL_THREADS
     TclpThreadExit(status);
-#endif
 }
 
-#ifndef TCL_THREADS
+#if !TCL_THREADS
 
 /*
  *----------------------------------------------------------------------

generic/tclThreadAlloc.c

@@ -13,7 +13,7 @@
  */
 
 #include "tclInt.h"
-#if defined(TCL_THREADS) && defined(USE_THREAD_ALLOC)
+#if TCL_THREADS && defined(USE_THREAD_ALLOC)
 
 /*
  * If range checking is enabled, an additional byte will be allocated to store

generic/tclThreadStorage.c

@@ -13,7 +13,7 @@
 
 #include "tclInt.h"
 
-#ifdef TCL_THREADS
+#if TCL_THREADS
 #include <signal.h>
 
 /*

generic/tclThreadTest.c

@@ -18,7 +18,7 @@
 #endif
 #include "tclInt.h"
 
-#ifdef TCL_THREADS
+#if TCL_THREADS
 /*
  * Each thread has an single instance of the following structure. There is one
  * instance of this structure per thread even if that thread contains multiple
@@ -174,7 +174,6 @@ TclThread_Init(
     Tcl_CreateObjCommand(interp, "testthread", ThreadObjCmd, NULL, NULL);
     return TCL_OK;
 }
-
 
 /*
  *----------------------------------------------------------------------
@@ -1158,6 +1157,14 @@ ThreadExitProc(
 
     Tcl_MutexLock(&threadMutex);
 
+    if (self == errorThreadId) {
+	if (errorProcString) {	/* Extra safety */
+	    ckfree(errorProcString);
+	    errorProcString = NULL;
+	}
+	errorThreadId = 0;
+    }
+
     if (threadEvalScript) {
 	ckfree(threadEvalScript);
 	threadEvalScript = NULL;

generic/tclTomMath.decls

@@ -250,6 +250,9 @@ declare 70 {
 declare 71 {
     unsigned long TclBN_mp_get_long(const mp_int *a)
 }
+declare 72 {
+    unsigned long TclBN_mp_get_int(const mp_int *a)
+}
 
 # Local Variables:
 # mode: tcl

generic/tclTomMathDecls.h

@@ -98,7 +98,6 @@
 #define mp_radix_size TclBN_mp_radix_size
 #define mp_read_radix TclBN_mp_read_radix
 #define mp_rshd TclBN_mp_rshd
-#define mp_s_rmap TclBNMpSRmap
 #define mp_set TclBN_mp_set
 #define mp_set_int TclBN_mp_set_int
 #define mp_set_long TclBN_mp_set_long
@@ -324,6 +323,8 @@ EXTERN Tcl_WideUInt	TclBN_mp_get_long_long(const mp_int *a);
 EXTERN int		TclBN_mp_set_long(mp_int *a, unsigned long i);
 /* 71 */
 EXTERN unsigned long	TclBN_mp_get_long(const mp_int *a);
+/* 72 */
+EXTERN unsigned long	TclBN_mp_get_int(const mp_int *a);
 
 typedef struct TclTomMathStubs {
     int magic;
@@ -401,6 +402,7 @@ typedef struct TclTomMathStubs {
     Tcl_WideUInt (*tclBN_mp_get_long_long) (const mp_int *a); /* 69 */
     int (*tclBN_mp_set_long) (mp_int *a, unsigned long i); /* 70 */
     unsigned long (*tclBN_mp_get_long) (const mp_int *a); /* 71 */
+    unsigned long (*tclBN_mp_get_int) (const mp_int *a); /* 72 */
 } TclTomMathStubs;
 
 extern const TclTomMathStubs *tclTomMathStubsPtr;
@@ -559,6 +561,8 @@ extern const TclTomMathStubs *tclTomMathStubsPtr;
 	(tclTomMathStubsPtr->tclBN_mp_set_long) /* 70 */
 #define TclBN_mp_get_long \
 	(tclTomMathStubsPtr->tclBN_mp_get_long) /* 71 */
+#define TclBN_mp_get_int \
+	(tclTomMathStubsPtr->tclBN_mp_get_int) /* 72 */
 
 #endif /* defined(USE_TCL_STUBS) */
 

generic/tclUtf.c

@@ -173,6 +173,13 @@ Tcl_UniCharToUtf(
 	    buf[0] = (char) ((ch >> 18) | 0xF0);
 	    return 4;
 	}
+    } else if (ch == -1) {
+	if (((buf[0] & 0xF8) == 0xF0) && ((buf[1] & 0xC0) == 0x80)
+		&& ((buf[2] & 0xCF) == 0)) {
+	    ch = 0xD7C0 + ((buf[0] & 0x07) << 8) + ((buf[1] & 0x3F) << 2)
+		    + ((buf[2] & 0x30) >> 4);
+	    goto three;
+	}
     }
 
     ch = 0xFFFD;
@@ -211,7 +218,7 @@ Tcl_UniCharToUtfDString(
 {
     const Tcl_UniChar *w, *wEnd;
     char *p, *string;
-    int oldLength;
+    int oldLength, len = 1;
 
     /*
      * UTF-8 string length in bytes will be <= Unicode string length * 4.
@@ -224,9 +231,18 @@ Tcl_UniCharToUtfDString(
     p = string;
     wEnd = uniStr + uniLength;
     for (w = uniStr; w < wEnd; ) {
-	p += Tcl_UniCharToUtf(*w, p);
+	if (!len && ((*w & 0xFC00) != 0xDC00)) {
+	    /* Special case for handling upper surrogates. */
+	    p += Tcl_UniCharToUtf(-1, p);
+	}
+	len = Tcl_UniCharToUtf(*w, p);
+	p += len;
 	w++;
     }
+    if (!len) {
+	/* Special case for handling upper surrogates. */
+	p += Tcl_UniCharToUtf(-1, p);
+    }
     Tcl_DStringSetLength(dsPtr, oldLength + (p - string));
 
     return string;
@@ -892,7 +908,7 @@ Tcl_UtfToUpper(
 	 * char to dst if its size is <= the original char.
 	 */
 
-	if (bytes < TclUtfCount(upChar)) {
+	if ((bytes < TclUtfCount(upChar)) || ((upChar & 0xF800) == 0xD800)) {
 	    memcpy(dst, src, (size_t) bytes);
 	    dst += bytes;
 	} else {
@@ -955,7 +971,7 @@ Tcl_UtfToLower(
 	 * char to dst if its size is <= the original char.
 	 */
 
-	if (bytes < TclUtfCount(lowChar)) {
+	if ((bytes < TclUtfCount(lowChar)) || ((lowChar & 0xF800) == 0xD800)) {
 	    memcpy(dst, src, (size_t) bytes);
 	    dst += bytes;
 	} else {
@@ -1015,7 +1031,7 @@ Tcl_UtfToTitle(
 #endif
 	titleChar = Tcl_UniCharToTitle(titleChar);
 
-	if (bytes < TclUtfCount(titleChar)) {
+	if ((bytes < TclUtfCount(titleChar)) || ((titleChar & 0xF800) == 0xD800)) {
 	    memcpy(dst, src, (size_t) bytes);
 	    dst += bytes;
 	} else {
@@ -1034,12 +1050,12 @@ Tcl_UtfToTitle(
 	    lowChar = (((lowChar & 0x3ff) << 10) | (ch & 0x3ff)) + 0x10000;
 	}
 #endif
-	/* Special exception for Gregorian characters, which don't have titlecase */
-	if ((lowChar < 0x1C90) || (lowChar >= 0x1CC0)) {
+	/* Special exception for Georgian Asomtavruli chars, no titlecase. */
+	if ((unsigned)(lowChar - 0x1C90) >= 0x30) {
 	    lowChar = Tcl_UniCharToLower(lowChar);
 	}
 
-	if (bytes < TclUtfCount(lowChar)) {
+	if ((bytes < TclUtfCount(lowChar)) || ((lowChar & 0xF800) == 0xD800)) {
 	    memcpy(dst, src, (size_t) bytes);
 	    dst += bytes;
 	} else {

generic/tclUtil.c

@@ -120,7 +120,7 @@ static int		FindElement(Tcl_Interp *interp, const char *string,
 /*
  * The following is the Tcl object type definition for an object that
  * represents a list index in the form, "end-offset". It is used as a
- * performance optimization in TclGetIntForIndex. The internal rep is 
+ * performance optimization in TclGetIntForIndex. The internal rep is
  * stored directly in the wideValue, so no memory management is required
  * for it. This is a caching intrep, keeping the result of a parse
  * around. This type is only created from a pre-existing string, so an
@@ -1673,7 +1673,7 @@ UtfWellFormedEnd(
     if (Tcl_UtfCharComplete(p, l - p)) {
 	return bytes;
     }
-    /* 
+    /*
      * Malformed utf-8 end, be sure we've NTS to safe compare of end-character,
      * avoid segfault by access violation out of range.
      */
@@ -3793,7 +3793,7 @@ GetEndOffsetFromObj(
     return TCL_OK;
 }
 
-    
+
 /*
  *----------------------------------------------------------------------
  *
@@ -3976,12 +3976,12 @@ TclIndexEncode(
         /* usual case, the absolute index value encodes itself */
     } else if (TCL_OK == GetEndOffsetFromObj(objPtr, 0, &idx)) {
         /*
-         * We parsed an end+offset index value. 
+         * We parsed an end+offset index value.
          * idx holds the offset value in the range INT_MIN...INT_MAX.
          */
         if (idx > 0) {
             /*
-             * All end+postive or end-negative expressions 
+             * All end+postive or end-negative expressions
              * always indicate "after the end".
              */
             idx = after;

generic/tclVar.c

@@ -60,14 +60,12 @@ VarHashCreateVar(
     Tcl_Obj *key,
     int *newPtr)
 {
-    Tcl_HashEntry *hPtr = Tcl_CreateHashEntry(&tablePtr->table,
-	    key, newPtr);
+    Tcl_HashEntry *hPtr = Tcl_CreateHashEntry(&tablePtr->table, key, newPtr);
 
-    if (hPtr) {
-	return VarHashGetValue(hPtr);
-    } else {
+    if (!hPtr) {
 	return NULL;
     }
+    return VarHashGetValue(hPtr);
 }
 
 #define VarHashFindVar(tablePtr, key) \
@@ -92,11 +90,10 @@ VarHashFirstVar(
 {
     Tcl_HashEntry *hPtr = VarHashFirstEntry(tablePtr, searchPtr);
 
-    if (hPtr) {
-	return VarHashGetValue(hPtr);
-    } else {
+    if (!hPtr) {
 	return NULL;
     }
+    return VarHashGetValue(hPtr);
 }
 
 static inline Var *
@@ -105,11 +102,10 @@ VarHashNextVar(
 {
     Tcl_HashEntry *hPtr = VarHashNextEntry(searchPtr);
 
-    if (hPtr) {
-	return VarHashGetValue(hPtr);
-    } else {
+    if (!hPtr) {
 	return NULL;
     }
+    return VarHashGetValue(hPtr);
 }
 
 #define VarHashGetKey(varPtr) \
@@ -174,10 +170,14 @@ typedef struct ArraySearch {
 
 static void		AppendLocals(Tcl_Interp *interp, Tcl_Obj *listPtr,
 			    Tcl_Obj *patternPtr, int includeLinks);
-static void             ArrayPopulateSearch(Tcl_Interp *interp, Tcl_Obj *arrayNameObj, Var *varPtr, ArraySearch *searchPtr);
-static void             ArrayDoneSearch (Interp *iPtr, Var *varPtr, ArraySearch *searchPtr);
+static void		ArrayPopulateSearch(Tcl_Interp *interp,
+			    Tcl_Obj *arrayNameObj, Var *varPtr,
+			    ArraySearch *searchPtr);
+static void		ArrayDoneSearch(Interp *iPtr, Var *varPtr,
+			    ArraySearch *searchPtr);
 static Tcl_NRPostProc   ArrayForLoopCallback;
-static int              ArrayForNRCmd(ClientData dummy, Tcl_Interp *interp, int objc, Tcl_Obj *const *objv);
+static int		ArrayForNRCmd(ClientData dummy, Tcl_Interp *interp,
+			    int objc, Tcl_Obj *const *objv);
 static void		DeleteSearches(Interp *iPtr, Var *arrayVarPtr);
 static void		DeleteArray(Interp *iPtr, Tcl_Obj *arrayNamePtr,
 			    Var *varPtr, int flags, int index);
@@ -322,7 +322,8 @@ CleanupVar(
 {
     if (TclIsVarUndefined(varPtr) && TclIsVarInHash(varPtr)
 	    && !TclIsVarTraced(varPtr)
-	    && (VarHashRefCount(varPtr) == (unsigned)!TclIsVarDeadHash(varPtr))) {
+	    && (VarHashRefCount(varPtr) == (unsigned)
+		    !TclIsVarDeadHash(varPtr))) {
 	if (VarHashRefCount(varPtr) == 0) {
 	    ckfree(varPtr);
 	} else {
@@ -331,7 +332,8 @@ CleanupVar(
     }
     if (arrayPtr != NULL && TclIsVarUndefined(arrayPtr) &&
 	    TclIsVarInHash(arrayPtr) && !TclIsVarTraced(arrayPtr) &&
-	    (VarHashRefCount(arrayPtr) == (unsigned)!TclIsVarDeadHash(arrayPtr))) {
+	    (VarHashRefCount(arrayPtr) == (unsigned)
+		    !TclIsVarDeadHash(arrayPtr))) {
 	if (VarHashRefCount(arrayPtr) == 0) {
 	    ckfree(arrayPtr);
 	} else {
@@ -607,7 +609,6 @@ TclObjLookupVarEx(
     }
 
     if (!parsed) {
-
 	/*
 	 * part1Ptr is possibly an unparsed array element.
 	 */
@@ -615,12 +616,11 @@ TclObjLookupVarEx(
 	int len;
 	const char *part1 = TclGetStringFromObj(part1Ptr, &len);
 
-	if (len > 1 && (part1[len - 1] == ')')) {
+	if ((len > 1) && (part1[len - 1] == ')')) {
+	    const char *part2 = strchr(part1, '(');
 
-	  const char *part2 = strchr(part1, '(');
-
-	  if (part2) {
-	    Tcl_Obj *arrayPtr;
+	    if (part2) {
+		Tcl_Obj *arrayPtr;
 
 		if (part2Ptr != NULL) {
 		    if (flags & TCL_LEAVE_ERR_MSG) {
@@ -632,19 +632,20 @@ TclObjLookupVarEx(
 		    return NULL;
 		}
 
-	    arrayPtr = Tcl_NewStringObj(part1, (part2 - part1));
-	    part2Ptr = Tcl_NewStringObj(part2 + 1, len - (part2 - part1) - 2);
+		arrayPtr = Tcl_NewStringObj(part1, (part2 - part1));
+		part2Ptr = Tcl_NewStringObj(part2 + 1,
+			len - (part2 - part1) - 2);
 
-	    TclFreeIntRep(part1Ptr);
+		TclFreeIntRep(part1Ptr);
 
-	    Tcl_IncrRefCount(arrayPtr);
-	    part1Ptr->internalRep.twoPtrValue.ptr1 = arrayPtr;
-	    Tcl_IncrRefCount(part2Ptr);
-	    part1Ptr->internalRep.twoPtrValue.ptr2 = part2Ptr;
-	    part1Ptr->typePtr = &tclParsedVarNameType;
+		Tcl_IncrRefCount(arrayPtr);
+		part1Ptr->internalRep.twoPtrValue.ptr1 = arrayPtr;
+		Tcl_IncrRefCount(part2Ptr);
+		part1Ptr->internalRep.twoPtrValue.ptr2 = part2Ptr;
+		part1Ptr->typePtr = &tclParsedVarNameType;
 
-	    part1Ptr = arrayPtr;
-	  }
+		part1Ptr = arrayPtr;
+	    }
 	}
     }
 
@@ -674,6 +675,7 @@ TclObjLookupVarEx(
 	/*
 	 * An indexed local variable.
 	 */
+
 	Tcl_Obj *cachedNamePtr = localName(varFramePtr, index);
 
 	part1Ptr->typePtr = &localVarNameType;
@@ -682,7 +684,7 @@ TclObjLookupVarEx(
 	    Tcl_IncrRefCount(cachedNamePtr);
 	    if (cachedNamePtr->typePtr != &localVarNameType
 		    || cachedNamePtr->internalRep.twoPtrValue.ptr1 != NULL) {
-	        TclFreeIntRep(cachedNamePtr);
+		TclFreeIntRep(cachedNamePtr);
 	    }
 	} else {
 	    part1Ptr->internalRep.twoPtrValue.ptr1 = NULL;
@@ -877,38 +879,41 @@ TclLookupSimpleVar(
 	if (varPtr == NULL) {
 	    Tcl_Obj *tailPtr;
 
-	    if (create) {	/* Var wasn't found so create it. */
-		TclGetNamespaceForQualName(interp, varName, cxtNsPtr,
-			flags, &varNsPtr, &dummy1Ptr, &dummy2Ptr, &tail);
-		if (varNsPtr == NULL) {
-		    *errMsgPtr = badNamespace;
-		    return NULL;
-		} else if (tail == NULL) {
-		    *errMsgPtr = missingName;
-		    return NULL;
-		}
-		if (tail != varName) {
-		    tailPtr = Tcl_NewStringObj(tail, -1);
-		} else {
-		    tailPtr = varNamePtr;
-		}
-		varPtr = VarHashCreateVar(&varNsPtr->varTable, tailPtr,
-			&isNew);
-		if (lookGlobal) {
-		    /*
-		     * The variable was created starting from the global
-		     * namespace: a global reference is returned even if it
-		     * wasn't explicitly requested.
-		     */
-
-		    *indexPtr = -1;
-		} else {
-		    *indexPtr = -2;
-		}
-	    } else {		/* Var wasn't found and not to create it. */
+	    if (!create) {	/* Var wasn't found and not to create it. */
 		*errMsgPtr = noSuchVar;
 		return NULL;
 	    }
+
+	    /*
+	     * Var wasn't found so create it.
+	     */
+
+	    TclGetNamespaceForQualName(interp, varName, cxtNsPtr, flags,
+		    &varNsPtr, &dummy1Ptr, &dummy2Ptr, &tail);
+	    if (varNsPtr == NULL) {
+		*errMsgPtr = badNamespace;
+		return NULL;
+	    } else if (tail == NULL) {
+		*errMsgPtr = missingName;
+		return NULL;
+	    }
+	    if (tail != varName) {
+		tailPtr = Tcl_NewStringObj(tail, -1);
+	    } else {
+		tailPtr = varNamePtr;
+	    }
+	    varPtr = VarHashCreateVar(&varNsPtr->varTable, tailPtr, &isNew);
+	    if (lookGlobal) {
+		/*
+		 * The variable was created starting from the global
+		 * namespace: a global reference is returned even if it wasn't
+		 * explicitly requested.
+		 */
+
+		*indexPtr = -1;
+	    } else {
+		*indexPtr = -2;
+	    }
 	}
     } else {			/* Local var: look in frame varFramePtr. */
 	int localLen, localCt = varFramePtr->numCompiledLocals;
@@ -2167,7 +2172,6 @@ TclPtrIncrObjVarIdx(
     } else {
 	/* Unshared - can Incr in place */
 	if (TCL_OK == TclIncrObj(interp, varValuePtr, incrPtr)) {
-
 	    /*
 	     * This seems dumb to write the incremeted value into the var
 	     * after we just adjusted the value in place, but the spec for
@@ -2909,27 +2913,24 @@ Tcl_LappendObjCmd(
 /*
  *----------------------------------------------------------------------
  *
- * ArrayForObjCmd
- * ArrayForNRCmd
- * ArrayForLoopCallback
- * ArrayObjNext
+ * ArrayForObjCmd, ArrayForNRCmd, ArrayForLoopCallback, ArrayObjNext --
  *
- *  These functions implement the "array for" Tcl command.
- *    array for {k v} a {}
- *  The array for command iterates over the array, setting the
- *  the specified loop variables, and executing the body each iteration.
+ *	These functions implement the "array for" Tcl command.
+ *	    array for {k v} a {}
+ *	The array for command iterates over the array, setting the the
+ *	specified loop variables, and executing the body each iteration.
  *
- *  ArrayForObjCmd() is the standard wrapper around ArrayForNRCmd().
+ *	ArrayForObjCmd() is the standard wrapper around ArrayForNRCmd().
  *
- *  ArrayForNRCmd() sets up the ArraySearch structure, sets arrayNamePtr
- *  inside the structure and calls VarHashFirstEntry to start the hash
- *  iteration.
+ *	ArrayForNRCmd() sets up the ArraySearch structure, sets arrayNamePtr
+ *	inside the structure and calls VarHashFirstEntry to start the hash
+ *	iteration.
  *
- *  ArrayForNRCmd() does not execute the body or set the loop variables,
- *  it only initializes the iterator.
+ *	ArrayForNRCmd() does not execute the body or set the loop variables,
+ *	it only initializes the iterator.
  *
- *  ArrayForLoopCallback() iterates over the entire array, executing
- *  the body each time.
+ *	ArrayForLoopCallback() iterates over the entire array, executing the
+ *	body each time.
  *
  *----------------------------------------------------------------------
  */
@@ -2937,39 +2938,39 @@ Tcl_LappendObjCmd(
 static int
 ArrayObjNext(
     Tcl_Interp *interp,
-    Tcl_Obj *arrayNameObj,      /* array */
-    Var *varPtr,                /* array */
+    Tcl_Obj *arrayNameObj,	/* array */
+    Var *varPtr,		/* array */
     ArraySearch *searchPtr,
     Tcl_Obj **keyPtrPtr,	/* Pointer to a variable to have the key
 				 * written into, or NULL. */
-    Tcl_Obj **valuePtrPtr	/* Pointer to a variable to have the
+    Tcl_Obj **valuePtrPtr)	/* Pointer to a variable to have the
 				 * value written into, or NULL.*/
-    )
 {
     Tcl_Obj *keyObj;
     Tcl_Obj *valueObj = NULL;
-    int     gotValue;
-    int     donerc;
+    int gotValue;
+    int donerc;
 
     donerc = TCL_BREAK;
 
     if ((varPtr->flags & VAR_SEARCH_ACTIVE) != VAR_SEARCH_ACTIVE) {
-      donerc = TCL_ERROR;
-      return donerc;
+	donerc = TCL_ERROR;
+	return donerc;
     }
 
     gotValue = 0;
     while (1) {
 	Tcl_HashEntry *hPtr = searchPtr->nextEntry;
-        if (hPtr != NULL) {
-          searchPtr->nextEntry = NULL;
-        } else {
-          hPtr = Tcl_NextHashEntry(&searchPtr->search);
-          if (hPtr == NULL) {
-            gotValue = 0;
-            break;
-          }
-        }
+
+	if (hPtr != NULL) {
+	    searchPtr->nextEntry = NULL;
+	} else {
+	    hPtr = Tcl_NextHashEntry(&searchPtr->search);
+	    if (hPtr == NULL) {
+		gotValue = 0;
+		break;
+	    }
+	}
 	varPtr = VarHashGetValue(hPtr);
 	if (!TclIsVarUndefined(varPtr)) {
 	    gotValue = 1;
@@ -2977,7 +2978,7 @@ ArrayObjNext(
 	}
     }
 
-    if (! gotValue) {
+    if (!gotValue) {
 	return donerc;
     }
 
@@ -2985,14 +2986,14 @@ ArrayObjNext(
 
     keyObj = VarHashGetKey(varPtr);
     *keyPtrPtr = keyObj;
-    valueObj = Tcl_ObjGetVar2(interp, arrayNameObj,
-        keyObj, TCL_LEAVE_ERR_MSG);
+    valueObj = Tcl_ObjGetVar2(interp, arrayNameObj, keyObj,
+	    TCL_LEAVE_ERR_MSG);
     *valuePtrPtr = valueObj;
 
     return donerc;
 }
 
-int
+static int
 ArrayForObjCmd(
     ClientData dummy,		/* Not used. */
     Tcl_Interp *interp,		/* Current interpreter. */
@@ -3019,8 +3020,7 @@ ArrayForNRCmd(
      */
 
     if (objc != 4) {
-	Tcl_WrongNumArgs(interp, 1, objv,
-		"{key value} arrayName script");
+	Tcl_WrongNumArgs(interp, 1, objv, "{key value} arrayName script");
 	return TCL_ERROR;
     }
 
@@ -3054,7 +3054,7 @@ ArrayForNRCmd(
      */
 
     searchPtr = ckalloc(sizeof(ArraySearch));
-    ArrayPopulateSearch (interp, arrayNameObj, varPtr, searchPtr);
+    ArrayPopulateSearch(interp, arrayNameObj, varPtr, searchPtr);
 
     /*
      * Make sure that these objects (which we need throughout the body of the
@@ -3120,35 +3120,37 @@ ArrayForLoopCallback(
     varPtr = TclObjLookupVarEx(interp, arrayNameObj, NULL, /*flags*/ 0,
 	    /*msg*/ 0, /*createPart1*/ 0, /*createPart2*/ 0, &arrayPtr);
     if (varPtr == NULL) {
-      done = TCL_ERROR;
+	done = TCL_ERROR;
     } else {
-      done = ArrayObjNext (interp, arrayNameObj, varPtr,
-          searchPtr, &keyObj, &valueObj);
+	done = ArrayObjNext(interp, arrayNameObj, varPtr, searchPtr, &keyObj,
+		&valueObj);
     }
 
     result = TCL_OK;
     if (done != TCL_CONTINUE) {
 	Tcl_ResetResult(interp);
-        if (done == TCL_ERROR) {
-	  Tcl_SetObjResult(interp, Tcl_NewStringObj(
-	      "array changed during iteration", -1));
-	  Tcl_SetErrorCode(interp, "TCL", "READ", "array", "for", NULL);
-	  varPtr->flags |= TCL_LEAVE_ERR_MSG;
-          result = done;
-        }
+	if (done == TCL_ERROR) {
+	    Tcl_SetObjResult(interp, Tcl_NewStringObj(
+		    "array changed during iteration", -1));
+	    Tcl_SetErrorCode(interp, "TCL", "READ", "array", "for", NULL);
+	    varPtr->flags |= TCL_LEAVE_ERR_MSG;
+	    result = done;
+	}
 	goto arrayfordone;
     }
 
     Tcl_ListObjGetElements(NULL, varListObj, &varc, &varv);
-    if (Tcl_ObjSetVar2(interp, varv[0], NULL, keyObj, TCL_LEAVE_ERR_MSG) == NULL) {
-      result = TCL_ERROR;
-      goto arrayfordone;
+    if (Tcl_ObjSetVar2(interp, varv[0], NULL, keyObj,
+	    TCL_LEAVE_ERR_MSG) == NULL) {
+	result = TCL_ERROR;
+	goto arrayfordone;
     }
     if (valueObj != NULL) {
-      if (Tcl_ObjSetVar2(interp, varv[1], NULL, valueObj, TCL_LEAVE_ERR_MSG) == NULL) {
-        result = TCL_ERROR;
-        goto arrayfordone;
-      }
+	if (Tcl_ObjSetVar2(interp, varv[1], NULL, valueObj,
+		TCL_LEAVE_ERR_MSG) == NULL) {
+	    result = TCL_ERROR;
+	    goto arrayfordone;
+	}
     }
 
     /*
@@ -3164,13 +3166,15 @@ ArrayForLoopCallback(
      */
 
   arrayfordone:
-    /* if the search was terminated by an array change, the
-     * VAR_SEARCH_ACTIVE flag will no longer be set
-     */
     if (done != TCL_ERROR) {
-      ArrayDoneSearch (iPtr, varPtr, searchPtr);
+	/*
+	 * If the search was terminated by an array change, the
+	 * VAR_SEARCH_ACTIVE flag will no longer be set.
+	 */
+
+	ArrayDoneSearch(iPtr, varPtr, searchPtr);
 	Tcl_DecrRefCount(searchPtr->name);
-      ckfree(searchPtr);
+	ckfree(searchPtr);
     }
 
     TclDecrRefCount(varListObj);
@@ -3181,14 +3185,15 @@ ArrayForLoopCallback(
 /*
  * ArrayPopulateSearch
  */
+
 static void
 ArrayPopulateSearch(
-    Tcl_Interp  *interp,
-    Tcl_Obj     *arrayNameObj,
-    Var         *varPtr,
+    Tcl_Interp *interp,
+    Tcl_Obj *arrayNameObj,
+    Var *varPtr,
     ArraySearch *searchPtr)
 {
-    Interp *iPtr = (Interp *)interp;
+    Interp *iPtr = (Interp *) interp;
     Tcl_HashEntry *hPtr;
     int isNew;
 
@@ -3206,7 +3211,7 @@ ArrayPopulateSearch(
 	    &searchPtr->search);
     Tcl_SetHashValue(hPtr, searchPtr);
     searchPtr->name = Tcl_ObjPrintf("s-%d-%s", searchPtr->id,
-        TclGetString(arrayNameObj));
+	    TclGetString(arrayNameObj));
     Tcl_IncrRefCount(searchPtr->name);
 }
 /*
@@ -3258,7 +3263,7 @@ ArrayStartSearchCmd(
      */
 
     searchPtr = ckalloc(sizeof(ArraySearch));
-    ArrayPopulateSearch (interp, objv[1], varPtr, searchPtr);
+    ArrayPopulateSearch(interp, objv[1], varPtr, searchPtr);
     Tcl_SetObjResult(interp, searchPtr->name);
     return TCL_OK;
 }
@@ -3268,12 +3273,12 @@ ArrayStartSearchCmd(
  *
  * ArrayDoneSearch --
  *
- *      Removes the search from the hash of active searches.
+ *	Removes the search from the hash of active searches.
  *
  *----------------------------------------------------------------------
  */
 static void
-ArrayDoneSearch (
+ArrayDoneSearch(
     Interp *iPtr,
     Var *varPtr,
     ArraySearch *searchPtr)
@@ -3288,7 +3293,7 @@ ArrayDoneSearch (
 
     hPtr = Tcl_FindHashEntry(&iPtr->varSearches, varPtr);
     if (hPtr == NULL) {
-      return;
+	return;
     }
     if (searchPtr == Tcl_GetHashValue(hPtr)) {
 	if (searchPtr->nextPtr) {
@@ -3522,7 +3527,7 @@ ArrayDoneSearchCmd(
 	return TCL_ERROR;
     }
 
-    ArrayDoneSearch (iPtr, varPtr, searchPtr);
+    ArrayDoneSearch(iPtr, varPtr, searchPtr);
     Tcl_DecrRefCount(searchPtr->name);
     ckfree(searchPtr);
     return TCL_OK;
@@ -4034,7 +4039,8 @@ ArraySetCmd(
 
 	    if ((elemVarPtr == NULL) ||
 		    (TclPtrSetVarIdx(interp, elemVarPtr, varPtr, arrayNameObj,
-		    elemPtrs[i],elemPtrs[i+1],TCL_LEAVE_ERR_MSG,-1) == NULL)){
+			    elemPtrs[i], elemPtrs[i+1], TCL_LEAVE_ERR_MSG,
+			    -1) == NULL)) {
 		result = TCL_ERROR;
 		break;
 	    }
@@ -6024,7 +6030,7 @@ TclInfoVarsCmd(
 	     */
 
 	    if ((nsPtr != globalNsPtr) && !specificNsInPattern) {
-		varPtr = VarHashFirstVar(&globalNsPtr->varTable,&search);
+		varPtr = VarHashFirstVar(&globalNsPtr->varTable, &search);
 		while (varPtr) {
 		    if (!TclIsVarUndefined(varPtr)
 			    || TclIsVarNamespaceVar(varPtr)) {
@@ -6317,25 +6323,50 @@ AppendLocals(
     }
 
     if (iPtr->varFramePtr->isProcCallFrame & FRAME_IS_METHOD) {
-	CallContext *contextPtr = iPtr->varFramePtr->clientData;
-	Method *mPtr = contextPtr->callPtr->chain[contextPtr->index].mPtr;
+	Method *mPtr = (Method *)
+		Tcl_ObjectContextMethod(iPtr->varFramePtr->clientData);
+	PrivateVariableMapping *privatePtr;
 
 	if (mPtr->declaringObjectPtr) {
-	    FOREACH(objNamePtr, mPtr->declaringObjectPtr->variables) {
+	    Object *oPtr = mPtr->declaringObjectPtr;
+
+	    FOREACH(objNamePtr, oPtr->variables) {
 		Tcl_CreateHashEntry(&addedTable, objNamePtr, &added);
 		if (added && (!pattern ||
 			Tcl_StringMatch(TclGetString(objNamePtr), pattern))) {
 		    Tcl_ListObjAppendElement(interp, listPtr, objNamePtr);
 		}
 	    }
+	    FOREACH_STRUCT(privatePtr, oPtr->privateVariables) {
+		Tcl_CreateHashEntry(&addedTable, privatePtr->variableObj,
+			&added);
+		if (added && (!pattern ||
+			Tcl_StringMatch(TclGetString(privatePtr->variableObj),
+				pattern))) {
+		    Tcl_ListObjAppendElement(interp, listPtr,
+			    privatePtr->variableObj);
+		}
+	    }
 	} else {
-	    FOREACH(objNamePtr, mPtr->declaringClassPtr->variables) {
+	    Class *clsPtr = mPtr->declaringClassPtr;
+
+	    FOREACH(objNamePtr, clsPtr->variables) {
 		Tcl_CreateHashEntry(&addedTable, objNamePtr, &added);
 		if (added && (!pattern ||
 			Tcl_StringMatch(TclGetString(objNamePtr), pattern))) {
 		    Tcl_ListObjAppendElement(interp, listPtr, objNamePtr);
 		}
 	    }
+	    FOREACH_STRUCT(privatePtr, clsPtr->privateVariables) {
+		Tcl_CreateHashEntry(&addedTable, privatePtr->variableObj,
+			&added);
+		if (added && (!pattern ||
+			Tcl_StringMatch(TclGetString(privatePtr->variableObj),
+				pattern))) {
+		    Tcl_ListObjAppendElement(interp, listPtr,
+			    privatePtr->variableObj);
+		}
+	    }
 	}
     }
     Tcl_DeleteHashTable(&addedTable);
@@ -6408,9 +6439,9 @@ CompareVarKeys(
     /*
      * If the object pointers are the same then they match.
      * OPT: this comparison was moved to the caller
-
-       if (objPtr1 == objPtr2) return 1;
-    */
+     *
+     * if (objPtr1 == objPtr2) return 1;
+     */
 
     /*
      * Don't use Tcl_GetStringFromObj as it would prevent l1 and l2 being in a

library/msgcat/msgcat.tcl

@@ -49,7 +49,7 @@ namespace eval msgcat {
 namespace eval msgcat::mcutil {
     namespace export getsystemlocale getpreferences
     namespace ensemble create -prefix 0
-    
+
     # Map of language codes used in Windows registry to those of ISO-639
     if {[info sharedlibextension] eq ".dll"} {
 	variable WinRegToISO639 [dict create  {*}{
@@ -292,7 +292,7 @@ proc msgcat::mcexists {args} {
 	}
     }
     set src [lindex $args 0]
-    
+
     if {![info exists ns]} { set ns [PackageNamespaceGet] }
 
     set loclist [PackagePreferences $ns]
@@ -537,7 +537,7 @@ proc msgcat::mcpackagelocale {subcommand args} {
 	set - preferences {
 	    # set a package locale or add a package locale
 	    set fSet [expr {$subcommand eq "set"}]
-	    
+
 	    # Check parameter
 	    if {$fSet && 1 < [llength $args] } {
 		return -code error "wrong # args: should be\
@@ -1241,7 +1241,7 @@ proc ::msgcat::PackageNamespaceGet {} {
 	}
     }
 }
-  
+
 # Initialize the default locale
 proc msgcat::mcutil::getsystemlocale {} {
     global env

macosx/GNUmakefile

@@ -132,7 +132,7 @@ ${objdir}/Makefile: ${UNIX_DIR}/Makefile.in ${UNIX_DIR}/configure \
 	mkdir -p "${OBJ_DIR}" && cd "${OBJ_DIR}" && \
 	if [ ${UNIX_DIR}/configure -nt config.status ]; then ${UNIX_DIR}/configure -C \
 	--prefix="${PREFIX}" --bindir="${BINDIR}" --libdir="${LIBDIR}" \
-	--mandir="${MANDIR}" --enable-threads --enable-framework --enable-dtrace \
+	--mandir="${MANDIR}" --enable-framework --enable-dtrace \
 	${CONFIGURE_ARGS} ${EXTRA_CONFIGURE_ARGS}; else ./config.status; fi
 
 build-${PROJECT}: ${objdir}/Makefile

macosx/Tcl-Common.xcconfig

@@ -30,7 +30,7 @@ MANDIR = $(PREFIX)/man
 PER_ARCH_CFLAGS_ppc = -mcpu=G3 -mtune=G4 $(PER_ARCH_CFLAGS_ppc)
 PER_ARCH_CFLAGS_ppc64 = -mcpu=G5 -mpowerpc64 $(PER_ARCH_CFLAGS_ppc64)
 PREFIX = /usr/local
-TCL_CONFIGURE_ARGS = --enable-threads --enable-dtrace
+TCL_CONFIGURE_ARGS = --enable-dtrace
 TCL_LIBRARY = $(LIBDIR)/tcl$(VERSION)
 TCL_PACKAGE_PATH = "$(LIBDIR)"
 TCL_DEFS = HAVE_TCL_CONFIG_H

tests/all.tcl

@@ -13,10 +13,14 @@
 package prefer latest
 package require Tcl 8.5-
 package require tcltest 2.2
-namespace import tcltest::*
-configure {*}$argv -testdir [file dir [info script]]
+namespace import ::tcltest::*
+
+configure {*}$argv -testdir [file dirname [file dirname [file normalize [
+    info script]/...]]]
+
 if {[singleProcess]} {
     interp debug {} -frame 1
 }
+
 runAllTests
 proc exit args {}

tests/async.test

@@ -20,7 +20,6 @@ if {[lsearch [namespace children] ::tcltest] == -1} {
 catch [list package require -exact Tcltest [info patchlevel]]
 
 testConstraint testasync [llength [info commands testasync]]
-testConstraint threaded [::tcl::pkgconfig get threaded]
 
 proc async1 {result code} {
     global aresult acode
@@ -149,7 +148,7 @@ test async-3.1 {deleting handlers} testasync {
 } {3 del2 {0 0 0 del1 del2}}
 
 test async-4.1 {async interrupting bytecode sequence} -constraints {
-    testasync threaded
+    testasync
 } -setup {
     set hm [testasync create async3]
     proc nothing {} {
@@ -157,21 +156,28 @@ test async-4.1 {async interrupting bytecode sequence} -constraints {
     }
 } -body {
     apply {{handle} {
-	global aresult
-	set aresult {Async event not delivered}
-	testasync marklater $handle
-	for {set i 0} {
-	    $i < 2500000  &&  $aresult eq "Async event not delivered"
-	} {incr i} {
-	    nothing
-	}
+    global aresult
+    set aresult {Async event not delivered}
+    testasync marklater $handle
+    # allow plenty of time to pass in case valgrind is running
+    set start [clock seconds]
+    while {
+	[clock seconds] - $start < 180 && $aresult eq "Async event not delivered"
+    } {
+	# be less busy
+	after 100
+	nothing
+    }
 	return $aresult
     }} $hm
 } -result {test pattern} -cleanup {
+    # give other threads some time to go way so that valgrind doesn't pick up
+    # "still reachable" cases from early thread termination
+    after 100
     testasync delete $hm
 }
 test async-4.2 {async interrupting straight bytecode sequence} -constraints {
-    testasync threaded
+    testasync
 } -setup {
     set hm [testasync create async3]
 } -body {
@@ -179,16 +185,24 @@ test async-4.2 {async interrupting straight bytecode sequence} -constraints {
 	global aresult
 	set aresult {Async event not delivered}
 	testasync marklater $handle
-	for {set i 0} {
-	    $i < 2500000  &&  $aresult eq "Async event not delivered"
-	} {incr i} {}
+	# allow plenty of time to pass in case valgrind is running
+	set start [clock seconds]
+	while {
+		[clock seconds] - $start < 180 && $aresult eq "Async event not delivered"
+	} {
+		# be less busy
+	    after 100
+	}
 	return $aresult
     }} $hm
 } -result {test pattern} -cleanup {
+    # give other threads some time to go way so that valgrind doesn't pick up
+    # "still reachable" cases from early thread termination
+    after 100
     testasync delete $hm
 }
 test async-4.3 {async interrupting loop-less bytecode sequence} -constraints {
-    testasync threaded
+    testasync
 } -setup {
     set hm [testasync create async3]
 } -body {
@@ -201,6 +215,9 @@ test async-4.3 {async interrupting loop-less bytecode sequence} -constraints {
 	return $aresult
     }]] $hm
 } -result {test pattern} -cleanup {
+    # give other threads some time to go way so that valgrind doesn't pick up
+    # "still reachable" cases from early thread termination
+    after 100
     testasync delete $hm
 }
 

tests/chanio.test

@@ -13,16 +13,11 @@
 # See the file "license.terms" for information on usage and redistribution of
 # this file, and for a DISCLAIMER OF ALL WARRANTIES.
 
+# TODO: This test is likely worthless. Confirm and remove
 if {[lsearch [namespace children] ::tcltest] == -1} {
     package require tcltest 2
-    namespace import -force ::tcltest::*
 }
 
-::tcltest::loadTestedCommands
-catch [list package require -exact Tcltest [info patchlevel]]
-
-testConstraint testbytestring [llength [info commands testbytestring]]
-
 namespace eval ::tcl::test::io {
     namespace import ::tcltest::*
 
@@ -35,18 +30,16 @@ namespace eval ::tcl::test::io {
     variable msg
     variable expected
 
-    ::tcltest::loadTestedCommands
+    loadTestedCommands
     catch [list package require -exact Tcltest [info patchlevel]]
+    package require tcltests
 
+    testConstraint testbytestring   [llength [info commands testbytestring]]
     testConstraint testchannel      [llength [info commands testchannel]]
-    testConstraint exec             [llength [info commands exec]]
     testConstraint openpipe         1
-    testConstraint fileevent        [llength [info commands fileevent]]
-    testConstraint fcopy            [llength [info commands fcopy]]
     testConstraint testfevent       [llength [info commands testfevent]]
     testConstraint testchannelevent [llength [info commands testchannelevent]]
     testConstraint testmainthread   [llength [info commands testmainthread]]
-    testConstraint thread [expr {0 == [catch {package require Thread 2.7-}]}]
 
     # You need a *very* special environment to do some tests.  In particular,
     # many file systems do not support large-files...
@@ -5964,7 +5957,7 @@ test chan-io-48.3 {testing readability conditions} -setup {
     chan close $f
 } -result {done {0 1 0 1 0 1 0 1 0 1 0 1 0 0}}
 unset path(bar)
-removeFile bar 
+removeFile bar
 
 test chan-io-48.4 {lf write, testing readability, ^Z termination, auto read mode} -setup {
     file delete $path(test1)

tests/cmdAH.test

@@ -1040,7 +1040,7 @@ test cmdAH-20.7.1 {
     Tcl_FileObjCmd: atime (built-in Windows names with dir path and extension)
 } -constraints {win} -body {
     file atime [file join [temporaryDirectory] CON.txt]
-} -result "could not get access time for file \"[file join [temporaryDirectory] CON.txt]\"" -returnCodes error
+} -match regexp -result {could not (?:get access time|read)} -returnCodes error
 
 if {[testConstraint unix] && [file exists /tmp]} {
     removeFile touch.me /tmp
@@ -1281,7 +1281,7 @@ test cmdAH-24.14.1 {
     Tcl_FileObjCmd: mtime (built-in Windows names with dir path and extension)
 } -constraints {win} -body {
     file mtime [file join [temporaryDirectory] CON.txt]
-} -result "could not get modification time for file \"[file join [temporaryDirectory] CON.txt]\"" -returnCodes error
+} -match regexp -result {could not (?:get modification time|read)} -returnCodes error
 
 # owned
 test cmdAH-25.1 {Tcl_FileObjCmd: owned} -returnCodes error -body {
@@ -1345,7 +1345,12 @@ test cmdAH-27.4 {
 test cmdAH-27.4.1 {
     Tcl_FileObjCmd: size (built-in Windows names with dir path and extension)
 } -constraints {win} -body {
-    file size [file join [temporaryDirectory] con.txt]
+    try {
+	set res [file size [file join [temporaryDirectory] con.txt]]
+    } trap {POSIX ENOENT} {} {
+	set res 0
+    }
+    set res
 } -result 0
 
 catch {testsetplatform $platform}
@@ -1447,8 +1452,13 @@ test cmdAH-28.13 {Tcl_FileObjCmd: stat (built-in Windows names)} -constraints {w
 test cmdAH-28.13.1 {Tcl_FileObjCmd: stat (built-in Windows names)} -constraints {win} -setup {
     unset -nocomplain stat
 } -body {
-    file stat [file join [temporaryDirectory] CON.txt] stat
-    lmap elem {atime ctime dev gid ino mode mtime nlink size type uid} {set stat($elem)}
+    try {
+	file stat [file join [temporaryDirectory] CON.txt] stat
+	set res [lmap elem {atime ctime dev gid ino mode mtime nlink size type uid} {set stat($elem)}]
+    } trap {POSIX ENOENT} {} {
+	set res {0 0 -1 0 0 8630 0 0 0 characterSpecial 0}
+    }
+    set res
 } -result {0 0 -1 0 0 8630 0 0 0 characterSpecial 0}
 unset -nocomplain stat
 
@@ -1498,7 +1508,12 @@ test cmdAH-29.6 {
 test cmdAH-29.6.1 {
     Tcl_FileObjCmd: type (built-in Windows names, with dir path and extension)
 } -constraints {win} -body {
-    file type [file join [temporaryDirectory] CON.txt]
+    try {
+	set res [file type [file join [temporaryDirectory] CON.txt]]
+    } trap {POSIX ENOENT} {} {
+	set res {characterSpecial}
+    }
+    set res
 } -result "characterSpecial"
 
 # Error conditions

tests/env.test

@@ -16,49 +16,96 @@ if {[lsearch [namespace children] ::tcltest] == -1} {
     namespace import -force ::tcltest::*
 }
 
-# Some tests require the "exec" command.
-# Skip them if exec is not defined.
-testConstraint exec [llength [info commands exec]]
-
-#
-# These tests will run on any platform (and indeed crashed on the Mac). So put
-# them before you test for the existance of exec.
-#
-test env-1.1 {propagation of env values to child interpreters} -setup {
-    catch {interp delete child}
-    catch {unset env(test)}
-} -body {
-    interp create child
-    set env(test) garbage
-    child eval {set env(test)}
-} -cleanup {
-    interp delete child
-    unset env(test)
-} -result {garbage}
-#
-# This one crashed on Solaris under Tcl8.0, so we only want to make sure it
-# runs.
-#
-test env-1.2 {lappend to env value} -setup {
-    catch {unset env(test)}
-} -body {
-    set env(test) aaaaaaaaaaaaaaaa
-    append env(test) bbbbbbbbbbbbbb
-    unset env(test)
-}
-test env-1.3 {reflection of env by "array names"} -setup {
-    catch {interp delete child}
-    catch {unset env(test)}
-} -body {
-    interp create child
-    child eval {set env(test) garbage}
-    expr {"test" in [array names env]}
-} -cleanup {
-    interp delete child
-    catch {unset env(test)}
-} -result {1}
+package require tcltests
 
-set printenvScript [makeFile {
+# [exec] is required here to see the actual environment received by child
+# processes.
+proc getenv {} {
+    global printenvScript
+    catch {exec [interpreter] $printenvScript} out
+    if {$out eq "child process exited abnormally"} {
+	set out {}
+    }
+    return $out
+}
+
+
+proc envrestore {} {
+    # Restore the environment variables at the end of the test.
+    global env
+    variable env2
+
+    foreach name [array names env] {
+	unset env($name)
+    }
+    array set env $env2
+    return
+}
+
+
+proc envprep {} {
+    # Save the current environment variables at the start of the test.
+    global env
+    variable keep
+    variable env2
+
+    set env2 [array get env]
+    foreach name [array names env] {
+	# Keep some environment variables that support operation of the tcltest
+	# package.
+	if {[string toupper $name] ni [string toupper $keep]} {
+	    unset env($name)
+	}
+    }
+    return
+}
+
+
+proc encodingrestore {} {
+    variable sysenc
+    encoding system $sysenc
+    return
+}
+
+
+proc encodingswitch encoding {
+    variable sysenc
+    # Need to run [getenv] in known encoding, so save the current one here...
+    set sysenc [encoding system]
+    encoding system $encoding
+    return
+}
+
+
+proc setup1 {} {
+    global env
+    envprep
+    encodingswitch iso8859-1
+}
+
+proc setup2 {} {
+    global env
+    setup1
+    set env(NAME1) {test string}
+    set env(NAME2) {new value}
+    set env(XYZZY) {garbage}
+}
+
+
+proc cleanup1 {} {
+    encodingrestore
+    envrestore
+}
+
+variable keep {
+    TCL_LIBRARY PATH LD_LIBRARY_PATH LIBPATH PURE_PROG_NAME DISPLAY
+    SHLIB_PATH SYSTEMDRIVE SYSTEMROOT DYLD_LIBRARY_PATH DYLD_FRAMEWORK_PATH
+    DYLD_NEW_LOCAL_SHARED_REGIONS DYLD_NO_FIX_PREBINDING
+    __CF_USER_TEXT_ENCODING SECURITYSESSIONID LANG WINDIR TERM
+    CommonProgramFiles ProgramFiles CommonProgramW6432 ProgramW6432
+}
+
+variable printenvScript [makeFile [string map [list @keep@ [list $keep]] {
     encoding system iso8859-1
     proc lrem {listname name} {
 	upvar $listname list
@@ -70,7 +117,7 @@ set printenvScript [makeFile {
     }
     proc mangle s {
 	regsub -all {\[|\\|\]} $s {\\&} s
-	regsub -all "\[\u0000-\u001f\u007f-\uffff\]" $s {[manglechar &]} s
+	regsub -all "\[\u0000-\u001f\u007f-\uffff\]" $s {[manglechar {&}]} s
 	return [subst -novariables $s]
     }
     proc manglechar c {
@@ -84,161 +131,154 @@ set printenvScript [makeFile {
 	lrem names ComSpec
 	lrem names ""
     }
-    foreach name {
-	TCL_LIBRARY PATH LD_LIBRARY_PATH LIBPATH PURE_PROG_NAME DISPLAY
-	SHLIB_PATH SYSTEMDRIVE SYSTEMROOT DYLD_LIBRARY_PATH DYLD_FRAMEWORK_PATH
-	DYLD_NEW_LOCAL_SHARED_REGIONS DYLD_NO_FIX_PREBINDING
-	__CF_USER_TEXT_ENCODING SECURITYSESSIONID LANG WINDIR TERM
-	CommonProgramFiles ProgramFiles CommonProgramW6432 ProgramW6432
-    } {
+    foreach name @keep@ {
 	lrem names $name
     }
     foreach p $names {
-	puts "[mangle $p]=[mangle $env($p)]"
+	puts [mangle $p]=[mangle $env($p)]
     }
     exit
-} printenv]
+}] printenv]
 
-# [exec] is required here to see the actual environment received by child
-# processes.
-proc getenv {} {
-    global printenvScript tcltest
-    catch {exec [interpreter] $printenvScript} out
-    if {$out eq "child process exited abnormally"} {
-	set out {}
-    }
-    return $out
+
+test env-1.1 {propagation of env values to child interpreters} -setup {
+    catch {interp delete child}
+    catch {unset env(test)}
+} -body {
+    interp create child
+    set env(test) garbage
+    child eval {set env(test)}
+} -cleanup {
+    interp delete child
+    unset env(test)
+} -result {garbage}
+
+
+# This one crashed on Solaris under Tcl8.0, so we only want to make sure it
+# runs.
+test env-1.2 {lappend to env value} -setup {
+    catch {unset env(test)}
+} -body {
+    set env(test) aaaaaaaaaaaaaaaa
+    append env(test) bbbbbbbbbbbbbb
+    unset env(test)
 }
 
-# Save the current environment variables at the start of the test.
 
-set env2 [array get env]
-foreach name [array names env] {
-    # Keep some environment variables that support operation of the tcltest
-    # package.
-    if {[string toupper $name] ni {
-	TCL_LIBRARY PATH LD_LIBRARY_PATH LIBPATH DISPLAY SHLIB_PATH
-	SYSTEMDRIVE SYSTEMROOT DYLD_LIBRARY_PATH DYLD_FRAMEWORK_PATH
-	DYLD_NEW_LOCAL_SHARED_REGIONS DYLD_NO_FIX_PREBINDING
-	SECURITYSESSIONID LANG WINDIR TERM
-	CONNOMPROGRAMFILES PROGRAMFILES COMMONPROGRAMW6432 PROGRAMW6432
-    }} {
-	unset env($name)
-    }
-}
-
-# Need to run 'getenv' in known encoding, so save the current one here...
-set sysenc [encoding system]
-
-test env-2.1 {adding environment variables} -setup {
-    encoding system iso8859-1
-} -constraints {exec} -body {
-    getenv
+test env-1.3 {reflection of env by "array names"} -setup {
+    catch {interp delete child}
+    catch {unset env(test)}
+} -body {
+    interp create child
+    child eval {set env(test) garbage}
+    expr {"test" in [array names env]}
 } -cleanup {
-    encoding system $sysenc
-} -result {}
-test env-2.2 {adding environment variables} -setup {
-    encoding system iso8859-1
-} -constraints {exec} -body {
+    interp delete child
+    catch {unset env(test)}
+} -result 1
+
+
+test env-2.1 {
+    adding environment variables
+} -constraints exec -setup setup1 -body {
+    getenv
+} -cleanup cleanup1 -result {}
+
+
+test env-2.2 {
+    adding environment variables
+} -constraints exec -setup setup1 -body {
     set env(NAME1) "test string"
     getenv
-} -cleanup {
-    encoding system $sysenc
-} -result {NAME1=test string}
-test env-2.3 {adding environment variables} -setup {
-    encoding system iso8859-1
+} -cleanup cleanup1 -result {NAME1=test string}
+
+
+test env-2.3 {adding environment variables} -constraints exec -setup {
+    setup1
     set env(NAME1) "test string"
-} -constraints {exec} -body {
+} -body {
     set env(NAME2) "more"
     getenv
-} -cleanup {
-    encoding system $sysenc
-} -result {NAME1=test string
+} -cleanup cleanup1 -result {NAME1=test string
 NAME2=more}
-test env-2.4 {adding environment variables} -setup {
-    encoding system iso8859-1
+
+
+test env-2.4 {
+    adding environment variables
+} -constraints exec -setup {
+    setup1
     set env(NAME1) "test string"
     set env(NAME2) "more"
-} -constraints {exec} -body {
+} -body {
     set env(XYZZY) "garbage"
     getenv
-} -cleanup {
-    encoding system $sysenc
+} -cleanup { cleanup1
 } -result {NAME1=test string
 NAME2=more
 XYZZY=garbage}
 
-set env(NAME1) "test string"
-set env(NAME2) "new value"
-set env(XYZZY) "garbage"
-test env-3.1 {changing environment variables} -setup {
-    encoding system iso8859-1
-} -constraints {exec} -body {
+
+test env-3.1 {
+    changing environment variables
+} -constraints exec -setup setup2 -body {
     set result [getenv]
     unset env(NAME2)
     set result
 } -cleanup {
-    encoding system $sysenc
+    cleanup1
 } -result {NAME1=test string
 NAME2=new value
 XYZZY=garbage}
-unset -nocomplain env(NAME2)
 
-test env-4.1 {unsetting environment variables: default} -setup {
-    encoding system iso8859-1
-} -constraints {exec} -body {
+
+test env-4.1 {
+    unsetting environment variables
+} -constraints exec -setup setup2 -body {
+    unset -nocomplain env(NAME2)
     getenv
-} -cleanup {
-    encoding system $sysenc
-} -result {NAME1=test string
+} -cleanup cleanup1 -result {NAME1=test string
 XYZZY=garbage}
-test env-4.2 {unsetting environment variables} -setup {
-    encoding system iso8859-1
-} -constraints {exec} -body {
-    unset env(NAME1)
-    getenv
-} -cleanup {
-    unset env(XYZZY)
-    encoding system $sysenc
-} -result {XYZZY=garbage}
-unset -nocomplain env(NAME1) env(XYZZY)
-test env-4.3 {setting international environment variables} -setup {
-    encoding system iso8859-1
-} -constraints {exec} -body {
+
+# env-4.2 is deleted
+
+test env-4.3 {
+    setting international environment variables
+} -constraints exec -setup setup1 -body {
     set env(\ua7) \ub6
     getenv
-} -cleanup {
-    encoding system $sysenc
-} -result {\u00a7=\u00b6}
-test env-4.4 {changing international environment variables} -setup {
-    encoding system iso8859-1
-} -constraints {exec} -body {
+} -cleanup cleanup1 -result {\u00a7=\u00b6}
+
+
+test env-4.4 {
+    changing international environment variables
+} -constraints exec -setup setup1 -body {
     set env(\ua7) \ua7
     getenv
-} -cleanup {
-    encoding system $sysenc
-} -result {\u00a7=\u00a7}
-test env-4.5 {unsetting international environment variables} -setup {
-    encoding system iso8859-1
+} -cleanup cleanup1 -result {\u00a7=\u00a7}
+
+
+test env-4.5 {
+    unsetting international environment variables
+} -constraints exec -setup {
+    setup1
     set env(\ua7) \ua7
 } -body {
     set env(\ub6) \ua7
     unset env(\ua7)
     getenv
-} -constraints {exec} -cleanup {
-    unset env(\ub6)
-    encoding system $sysenc
-} -result {\u00b6=\u00a7}
+} -cleanup cleanup1 -result {\u00b6=\u00a7}
 
-test env-5.0 {corner cases - set a value, it should exist} -body {
+test env-5.0 {
+    corner cases - set a value, it should exist
+} -setup setup1 -body {
     set env(temp) a
     set env(temp)
-} -cleanup {
-    unset env(temp)
-} -result {a}
-test env-5.1 {corner cases - remove one elem at a time} -setup {
-    set x [array get env]
-} -body {
+} -cleanup cleanup1 -result a
+
+
+test env-5.1 {
+    corner cases - remove one elem at a time
+} -setup setup1 -body {
     # When no environment variables exist, the env var will contain no
     # entries. The "array names" call synchs up the C-level environ array with
     # the Tcl level env array. Make sure an empty Tcl array is created.
@@ -246,9 +286,9 @@ test env-5.1 {corner cases - remove one elem at a time} -setup {
 	unset env($e)
     }
     array size env
-} -cleanup {
-    array set env $x
-} -result {0}
+} -cleanup cleanup1 -result 0
+
+
 test env-5.2 {corner cases - unset the env array} -setup {
     interp create i
 } -body {
@@ -262,42 +302,54 @@ test env-5.2 {corner cases - unset the env array} -setup {
 } -cleanup {
     interp delete i
 } -result {0}
+
+
 test env-5.3 {corner cases: unset the env in master should unset child} -setup {
+    setup1
     interp create i
 } -body {
     # Variables deleted in a master interp should be deleted in child interp
     # too.
-    i eval { set env(THIS_SHOULD_EXIST) a}
+    i eval {set env(THIS_SHOULD_EXIST) a}
     set result [set env(THIS_SHOULD_EXIST)]
     unset env(THIS_SHOULD_EXIST)
     lappend result [i eval {catch {set env(THIS_SHOULD_EXIST)}}]
 } -cleanup {
+    cleanup1
     interp delete i
 } -result {a 1}
+
+
 test env-5.4 {corner cases - unset the env array} -setup {
+    setup1
     interp create i
 } -body {
     # The info exists command should be in synch with the env array.
     # Know Bug: 1737
-    i eval { set env(THIS_SHOULD_EXIST) a}
+    i eval {set env(THIS_SHOULD_EXIST) a}
     set     result [info exists env(THIS_SHOULD_EXIST)]
     lappend result [set env(THIS_SHOULD_EXIST)]
     lappend result [info exists env(THIS_SHOULD_EXIST)]
 } -cleanup {
+    cleanup1
     interp delete i
 } -result {1 a 1}
-test env-5.5 {corner cases - cannot have null entries on Windows} -constraints win -body {
+
+
+test env-5.5 {
+    corner cases - cannot have null entries on Windows
+} -constraints win -body {
     set env() a
     catch {set env()}
-} -result 1
+} -cleanup cleanup1 -result 1
 
-test env-6.1 {corner cases - add lots of env variables} -body {
+test env-6.1 {corner cases - add lots of env variables} -setup setup1 -body {
     set size [array size env]
     for {set i 0} {$i < 100} {incr i} {
 	set env(BOGUS$i) $i
     }
     expr {[array size env] - $size}
-} -result 100
+} -cleanup cleanup1 -result 100
 
 test env-7.1 {[219226]: whole env array should not be unset by read} -body {
     set n [array size env]
@@ -310,16 +362,20 @@ test env-7.1 {[219226]: whole env array should not be unset by read} -body {
     return $n
 } -result 0
 
-test env-7.2 {[219226]: links to env elements should not be removed by read} -body {
+test env-7.2 {
+    [219226]: links to env elements should not be removed by read
+} -setup setup1 -body {
     apply {{} {
 	set ::env(test7_2) ok
 	upvar env(test7_2) elem
 	set ::env(PATH)
 	return $elem
     }}
-} -result ok
+} -cleanup cleanup1 -result ok
 
-test env-7.3 {[9b4702]: testing existence of env(some_thing) should not destroy trace} -body {
+test env-7.3 {
+    [9b4702]: testing existence of env(some_thing) should not destroy trace
+} -setup setup1 -body {
     apply {{} {
       catch {unset ::env(test7_3)}
       proc foo args {
@@ -330,16 +386,25 @@ test env-7.3 {[9b4702]: testing existence of env(some_thing) should not destroy
       set ::env(not_yet_existent) "Now I'm here";
       return [info exists ::env(test7_3)]
     }}
-} -result 1
+} -cleanup cleanup1 -result 1
 
-# Restore the environment variables at the end of the test.
+test env-8.0 {
+    memory usage - valgrind does not report reachable memory
+} -body {
+    set res [set env(__DUMMY__) {i'm with dummy}]
+    unset env(__DUMMY__)
+    return $res
+} -result {i'm with dummy}
+
 
-foreach name [array names env] {
-    unset env($name)
-}
-array set env $env2
 
 # cleanup
+rename getenv {}
+rename envrestore {}
+rename envprep {}
+rename encodingrestore {}
+rename encodingswitch {}
+
 removeFile $printenvScript
 ::tcltest::cleanupTests
 return

tests/exec.test

@@ -11,9 +11,14 @@
 # See the file "license.terms" for information on usage and redistribution of
 # this file, and for a DISCLAIMER OF ALL WARRANTIES.
 
+# There is no point in running Valgrind on cases where [exec] forks but then
+# fails and the child process doesn't go through full cleanup.
+
 package require tcltest 2
 namespace import -force ::tcltest::*
 
+package require tcltests
+
 # All tests require the "exec" command.
 # Skip them if exec is not defined.
 testConstraint exec [llength [info commands exec]]
@@ -325,11 +330,11 @@ test exec-8.2 {long input and output} {exec} {
 
 # Commands that return errors.
 
-test exec-9.1 {commands returning errors} {exec} {
+test exec-9.1 {commands returning errors} {exec notValgrind} {
     set x [catch {exec gorp456} msg]
     list $x [string tolower $msg] [string tolower $errorCode]
 } {1 {couldn't execute "gorp456": no such file or directory} {posix enoent {no such file or directory}}}
-test exec-9.2 {commands returning errors} {exec} {
+test exec-9.2 {commands returning errors} {exec notValgrind} {
     string tolower [list [catch {exec [interpreter] echo foo | foo123} msg] $msg $errorCode]
 } {1 {couldn't execute "foo123": no such file or directory} {posix enoent {no such file or directory}}}
 test exec-9.3 {commands returning errors} -constraints {exec stdio} -body {
@@ -339,7 +344,7 @@ test exec-9.4 {commands returning errors} -constraints {exec stdio} -body {
     exec [interpreter] $path(exit) 43 | [interpreter] $path(echo) "foo bar"
 } -returnCodes error -result {foo bar
 child process exited abnormally}
-test exec-9.5 {commands returning errors} -constraints {exec stdio} -body {
+test exec-9.5 {commands returning errors} -constraints {exec stdio notValgrind} -body {
     exec gorp456 | [interpreter] echo a b c
 } -returnCodes error -result {couldn't execute "gorp456": no such file or directory}
 test exec-9.6 {commands returning errors} -constraints {exec} -body {
@@ -428,13 +433,13 @@ test exec-10.19 {errors in exec invocation} -constraints {exec} -body {
     exec cat >@ $f
 } -returnCodes error -result "channel \"$f\" wasn't opened for writing"
 close $f
-test exec-10.20 {errors in exec invocation} -constraints {exec} -body {
+test exec-10.20 {errors in exec invocation} -constraints {exec notValgrind} -body {
     exec ~non_existent_user/foo/bar
 } -returnCodes error -result {user "non_existent_user" doesn't exist}
-test exec-10.21 {errors in exec invocation} -constraints {exec} -body {
+test exec-10.21 {errors in exec invocation} -constraints {exec notValgrind} -body {
     exec [interpreter] true | ~xyzzy_bad_user/x | false
 } -returnCodes error -result {user "xyzzy_bad_user" doesn't exist}
-test exec-10.22 {errors in exec invocation} -constraints exec -body {
+test exec-10.22 {errors in exec invocation} -constraints {exec notValgrind} -body {
     exec echo test > ~non_existent_user/foo/bar
 } -returnCodes error -result {user "non_existent_user" doesn't exist}
 # Commands in background.
@@ -510,7 +515,7 @@ test exec-13.1 {setting errorCode variable} {exec} {
 test exec-13.2 {setting errorCode variable} {exec} {
     list [catch {exec [interpreter] $path(cat) > a/b/c} msg] [string tolower $errorCode]
 } {1 {posix enoent {no such file or directory}}}
-test exec-13.3 {setting errorCode variable} {exec} {
+test exec-13.3 {setting errorCode variable} {exec notValgrind} {
     set x [catch {exec _weird_cmd_} msg]
     list $x [string tolower $msg] [lindex $errorCode 0] \
 	    [string tolower [lrange $errorCode 2 end]]
@@ -548,7 +553,7 @@ test exec-14.2 {-keepnewline switch} -constraints {exec} -body {
 test exec-14.3 {unknown switch} -constraints {exec} -body {
     exec -gorp
 } -returnCodes error -result {bad option "-gorp": must be -ignorestderr, -keepnewline, or --}
-test exec-14.4 {-- switch} -constraints {exec} -body {
+test exec-14.4 {-- switch} -constraints {exec notValgrind} -body {
     exec -- -gorp
 } -returnCodes error -result {couldn't execute "-gorp": no such file or directory}
 test exec-14.5 {-ignorestderr switch} {exec} {
@@ -662,7 +667,7 @@ test exec-18.2 {exec cat deals with weird file names} -body {
 # Note that this test cannot be adapted to work on Windows; that platform has
 # no kernel support for an analog of O_APPEND. OTOH, that means we can assume
 # that there is a POSIX shell...
-test exec-19.1 {exec >> uses O_APPEND} -constraints {exec unix} -setup {
+test exec-19.1 {exec >> uses O_APPEND} -constraints {exec unix notValgrind} -setup {
     set tmpfile [makeFile {0} tmpfile.exec-19.1]
 } -body {
     # Note that we have to allow for the current contents of the temporary
@@ -675,7 +680,7 @@ test exec-19.1 {exec >> uses O_APPEND} -constraints {exec unix} -setup {
 	    {for a in a b c; do sleep 1; echo $a; done} >>$tmpfile &
     exec /bin/sh -c \
 	    {for a in d e f; do sleep 1; echo $a >&2; done} 2>>$tmpfile &
-    # The above four shell invokations take about 3 seconds to finish, so allow
+    # The above four shell invocations take about 3 seconds to finish, so allow
     # 5s (in case the machine is busy)
     after 5000
     # Check that no bytes have got lost through mixups with overlapping

tests/expr.test

@@ -7157,6 +7157,15 @@ test expr-51.1 {test round-to-even on input} {
     expr 6.9294956446009195e15
 } 6929495644600920.0
 
+test expr-52.1 {
+	comparison with empty string does not generate string representation
+} {
+	set a [list one two three]
+	list [expr {$a eq {}}] [expr {$a < {}}] [expr {$a > {}}] [
+		string match {*no string representation*} [
+		::tcl::unsupported::representation $a]]
+} {0 0 1 1}
+
 
 
 # cleanup

tests/fileSystem.test

@@ -264,6 +264,12 @@ removeDirectory dir.dir
 test filesystem-1.30 {normalisation of nonexistent user} -body {
     file normalize ~noonewiththisname
 } -returnCodes error -result {user "noonewiththisname" doesn't exist}
+test filesystem-1.30.1 {normalisation of existing user} -body {
+    catch {file normalize ~$::tcl_platform(user)}
+} -result {0}
+test filesystem-1.30.2 {normalisation of nonexistent user specified as user@domain} -body {
+    file normalize ~nonexistentuser@nonexistentdomain
+} -returnCodes error -result {user "nonexistentuser@nonexistentdomain" doesn't exist}
 test filesystem-1.31 {link normalisation: link near filesystem root} {testsetplatform} {
     testsetplatform unix
     file normalize /foo/../bar

tests/format.test

@@ -597,6 +597,20 @@ test format-19.3 {Bug 2830354} {
     string length [format %340f 0]
 } 340
 
+test format-19.4.1 {Bug d498578df4: width overflow should cause limit exceeded} \
+-constraints {longIs32bit} -body {
+    # in case of overflow into negative, it produces width -2 (and limit exceeded),
+    # in case of width will be unsigned, it will be outside limit (2GB for 32bit)...
+    # and it don't throw an error in case the bug is not fixed (and probably no segfault).
+    format %[expr {0xffffffff - 1}]g 0
+} -returnCodes error -result "max size for a Tcl value exceeded"
+
+test format-19.4.2 {Bug d498578df4: width overflow should cause limit exceeded} -body {
+    # limit should exceeds in any case,
+    # and it don't throw an error in case the bug is not fixed (and probably no segfault).
+    format %[expr {0xffffffffffffffff - 1}]g 0
+} -returnCodes error -result "max size for a Tcl value exceeded"
+
 # Note that this test may fail in future versions
 test format-20.1 {Bug 2932421: plain %s caused intrep change of args} -body {
     set x [dict create a b c d]

tests/http11.test

@@ -666,6 +666,13 @@ test http11-4.3 "normal post request, check channel query length" -setup {
 
 # -------------------------------------------------------------------------
 
+# Eliminate valgrind "still reachable" reports on outstanding "Detached"
+# structures in the detached list which stem from PipeClose2Proc not waiting
+# around for background processes to complete, meaning that previous calls to
+# Tcl_ReapDetachedProcs might not have had a chance to reap all processes.
+after 10
+exec [info nameofexecutable] << {}
+
 foreach p {create_httpd httpd_read halt_httpd meta check_crc} {
     if {[llength [info proc $p]]} {rename $p {}}
 }

tests/io.test

@@ -15,14 +15,8 @@
 
 if {[lsearch [namespace children] ::tcltest] == -1} {
     package require tcltest 2
-    namespace import -force ::tcltest::*
 }
 
-::tcltest::loadTestedCommands
-catch [list package require -exact Tcltest [info patchlevel]]
-
-testConstraint testbytestring [llength [info commands testbytestring]]
-
 namespace eval ::tcl::test::io {
     namespace import ::tcltest::*
 
@@ -35,15 +29,16 @@ namespace eval ::tcl::test::io {
     variable msg
     variable expected
 
+    loadTestedCommands
+    catch [list package require -exact Tcltest [info patchlevel]]
+    package require tcltests
+
+testConstraint testbytestring [llength [info commands testbytestring]]
 testConstraint testchannel      [llength [info commands testchannel]]
-testConstraint exec             [llength [info commands exec]]
 testConstraint openpipe         1
-testConstraint fileevent        [llength [info commands fileevent]]
-testConstraint fcopy            [llength [info commands fcopy]]
 testConstraint testfevent       [llength [info commands testfevent]]
 testConstraint testchannelevent [llength [info commands testchannelevent]]
 testConstraint testmainthread   [llength [info commands testmainthread]]
-testConstraint thread [expr {0 == [catch {package require Thread 2.7-}]}]
 testConstraint testobj		[llength [info commands testobj]]
 
 # You need a *very* special environment to do some tests.  In

tests/ioCmd.test

@@ -21,10 +21,10 @@ if {[lsearch [namespace children] ::tcltest] == -1} {
 ::tcltest::loadTestedCommands
 catch [list package require -exact Tcltest [info patchlevel]]
 
+package require tcltests
+
 # Custom constraints used in this file
-testConstraint fcopy		[llength [info commands fcopy]]
 testConstraint testchannel	[llength [info commands testchannel]]
-testConstraint thread [expr {0 == [catch {package require Thread 2.7-}]}]
 
 #----------------------------------------------------------------------
 
@@ -395,7 +395,7 @@ test iocmd-11.2 {I/O to command pipelines} {unixOrPc unixExecs} {
 test iocmd-11.3 {I/O to command pipelines} {unixOrPc unixExecs} {
     list [catch {open "| echo > \"$path(test5)\"" r+} msg] $msg $::errorCode
 } {1 {can't read output from command: standard output was redirected} {TCL OPERATION EXEC BADREDIRECT}}
-test iocmd-11.4 {I/O to command pipelines} unixOrPc {
+test iocmd-11.4 {I/O to command pipelines} {notValgrind unixOrPc} {
     list [catch {open "| no_such_command_exists" rb} msg] $msg $::errorCode
 } {1 {couldn't execute "no_such_command_exists": no such file or directory} {POSIX ENOENT {no such file or directory}}}
 
@@ -3781,7 +3781,6 @@ test iocmd.tf-32.0 {origin thread of moved channel gone} -match glob -body {
 # Use constraints to skip this test while valgrinding so this expected leak
 # doesn't prevent a finding of "leak-free".
 #
-testConstraint notValgrind [expr {![testConstraint valgrind]}]
 test iocmd.tf-32.1 {origin thread of moved channel destroyed during access} -match glob -body {
 
     #puts <<$tcltest::mainThread>>main
@@ -3834,6 +3833,16 @@ test iocmd.tf-32.1 {origin thread of moved channel destroyed during access} -mat
 
 rename track {}
 # cleanup
+
+
+# Eliminate valgrind "still reachable" reports on outstanding "Detached"
+# structures in the detached list which stem from PipeClose2Proc not waiting
+# around for background processes to complete, meaning that previous calls to
+# Tcl_ReapDetachedProcs might not have had a chance to reap all processes.
+after 10
+exec [info nameofexecutable] << {}
+
+
 foreach file [list test1 test2 test3 test4] {
     removeFile $file
 }

tests/ioTrans.test

@@ -1240,8 +1240,8 @@ test iortrans-11.1 {origin interpreter of moved transform destroyed during acces
 	set res
     }]
 } -cleanup {
-    tempdone
     interp delete $idb
+    tempdone
 } -result {Owner lost}
 test iortrans-11.2 {delete interp of reflected transform} -setup {
     interp create slave

tests/iogt.test

@@ -608,7 +608,7 @@ test iogt-3.0 {Tcl_Channel valid after stack/unstack, fevent handling} -setup {
 	variable copy 1
     }
 } -constraints {testchannel knownBug} -body {
-    # This test to check the validity of aquired Tcl_Channel references is not
+    # This test to check the validity of acquired Tcl_Channel references is not
     # possible because even a backgrounded fcopy will immediately start to
     # copy data, without waiting for the event loop. This is done only in case
     # of an underflow on the read size!. So stacking transforms after the

tests/main.test

@@ -1210,8 +1210,6 @@ namespace eval ::tcl::test::main {
 	Bug 1775878
     } -constraints {
 	exec Tcltest
-    } -setup {
-	catch {set f [open "|[list [interpreter]]" w+]}
     } -body {
 	exec [interpreter] << "testsetmainloop\nputs \\\npwd\ntestexitmainloop" >& result
 	set f [open result]

tests/msgcat.test

@@ -999,7 +999,7 @@ if {[package vsatisfies [package provide msgcat] 1.7]} {
 	    mcpackagelocale isset
 	} -result {0}
 
-	
+
     # Tests msgcat-13.*: [mcpackageconfig subcmds]
 
 	test msgcat-13.1 {mcpackageconfig no subcommand} -body {
@@ -1153,7 +1153,7 @@ if {[package vsatisfies [package provide msgcat] 1.7]} {
 
 
     # Tests msgcat-15.*: tcloo coverage
-    
+
     # There are 4 use-cases, where 3 must be tested now:
     # - namespace defined, in class definition, class defined oo, classless
 
@@ -1210,7 +1210,7 @@ if {[package vsatisfies [package provide msgcat] 1.7]} {
     } -body {
 	bar::ObjCur method1
     } -result con2bar
-    
+
     test msgcat-15.4 {mc in classless object with explicite namespace eval}\
     -setup {
 	# full namespace is ::msgcat::test:bar
@@ -1236,7 +1236,7 @@ if {[package vsatisfies [package provide msgcat] 1.7]} {
     } -body {
 	bar::ObjCur method1
     } -result con2baz
-    
+
     # Test msgcat-16.*: command mcpackagenamespaceget
 
     test msgcat-16.1 {mcpackagenamespaceget in namespace procedure} -body {
@@ -1298,7 +1298,7 @@ if {[package vsatisfies [package provide msgcat] 1.7]} {
 
 
     # Test msgcat-17.*: mcn command
-    
+
     test msgcat-17.1 {mcn no parameters} -body {
 	mcn
     } -returnCodes 1\
@@ -1328,26 +1328,26 @@ if {[package vsatisfies [package provide msgcat] 1.7]} {
 	mcutil junk
     } -returnCodes 1\
     -result {unknown subcommand "junk": must be getpreferences, or getsystemlocale}
-    
+
     test msgcat-18.3 {mcutil - partial argument} -body {
 	mcutil getsystem
     } -returnCodes 1\
     -result {unknown subcommand "getsystem": must be getpreferences, or getsystemlocale}
-    
+
     test msgcat-18.4 {mcutil getpreferences - no argument} -body {
 	mcutil getpreferences
     } -returnCodes 1\
     -result {wrong # args: should be "mcutil getpreferences locale"}
-    
+
     test msgcat-18.5 {mcutil getpreferences - DE_de} -body {
 	mcutil getpreferences DE_de
     } -result {de_de de {}}
-    
+
     test msgcat-18.6 {mcutil getsystemlocale - wrong argument} -body {
 	mcutil getsystemlocale DE_de
     } -returnCodes 1\
     -result {wrong # args: should be "mcutil getsystemlocale"}
-    
+
     # The result is system dependent
     # So just test if it runs
     # The environment variable version was test with test 0.x
@@ -1355,8 +1355,8 @@ if {[package vsatisfies [package provide msgcat] 1.7]} {
 	mcutil getsystemlocale
 	set ok ok
     } -result {ok}
-    
-    
+
+
     cleanupTests
 }
 namespace delete ::msgcat::test

tests/namespace.test

@@ -205,7 +205,7 @@ test namespace-7.8 {Bug ba1419303b4c} -setup {
 	namespace delete ns1
     }
 } -body {
-    # No segmentation fault given --enable-symbols=mem. 
+    # No segmentation fault given --enable-symbols=mem.
     namespace delete ns1
 } -result {}
 

tests/oo.test

@@ -340,10 +340,10 @@ test oo-1.21 {basic test of OO functionality: default relations} -setup {
 	    lappend x [info object class ::oo::$initial]
 	}
 	return $x
-    }] {lsort $x}
+    }] {lsort [lmap y $x {if {[string match *::delegate $y]} continue; set y}]}
 } -cleanup {
     interp delete $fresh
-} -result {{} {::oo::Slot ::oo::class ::oo::object} {::oo::define::filter ::oo::define::mixin ::oo::define::superclass ::oo::define::variable ::oo::objdefine::filter ::oo::objdefine::mixin ::oo::objdefine::variable} {::oo::Slot ::oo::class} {} {} {} {} {} {} ::oo::object ::oo::object ::oo::class ::oo::class ::oo::class}
+} -result {{} {::oo::Slot ::oo::abstract ::oo::class ::oo::object ::oo::singleton} {::oo::define::filter ::oo::define::mixin ::oo::define::superclass ::oo::define::variable ::oo::objdefine::filter ::oo::objdefine::mixin ::oo::objdefine::variable} {::oo::Slot ::oo::class} {::oo::abstract ::oo::singleton} {} {} {} {} {} ::oo::object ::oo::object ::oo::class ::oo::class ::oo::class}
 
 test oo-2.1 {basic test of OO functionality: constructor} -setup {
     # This is a bit complex because it needs to run in a sub-interp as
@@ -2153,7 +2153,7 @@ test oo-15.13.1 {
 } -cleanup {
     Cls destroy
     Cls2 destroy
-} -result done 
+} -result done
 test oo-15.13.2 {OO: object cloning with target NS} -setup {
     oo::class create Super
     oo::class create Cls {superclass Super}
@@ -2202,7 +2202,7 @@ test oo-16.2 {OO: object introspection} -body {
 } -returnCodes 1 -result {NOTANOBJECT does not refer to an object}
 test oo-16.3 {OO: object introspection} -body {
     info object gorp oo::object
-} -returnCodes 1 -result {unknown or ambiguous subcommand "gorp": must be call, class, definition, filters, forward, isa, methods, methodtype, mixins, namespace, variables, or vars}
+} -returnCodes 1 -result {unknown or ambiguous subcommand "gorp": must be call, class, creationid, definition, filters, forward, isa, methods, methodtype, mixins, namespace, variables, or vars}
 test oo-16.4 {OO: object introspection} -setup {
     oo::class create meta { superclass oo::class }
     [meta create instance1] create instance2
@@ -2332,6 +2332,73 @@ test oo-16.14 {OO: object introspection: TIP #436} -setup {
 } -cleanup {
     meta destroy
 } -result {class {0 0} meta {0 0 0} type {0 0 0 0 0 0} mix {0 0 0 0 0 0}}
+test oo-16.15 {OO: object introspection: creationid #500} -setup {
+    oo::class create cls
+} -body {
+    info object creationid [cls new]
+} -cleanup {
+    cls destroy
+} -result {^\d+$} -match regexp
+test oo-16.16 {OO: object introspection: creationid #500} -setup {
+    oo::class create cls
+} -body {
+    set obj [cls new]
+    set id [info object creationid $obj]
+    rename $obj gorp
+    set id2 [info object creationid gorp]
+    list $id $id2
+} -cleanup {
+    cls destroy
+} -result {^(\d+) \1$} -match regexp
+test oo-16.17 {OO: object introspection: creationid #500} -body {
+    info object creationid nosuchobject
+} -returnCodes error -result {nosuchobject does not refer to an object}
+test oo-16.18 {OO: object introspection: creationid #500} -body {
+    info object creationid
+} -returnCodes error -result {wrong # args: should be "info object creationid objName"}
+test oo-16.18 {OO: object introspection: creationid #500} -body {
+    info object creationid oo::object gorp
+} -returnCodes error -result {wrong # args: should be "info object creationid objName"}
+test oo-16.19 {OO: object introspection: creationid #500} -setup {
+    oo::class create cls
+} -body {
+    set id1 [info object creationid [set o1 [cls new]]]
+    set id2 [info object creationid [set o2 [cls new]]]
+    if {$id1 == $id2} {
+	format "objects %s and %s have same creation id: %d" $o1 $o2 $id1
+    } else {
+	string cat not-equal
+    }
+} -cleanup {
+    cls destroy
+} -result not-equal
+test oo-16.20 {OO: object introspection: creationid #500} -setup {
+    oo::class create cls
+} -body {
+    set id1 [info object creationid [set o1 [cls new]]]
+    $o1 destroy
+    set id2 [info object creationid [set o2 [cls new]]]
+    if {$id1 == $id2} {
+	format "objects %s and %s have same creation id: %d" $o1 $o2 $id1
+    } else {
+	string cat not-equal
+    }
+} -cleanup {
+    cls destroy
+} -result not-equal
+test oo-16.21 {OO: object introspection: creationid #500} -setup {
+    oo::class create cls
+} -body {
+    set id1 [info object creationid [set o1 [cls new]]]
+    set id2 [info object creationid [set o2 [oo::copy $o1]]]
+    if {$id1 == $id2} {
+	format "objects %s and %s have same creation id: %d" $o1 $o2 $id1
+    } else {
+	string cat not-equal
+    }
+} -cleanup {
+    cls destroy
+} -result not-equal
 
 test oo-17.1 {OO: class introspection} -body {
     info class
@@ -4102,6 +4169,751 @@ test oo-36.10 {TIP #470: introspection within oo::define} -setup {
     Cls destroy
     catch {rename oo::objdefine::testself {}}
 } -result {{} {1 {this command may only be called from within the context of an ::oo::define or ::oo::objdefine command} 0 ::obj}}
+
+test oo-37.1 {TIP 500: private command propagates errors} -setup {
+    oo::class create cls
+} -body {
+    oo::define cls {
+	private ::error "this is an error"
+    }
+} -cleanup {
+    cls destroy
+} -returnCodes error -result {this is an error}
+test oo-37.2 {TIP 500: private command propagates errors} -setup {
+    oo::class create cls
+} -body {
+    oo::define cls {
+	private {
+	    ::error "this is an error"
+	}
+    }
+} -cleanup {
+    cls destroy
+} -returnCodes error -result {this is an error}
+test oo-37.3 {TIP 500: private command propagates errors} -setup {
+    oo::object create obj
+} -body {
+    oo::objdefine obj {
+	private ::error "this is an error"
+    }
+} -cleanup {
+    obj destroy
+} -returnCodes error -result {this is an error}
+test oo-37.4 {TIP 500: private command propagates errors} -setup {
+    oo::object create obj
+} -body {
+    oo::objdefine obj {
+	private {
+	    ::error "this is an error"
+	}
+    }
+} -cleanup {
+    obj destroy
+} -returnCodes error -result {this is an error}
+test oo-37.5 {TIP 500: private command can't be used outside definitions} -body {
+    oo::define::private error "xyz"
+} -returnCodes error -result {this command may only be called from within the context of an ::oo::define or ::oo::objdefine command}
+test oo-37.6 {TIP 500: private command can't be used outside definitions} -body {
+    oo::objdefine::private error "xyz"
+} -returnCodes error -result {this command may only be called from within the context of an ::oo::define or ::oo::objdefine command}
+
+test oo-38.1 {TIP 500: private variables don't cross-interfere with each other or normal ones} -setup {
+    oo::class create parent
+} -body {
+    oo::class create clsA {
+	superclass parent
+	private variable x
+	constructor {} {
+	    set x 1
+	}
+	method getA {} {
+	    return $x
+	}
+    }
+    oo::class create clsB {
+	superclass clsA
+	private {
+	    variable x
+	}
+	constructor {} {
+	    set x 2
+	    next
+	}
+	method getB {} {
+	    return $x
+	}
+    }
+    oo::class create clsC {
+	superclass clsB
+	variable x
+	constructor {} {
+	    set x 3
+	    next
+	}
+	method getC {} {
+	    return $x
+	}
+    }
+    clsC create obj
+    oo::objdefine obj {
+	private {
+	    variable x
+	}
+	method setup {} {
+	    set x 4
+	}
+	method getO {} {
+	    return $x
+	}
+    }
+    obj setup
+    list [obj getA] [obj getB] [obj getC] [obj getO] \
+	[lsort [string map [list [info object creationid clsA] CLASS-A \
+				[info object creationid clsB] CLASS-B \
+				[info object creationid obj] OBJ] \
+		    [info object vars obj]]]
+} -cleanup {
+    parent destroy
+} -result {1 2 3 4 {{CLASS-A : x} {CLASS-B : x} {OBJ : x} x}}
+test oo-38.2 {TIP 500: private variables introspection} -setup {
+    oo::class create parent
+} -body {
+    oo::class create cls {
+	superclass parent
+	private {
+	    variable x1
+	    variable x2
+	}
+	variable y1 y2
+    }
+    cls create obj
+    oo::objdefine obj {
+	private variable a1 a2
+	variable b1 b2
+    }
+    list [lsort [info class variables cls]] \
+	[lsort [info class variables cls -private]] \
+	[lsort [info object variables obj]] \
+	[lsort [info object variables obj -private]]
+} -cleanup {
+    parent destroy
+} -result {{y1 y2} {x1 x2} {b1 b2} {a1 a2}}
+test oo-38.3 {TIP 500: private variables and oo::object·varname} -setup {
+    oo::class create parent
+} -body {
+    oo::class create clsA {
+	superclass parent
+	private {
+	    variable x
+	}
+	method getx {} {
+	    set x 1
+	    my varname x
+	}
+	method readx {} {
+	    return $x
+	}
+    }
+    oo::class create clsB {
+	superclass clsA
+	variable x
+	method gety {} {
+	    set x 1
+	    my varname x
+	}
+	method ready {} {
+	    return $x
+	}
+    }
+    clsB create obj
+    set [obj getx] 2
+    set [obj gety] 3
+    list [obj readx] [obj ready]
+} -cleanup {
+    parent destroy
+} -result {2 3}
+test oo-38.4 {TIP 500: private variables introspection} -setup {
+    oo::class create parent
+} -body {
+    oo::class create cls {
+	superclass parent
+	private {
+	    variable x1 x2
+	}
+	variable y1 y2
+	constructor {} {
+	    variable z boo
+	    set x1 a
+	    set y1 c
+	}
+	method list {} {
+	    variable z
+	    set ok 1
+	    list [info locals] [lsort [info vars]] [info exist x2]
+	}
+    }
+    cls create obj
+    oo::objdefine obj {
+	private variable a1 a2
+	variable b1 b2
+	method init {} {
+	    # Because we don't have a constructor to do this setup for us
+	    set a1 p
+	    set b1 r
+	}
+	method list {} {
+	    variable z
+	    set yes 1
+	    list {*}[next] [info locals] [lsort [info vars]] [info exist a2]
+	}
+    }
+    obj init
+    obj list
+} -cleanup {
+    parent destroy
+} -result {ok {ok x1 x2 y1 y2 z} 0 yes {a1 a2 b1 b2 yes z} 0}
+test oo-38.5 {TIP 500: private variables and oo::object·variable} -setup {
+    oo::class create parent
+} -body {
+    oo::class create cls1 {
+	superclass parent
+	private variable x
+	method abc val {
+	    my variable x
+	    set x $val
+	}
+	method def val {
+	    my variable y
+	    set y $val
+	}
+	method get1 {} {
+	    my variable x y
+	    return [list $x $y]
+	}
+    }
+    oo::class create cls2 {
+	superclass cls1
+	private variable x
+	method x-exists {} {
+	    return [info exists x],[uplevel 1 {info exists x}]
+	}
+	method ghi x {
+	    # Additional instrumentation to show that we're not using the
+	    # resolved variable until we ask for it; the argument nixed that
+	    # happening by default.
+	    set val $x
+	    set before [my x-exists]
+	    unset x
+	    set x $val
+	    set mid [my x-exists]
+	    unset x
+	    set mid2 [my x-exists]
+	    my variable x
+	    set x $val
+	    set after [my x-exists]
+	    return "$before;$mid;$mid2;$after"
+	}
+	method jkl val {
+	    my variable y
+	    set y $val
+	}
+	method get2 {} {
+	    my variable x y
+	    return [list $x $y]
+	}
+    }
+    cls2 create a
+    a abc 123
+    a def 234
+    set tmp [a ghi 345]
+    a jkl 456
+    list $tmp [a get1] [a get2]
+} -cleanup {
+    parent destroy
+} -result {{0,1;0,1;0,0;1,1} {123 456} {345 456}}
+
+test oo-39.1 {TIP 500: private methods internal call; class private} -setup {
+    oo::class create parent
+} -body {
+    oo::class create clsA {
+	superclass parent
+	variable x
+	constructor {} {
+	    set x 1
+	}
+	method act {} {
+	    my step
+	    my step
+	    my step
+	    return
+	}
+	private {
+	    method step {} {
+		incr x 2
+	    }
+	}
+	method x {} {
+	    return $x
+	}
+    }
+    clsA create obj
+    obj act
+    list [obj x] [catch {obj step} msg] $msg
+} -cleanup {
+    parent destroy
+} -result {7 1 {unknown method "step": must be act, destroy or x}}
+test oo-39.2 {TIP 500: private methods internal call; class private} -setup {
+    oo::class create parent
+} -body {
+    oo::class create clsA {
+	superclass parent
+	variable x
+	constructor {} {
+	    set x 1
+	}
+	method act {} {
+	    my step
+	    my step
+	    my step
+	    return
+	}
+	private {
+	    method step {} {
+		incr x 2
+	    }
+	}
+	method x {} {
+	    return $x
+	}
+    }
+    oo::class create clsB {
+	superclass clsA
+	variable x
+	method step {} {
+	    incr x 5
+	}
+    }
+    clsB create obj
+    obj act
+    list [obj x] [obj step]
+} -cleanup {
+    parent destroy
+} -result {7 12}
+test oo-39.3 {TIP 500: private methods internal call; class private} -setup {
+    oo::class create parent
+} -body {
+    oo::class create clsA {
+	superclass parent
+	variable x
+	constructor {} {
+	    set x 1
+	}
+	method act {} {
+	    my Step
+	    my Step
+	    my Step
+	    return
+	}
+	method x {} {
+	    return $x
+	}
+    }
+    oo::class create clsB {
+	superclass clsA
+	variable x
+	method Step {} {
+	    incr x 5
+	}
+    }
+    clsB create obj
+    obj act
+    set result [obj x]
+    oo::define clsA {
+	private {
+	    method Step {} {
+		incr x 2
+	    }
+	}
+    }
+    obj act
+    lappend result [obj x]
+} -cleanup {
+    parent destroy
+} -result {16 22}
+test oo-39.4 {TIP 500: private methods internal call; instance private} -setup {
+    oo::class create parent
+} -body {
+    oo::class create clsA {
+	superclass parent
+	variable x
+	constructor {} {
+	    set x 1
+	}
+	method act {} {
+	    my step
+	    return
+	}
+	method step {} {
+	    incr x
+	}
+	method x {} {
+	    return $x
+	}
+    }
+    clsA create obj
+    obj act
+    set result [obj x]
+    oo::objdefine obj {
+	variable x
+	private {
+	    method step {} {
+		incr x 2
+	    }
+	}
+    }
+    obj act
+    lappend result [obj x]
+    oo::objdefine obj {
+	method act {} {
+	    my step
+	    next
+	}
+    }
+    obj act
+    lappend result [obj x]
+} -cleanup {
+    parent destroy
+} -result {2 3 6}
+test oo-39.5 {TIP 500: private methods internal call; cross object} -setup {
+    oo::class create parent
+} -body {
+    oo::class create cls {
+	superclass parent
+	variable x
+	constructor {val} {
+	    set x $val
+	}
+	private method x {} {
+	    return $x
+	}
+	method equal {other} {
+	    expr {$x == [$other x]}
+	}
+    }
+    cls create a 1
+    cls create b 2
+    cls create c 1
+    list [a equal b] [b equal c] [c equal a] [catch {a x} msg] $msg
+} -cleanup {
+    parent destroy
+} -result {0 0 1 1 {unknown method "x": must be destroy or equal}}
+test oo-39.6 {TIP 500: private methods internal call; error reporting} -setup {
+    oo::class create parent
+} -body {
+    oo::class create cls {
+	superclass parent
+	variable x
+	constructor {val} {
+	    set x $val
+	}
+	private method x {} {
+	    return $x
+	}
+	method equal {other} {
+	    expr {$x == [$other y]}
+	}
+    }
+    cls create a 1
+    cls create b 2
+    a equal b
+} -returnCodes error -cleanup {
+    parent destroy
+} -result {unknown method "y": must be destroy, equal or x}
+test oo-39.7 {TIP 500: private methods internal call; error reporting} -setup {
+    oo::class create parent
+} -body {
+    oo::class create cls {
+	superclass parent
+	variable x
+	constructor {val} {
+	    set x $val
+	}
+	private method x {} {
+	    return $x
+	}
+	method equal {other} {
+	    expr {[[self] y] == [$other x]}
+	}
+    }
+    cls create a 1
+    cls create b 2
+    a equal b
+} -returnCodes error -cleanup {
+    parent destroy
+} -result {unknown method "y": must be destroy, equal or x}
+test oo-39.8 {TIP 500: private methods internal call; error reporting} -setup {
+    oo::class create parent
+} -body {
+    oo::class create cls {
+	superclass parent
+	variable x
+	constructor {val} {
+	    set x $val
+	}
+	private method x {} {
+	    return $x
+	}
+	method equal {other} {
+	    expr {[my y] == [$other x]}
+	}
+    }
+    cls create a 1
+    cls create b 2
+    a equal b
+} -returnCodes error -cleanup {
+    parent destroy
+} -result {unknown method "y": must be <cloned>, destroy, equal, eval, unknown, variable, varname or x}
+test oo-39.9 {TIP 500: private methods internal call; error reporting} -setup {
+    oo::class create parent
+} -body {
+    oo::class create cls {
+	superclass parent
+	variable x
+	constructor {val} {
+	    set x $val
+	}
+	private method x {} {
+	    return $x
+	}
+    }
+    oo::class create cls2 {
+	superclass cls
+	method equal {other} {
+	    expr {[my y] == [$other x]}
+	}
+    }
+    cls2 create a 1
+    cls2 create b 2
+    a equal b
+} -returnCodes error -cleanup {
+    parent destroy
+} -result {unknown method "y": must be <cloned>, destroy, equal, eval, unknown, variable or varname}
+test oo-39.10 {TIP 500: private methods internal call; error reporting} -setup {
+    oo::class create parent
+} -body {
+    oo::class create cls {
+	superclass parent
+	variable x
+	constructor {val} {
+	    set x $val
+	}
+	private method x {} {
+	    return $x
+	}
+    }
+    oo::class create cls2 {
+	superclass cls
+	method equal {other} {
+	    expr {[my x] == [$other x]}
+	}
+    }
+    cls2 create a 1
+    cls2 create b 2
+    a equal b
+} -returnCodes error -cleanup {
+    parent destroy
+} -result {unknown method "x": must be <cloned>, destroy, equal, eval, unknown, variable or varname}
+test oo-39.11 {TIP 500: private methods; call chain caching and reporting} -setup {
+    oo::class create parent
+} -body {
+    oo::class create cls {
+	superclass parent
+	method chain {} {
+	    return [self call]
+	}
+    }
+    oo::class create cls2 {
+	superclass cls
+	private method chain {} {
+	    next
+	}
+	method chain2 {} {
+	    my chain
+	}
+	method chain3 {} {
+	    [self] chain
+	}
+    }
+    cls create a
+    cls2 create b
+    list [a chain] [b chain] [b chain2] [b chain3]
+} -cleanup {
+    parent destroy
+} -result {{{{method chain ::cls method}} 0} {{{method chain ::cls method}} 0} {{{private chain ::cls2 method} {method chain ::cls method}} 1} {{{private chain ::cls2 method} {method chain ::cls method}} 1}}
+test oo-39.12 {TIP 500: private methods; introspection} -setup {
+    oo::class create parent
+} -body {
+    oo::class create cls {
+	superclass parent
+	method chain {} {
+	    return [self call]
+	}
+	private method abc {} {}
+    }
+    oo::class create cls2 {
+	superclass cls
+	method chain2 {} {
+	    my chain
+	}
+	method chain3 {} {
+	    [self] chain
+	}
+	private method def {} {}
+	unexport chain3
+    }
+    cls create a
+    cls2 create b
+    oo::objdefine b {
+	private method ghi {} {}
+	method ABC {} {}
+	method foo {} {}
+    }
+    set scopes {public unexported private}
+    list a: [lmap s $scopes {info object methods a -scope $s}] \
+	b: [lmap s $scopes {info object methods b -scope $s}] \
+	cls: [lmap s $scopes {info class methods cls -scope $s}] \
+	cls2: [lmap s $scopes {info class methods cls2 -scope $s}] \
+} -cleanup {
+    parent destroy
+} -result {a: {{} {} {}} b: {foo ABC ghi} cls: {chain {} abc} cls2: {chain2 chain3 def}}
+
+test oo-40.1 {TIP 500: private and self} -setup {
+    oo::class create cls
+} -body {
+    oo::define cls {
+	self {
+	    private {
+		variable a
+	    }
+	    variable b
+	}
+	private {
+	    self {
+		variable c
+	    }
+	    variable d
+	}
+	variable e
+    }
+    list \
+	[lsort [info class variables cls]] \
+	[lsort [info class variables cls -private]] \
+	[lsort [info object variables cls]] \
+	[lsort [info object variables cls -private]]
+} -cleanup {
+    cls destroy
+} -result {e d b {a c}}
+test oo-40.2 {TIP 500: private and export} -setup {
+    oo::class create cls
+} -body {
+    oo::define cls {
+	private method foo {} {}
+    }
+    set result [lmap s {public unexported private} {
+	info class methods cls -scope $s}]
+    oo::define cls {
+	export foo
+    }
+    lappend result {*}[lmap s {public unexported private} {
+	info class methods cls -scope $s}]
+} -cleanup {
+    cls destroy
+} -result {{} {} foo foo {} {}}
+test oo-40.3 {TIP 500: private and unexport} -setup {
+    oo::class create cls
+} -body {
+    oo::define cls {
+	private method foo {} {}
+    }
+    set result [lmap s {public unexported private} {
+	info class methods cls -scope $s}]
+    oo::define cls {
+	unexport foo
+    }
+    lappend result {*}[lmap s {public unexported private} {
+	info class methods cls -scope $s}]
+} -cleanup {
+    cls destroy
+} -result {{} {} foo {} foo {}}
+
+test oo-41.1 {TIP 478: myclass command, including class morphing} -setup {
+    oo::class create parent
+    set result {}
+} -body {
+    oo::class create cls1 {
+	superclass parent
+	self method count {} {
+	    my variable c
+	    incr c
+	}
+	method act {} {
+	    myclass count
+	}
+    }
+    cls1 create x
+    lappend result [x act] [x act]
+    cls1 create y
+    lappend result [y act] [y act] [x act]
+    oo::class create cls2 {
+	superclass cls1
+	self method count {} {
+	    my variable d
+	    expr {1.0 * [incr d]}
+	}
+    }
+    oo::objdefine x {class cls2}
+    lappend result [x act] [y act] [x act] [y act]
+} -cleanup {
+    parent destroy
+} -result {1 2 3 4 5 1.0 6 2.0 7}
+test oo-41.2 {TIP 478: myclass command cleanup} -setup {
+    oo::class create parent
+    set result {}
+} -body {
+    oo::class create cls1 {
+	superclass parent
+	self method hi {} {
+	    return "this is [self]"
+	}
+	method hi {} {
+	    return "this is [self]"
+	}
+    }
+    cls1 create x
+    rename [info object namespace x]::my foo
+    rename [info object namespace x]::myclass bar
+    lappend result [cls1 hi] [x hi] [foo hi] [bar hi]
+    x destroy
+    lappend result [catch {foo hi}] [catch {bar hi}]
+} -cleanup {
+    parent destroy
+} -result {{this is ::cls1} {this is ::x} {this is ::x} {this is ::cls1} 1 1}
+test oo-41.3 {TIP 478: myclass command calls unexported methods, via forward} -setup {
+    oo::class create parent
+    set result {}
+} -body {
+    oo::class create cls1 {
+	superclass parent
+	self method Hi {} {
+	    return "this is [self]"
+	}
+	forward poke myclass Hi
+    }
+    cls1 create x
+    lappend result [catch {cls1 Hi}] [x poke]
+} -cleanup {
+    parent destroy
+} -result {1 {this is ::cls1}}
 
 cleanupTests
 return

tests/ooUtil.test

@@ -0,0 +1,563 @@
+# This file contains a collection of tests for functionality originally
+# sourced from the ooutil package in Tcllib. Sourcing this file into Tcl runs
+# the tests and generates output for errors. No output means no errors were
+# found.
+#
+# Copyright (c) 2014-2016 Andreas Kupries
+# Copyright (c) 2018 Donal K. Fellows
+#
+# See the file "license.terms" for information on usage and redistribution of
+# this file, and for a DISCLAIMER OF ALL WARRANTIES.
+
+package require TclOO 1.0.3
+package require tcltest 2
+if {"::tcltest" in [namespace children]} {
+    namespace import -force ::tcltest::*
+}
+
+test ooUtil-1.1 {TIP 478: classmethod} -setup {
+    oo::class create parent
+} -body {
+    oo::class create ActiveRecord {
+	superclass parent
+        classmethod find args {
+	    return "[self] called with arguments: $args"
+	}
+    }
+    oo::class create Table {
+        superclass ActiveRecord
+    }
+    Table find foo bar
+} -cleanup {
+    parent destroy
+} -result {::Table called with arguments: foo bar}
+test ooUtil-1.2 {TIP 478: classmethod in namespace} -setup {
+    namespace eval ::testns {}
+} -body {
+    namespace eval ::testns {
+	oo::class create ActiveRecord {
+	    classmethod find args {
+		return "[self] called with arguments: $args"
+	    }
+	}
+	oo::class create Table {
+	    superclass ActiveRecord
+	}
+    }
+    testns::Table find foo bar
+} -cleanup {
+    namespace delete ::testns
+} -result {::testns::Table called with arguments: foo bar}
+test ooUtil-1.3 {TIP 478: classmethod must not interfere with constructor signatures} -setup {
+    oo::class create parent
+} -body {
+    oo::class create TestClass {
+        superclass oo::class parent
+        self method create {name ignore body} {
+            next $name $body
+        }
+    }
+    TestClass create okay {} {}
+} -cleanup {
+    parent destroy
+} -result {::okay}
+test ooUtil-1.4 {TIP 478: classmethod with several inheritance levels} -setup {
+    oo::class create parent
+} -body {
+    oo::class create ActiveRecord {
+	superclass parent
+        classmethod find args {
+	    return "[self] called with arguments: $args"
+	}
+    }
+    oo::class create Table {
+        superclass ActiveRecord
+    }
+    oo::class create SubTable {
+        superclass Table
+    }
+    SubTable find foo bar
+} -cleanup {
+    parent destroy
+} -result {::SubTable called with arguments: foo bar}
+test ooUtil-1.5 {TIP 478: classmethod and instances} -setup {
+    oo::class create parent
+} -body {
+    oo::class create ActiveRecord {
+	superclass parent
+        classmethod find args {
+	    return "[self] called with arguments: $args"
+	}
+    }
+    oo::class create Table {
+	superclass ActiveRecord
+    }
+    set t [Table new]
+    $t find 1 2 3
+} -cleanup {
+    parent destroy
+} -result {::Table called with arguments: 1 2 3}
+test ooUtil-1.6 {TIP 478: classmethod and instances} -setup {
+    oo::class create parent
+} -body {
+    oo::class create ActiveRecord {
+	superclass parent
+        classmethod find args {
+	    return "[self] called with arguments: $args"
+	}
+    }
+    oo::class create Table {
+	superclass ActiveRecord
+	unexport find
+    }
+    set t [Table new]
+    $t find 1 2 3
+} -returnCodes error -cleanup {
+    parent destroy
+} -match glob -result {unknown method "find": must be *}
+test ooUtil-1.7 {} -setup {
+    oo::class create parent
+} -body {
+    oo::class create Foo {
+	superclass parent
+        classmethod bar {} {
+            puts "This is in the class; self is [self]"
+            my meee
+        }
+        classmethod meee {} {
+            puts "This is meee"
+        }
+    }
+    oo::class create Grill {
+        superclass Foo
+        classmethod meee {} {
+            puts "This is meee 2"
+        }
+    }
+    list [Foo bar] [Grill bar] [[Foo new] bar] [[Grill new] bar]
+} -cleanup {
+    parent destroy
+} -result {{} {} {} {}} -output "This is in the class; self is ::Foo\nThis is meee\nThis is in the class; self is ::Grill\nThis is meee 2\nThis is in the class; self is ::Foo\nThis is meee\nThis is in the class; self is ::Grill\nThis is meee 2\n"
+# Two tests to confirm that we correctly initialise the scripted part of TclOO
+# in child interpreters. This is slightly tricky at the implementation level
+# because we cannot count on either [source] or [open] being available.
+test ooUtil-1.8 {TIP 478: classmethod in child interp} -setup {
+    set childinterp [interp create]
+} -body {
+    $childinterp eval {
+	oo::class create ActiveRecord {
+	    classmethod find args {
+		return "[self] called with arguments: $args"
+	    }
+	}
+	oo::class create Table {
+	    superclass ActiveRecord
+	}
+	# This is confirming that this is not the master interpreter
+	list [Table find foo bar] [info globals childinterp]
+    }
+} -cleanup {
+    interp delete $childinterp
+} -result {{::Table called with arguments: foo bar} {}}
+test ooUtil-1.9 {TIP 478: classmethod in safe child interp} -setup {
+    set safeinterp [interp create -safe]
+} -body {
+    $safeinterp eval {
+	oo::class create ActiveRecord {
+	    classmethod find args {
+		return "[self] called with arguments: $args"
+	    }
+	}
+	oo::class create Table {
+	    superclass ActiveRecord
+	}
+	# This is confirming that this is a (basic) safe interpreter
+	list [Table find foo bar] [info commands source]
+    }
+} -cleanup {
+    interp delete $safeinterp
+} -result {{::Table called with arguments: foo bar} {}}
+
+test ooUtil-2.1 {TIP 478: callback generation} -setup {
+    oo::class create parent
+} -body {
+    oo::class create c {
+	superclass parent
+	method CallMe {} { return ok,[self] }
+	method makeCall {} {
+	    return [callback CallMe]
+	}
+    }
+    c create ::context
+    set cb [context makeCall]
+    {*}$cb
+} -cleanup {
+    parent destroy
+} -result {ok,::context}
+test ooUtil-2.2 {TIP 478: callback generation} -setup {
+    oo::class create parent
+} -body {
+    oo::class create c {
+	superclass parent
+	method CallMe {a b c} { return ok,[self],$a,$b,$c }
+	method makeCall {b} {
+	    return [callback CallMe 123 $b]
+	}
+    }
+    c create ::context
+    set cb [context makeCall "a b c"]
+    {*}$cb PQR
+} -cleanup {
+    parent destroy
+} -result {ok,::context,123,a b c,PQR}
+test ooUtil-2.3 {TIP 478: callback generation, alternate name} -setup {
+    oo::class create parent
+} -body {
+    oo::class create c {
+	superclass parent
+	method CallMe {} { return ok,[self] }
+	method makeCall {} {
+	    return [mymethod CallMe]
+	}
+    }
+    c create ::context
+    set cb [context makeCall]
+    {*}$cb
+} -cleanup {
+    parent destroy
+} -result {ok,::context}
+test ooUtil-2.4 {TIP 478: callback generation, alternate name} -setup {
+    oo::class create parent
+} -body {
+    oo::class create c {
+	superclass parent
+	method CallMe {a b c} { return ok,[self],$a,$b,$c }
+	method makeCall {b} {
+	    return [mymethod CallMe 123 $b]
+	}
+    }
+    c create ::context
+    set cb [context makeCall "a b c"]
+    {*}$cb PQR
+} -cleanup {
+    parent destroy
+} -result {ok,::context,123,a b c,PQR}
+test ooUtil-2.5 {TIP 478: callbacks and method lifetime} -setup {
+    oo::class create parent
+} -body {
+    oo::class create c {
+	superclass parent
+	method makeCall {b} {
+	    return [callback CallMe 123 $b]
+	}
+    }
+    c create ::context
+    set cb [context makeCall "a b c"]
+    set result [list [catch {{*}$cb PQR} msg] $msg]
+    oo::objdefine context {
+	method CallMe {a b c} { return ok,[self],$a,$b,$c }
+    }
+    lappend result [{*}$cb PQR]
+} -cleanup {
+    parent destroy
+} -result {1 {unknown method "CallMe": must be <cloned>, destroy, eval, makeCall, unknown, variable or varname} {ok,::context,123,a b c,PQR}}
+test ooUtil-2.6 {TIP 478: callback use case} -setup {
+    oo::class create parent
+    unset -nocomplain x
+} -body {
+    oo::class create c {
+	superclass parent
+	variable count
+	constructor {var} {
+	    set count 0
+	    upvar 1 $var v
+	    trace add variable v write [callback TraceCallback]
+	}
+	method count {} {return $count}
+	method TraceCallback {name1 name2 op} {
+	    incr count
+	}
+    }
+    set o [c new x]
+    for {set x 0} {$x < 5} {incr x} {}
+    $o count
+} -cleanup {
+    unset -nocomplain x
+    parent destroy
+} -result 6
+
+test ooUtil-3.1 {TIP 478: class initialisation} -setup {
+    oo::class create parent
+    catch {rename ::foobar-3.1 {}}
+} -body {
+    oo::class create ::cls {
+	superclass parent
+	initialise {
+	    proc foobar-3.1 {} {return ok}
+	}
+	method calls {} {
+	    list [catch foobar-3.1 msg] $msg \
+		[namespace eval [info object namespace [self class]] foobar-3.1]
+	}
+    }
+    [cls new] calls
+} -cleanup {
+    parent destroy
+} -result {1 {invalid command name "foobar-3.1"} ok}
+test ooUtil-3.2 {TIP 478: class variables} -setup {
+    oo::class create parent
+    catch {rename ::foobar-3.1 {}}
+} -body {
+    oo::class create ::cls {
+	superclass parent
+	initialise {
+	    variable x 123
+	}
+	method call {} {
+	    classvariable x
+	    incr x
+	}
+    }
+    cls create a
+    cls create b
+    cls create c
+    list [a call] [b call] [c call] [a call] [b call] [c call]
+} -cleanup {
+    parent destroy
+} -result {124 125 126 127 128 129}
+test ooUtil-3.3 {TIP 478: class initialisation} -setup {
+    oo::class create parent
+    catch {rename ::foobar-3.3 {}}
+} -body {
+    oo::class create ::cls {
+	superclass parent
+	initialize {
+	    proc foobar-3.3 {} {return ok}
+	}
+	method calls {} {
+	    list [catch foobar-3.3 msg] $msg \
+		[namespace eval [info object namespace [self class]] foobar-3.3]
+	}
+    }
+    [cls new] calls
+} -cleanup {
+    parent destroy
+} -result {1 {invalid command name "foobar-3.3"} ok}
+test ooUtil-3.4 {TIP 478: class initialisation} -setup {
+    oo::class create parent
+    catch {rename ::appendToResultVar {}}
+    proc ::appendToResultVar args {
+	lappend ::result {*}$args
+    }
+    set result {}
+} -body {
+    trace add execution oo::define::initialise enter appendToResultVar
+    oo::class create ::cls {
+	superclass parent
+	initialize {proc xyzzy {} {}}
+    }
+    return $result
+} -cleanup {
+    catch {
+	trace remove execution oo::define::initialise enter appendToResultVar
+    }
+    rename ::appendToResultVar {}
+    parent destroy
+} -result {{initialize {proc xyzzy {} {}}} enter}
+test ooUtil-3.5 {TIP 478: class initialisation} -body {
+    oo::define oo::object {
+	::list [::namespace which initialise] [::namespace which initialize] \
+	     [::namespace origin initialise] [::namespace origin initialize]
+    }
+} -result {::oo::define::initialise ::oo::define::initialize ::oo::define::initialise ::oo::define::initialise}
+
+test ooUtil-4.1 {TIP 478: singleton} -setup {
+    oo::class create parent
+} -body {
+    oo::singleton create xyz {
+	superclass parent
+    }
+    set x [xyz new]
+    set y [xyz new]
+    set z [xyz new]
+    set code [catch {$x destroy} msg]
+    set p [xyz new]
+    lappend code [catch {rename $x ""}]
+    set q [xyz new]
+    string map [list $x ONE $q TWO] [list {*}$code $x $y $z $p $q [xyz new]]
+} -cleanup {
+    parent destroy
+} -result {1 0 ONE ONE ONE ONE TWO TWO}
+test ooUtil-4.2 {TIP 478: singleton errors} -setup {
+    oo::class create parent
+} -body {
+    oo::singleton create xyz {
+	superclass parent
+    }
+    [xyz new] destroy
+} -returnCodes error -cleanup {
+    parent destroy
+} -result {may not destroy a singleton object}
+test ooUtil-4.3 {TIP 478: singleton errors} -setup {
+    oo::class create parent
+} -body {
+    oo::singleton create xyz {
+	superclass parent
+    }
+    oo::copy [xyz new]
+} -returnCodes error -cleanup {
+    parent destroy
+} -result {may not clone a singleton object}
+
+
+test ooUtil-5.1 {TIP 478: abstract} -setup {
+    oo::class create parent
+} -body {
+    oo::abstract create xyz {
+	superclass parent
+	method foo {} {return 123}
+    }
+    oo::class create pqr {
+	superclass xyz
+	method bar {} {return 456}
+    }
+    set codes [list [catch {xyz new}] [catch {xyz create x}] [catch {xyz createWithNamespace x y}]]
+    set x [pqr new]
+    set y [pqr create ::y]
+    lappend codes [$x foo] [$x bar] $y
+} -cleanup {
+    parent destroy
+} -result {1 1 1 123 456 ::y}
+
+test ooUtil-6.1 {TIP 478: classvarable} -setup {
+    oo::class create parent
+} -body {
+    oo::class create xyz {
+	superclass parent
+	initialise {
+	    variable x 1 y 2
+	}
+	method a {} {
+	    classvariable x
+	    incr x
+	}
+	method b {} {
+	    classvariable y
+	    incr y
+	}
+	method c {} {
+	    classvariable x y
+	    list $x $y
+	}
+    }
+    set p [xyz new]
+    set q [xyz new]
+    set result [list [$p c] [$q c]]
+    $p a
+    $q b
+    lappend result [[xyz new] c]
+} -cleanup {
+    parent destroy
+} -result {{1 2} {1 2} {2 3}}
+test ooUtil-6.2 {TIP 478: classvarable error case} -setup {
+    oo::class create parent
+} -body {
+    oo::class create xyz {
+	superclass parent
+	method a {} {
+	    classvariable x(1)
+	    incr x(1)
+	}
+    }
+    set p [xyz new]
+    set q [xyz new]
+    list [$p a] [$q a]
+} -returnCodes error -cleanup {
+    parent destroy
+} -result {bad variable name "x(1)": can't create a scalar variable that looks like an array element}
+test ooUtil-6.3 {TIP 478: classvarable error case} -setup {
+    oo::class create parent
+} -body {
+    oo::class create xyz {
+	superclass parent
+	method a {} {
+	    classvariable ::x
+	    incr x
+	}
+    }
+    set p [xyz new]
+    set q [xyz new]
+    list [$p a] [$q a]
+} -returnCodes error -cleanup {
+    parent destroy
+} -result {bad variable name "::x": can't create a local variable with a namespace separator in it}
+
+test ooUtil-7.1 {TIP 478: link calling pattern} -setup {
+    oo::class create parent
+} -body {
+    oo::class create cls {
+	superclass parent
+	method foo {} {return "in foo of [self]"}
+	method Bar {} {return "in bar of [self]"}
+	method Grill {} {return "in grill of [self]"}
+	export eval
+	constructor {} {
+	    link foo
+	    link {bar Bar} {grill Grill}
+	}
+    }
+    cls create o
+    o eval {list [foo] [bar] [grill]}
+} -cleanup {
+    parent destroy
+} -result {{in foo of ::o} {in bar of ::o} {in grill of ::o}}
+test ooUtil-7.2 {TIP 478: link removed when [my] disappears} -setup {
+    oo::class create parent
+} -body {
+    oo::class create cls {
+	superclass parent
+	method foo {} {return "in foo of [self]"}
+	constructor {cmd} {
+	    link [list ::$cmd foo]
+	}
+    }
+    cls create o pqr
+    list [o foo] [pqr] [rename [info object namespace o]::my {}] [catch pqr msg] $msg
+} -cleanup {
+    parent destroy
+} -result {{in foo of ::o} {in foo of ::o} {} 1 {invalid command name "pqr"}}
+
+# Tests that verify issues detected with the tcllib version of the code
+test ooUtil-tcllib-ticket-b3577ed586 {test scoping of delegation in oo::class.Delegate } -setup {
+    oo::class create animal {}
+    namespace eval ::ooutiltest {
+	oo::class create pet { superclass animal }
+    }
+} -body {
+    namespace eval ::ooutiltest {
+	oo::class create dog { superclass pet }
+    }
+} -cleanup {
+    namespace delete ooutiltest
+    rename animal {}
+} -result {::ooutiltest::dog}
+test ooUtil-tcllib-ticket-fe7a0e0a3a {classmethod must not interfere with constructor signatures} -setup {
+    oo::class create TestClass {
+        superclass oo::class
+        self method create {name ignore body} {
+            next $name $body
+        }
+    }
+} -body {
+    TestClass create okay {} {}
+} -cleanup {
+    rename TestClass {}
+} -result {::okay}
+
+cleanupTests
+return
+
+# Local Variables:
+# fill-column: 78
+# mode: tcl
+# End: