Tcl Source Code

2011-06-13  Don Porter  <[email protected]>

	* generic/tclStrToD.c:  [Bug 3315098] Mem leak fix from Gustaf Neumann.

2011-06-08  Andreas Kupries  <[email protected]>

	* generic/tclExecute.c: Reverted the fix for [Bug 3274728]
	committed on 2011-04-06 and replaced with one which is
	64bit-safe. The existing fix crashed tclsh on Windows 64bit.

2011-06-08  Donal K. Fellows  <[email protected]>

	* tests/fileSystem.test: Reduce the amount of use of duplication of
	complex code to perform common tests, and convert others to do the
	test result check directly using Tcltest's own primitives.

2011-06-06  Jan Nijtmans  <[email protected]>

	* tests/socket.test: Add test constraint, so 6.2 and 6.3 don't fail
	when the machine does not have support for ip6. Follow-up to checkin
	from 2011-05-11 by rmax.

2011-06-02  Don Porter  <[email protected]>

	* generic/tclBasic.c:	Removed TclCleanupLiteralTable(), and old
	* generic/tclInt.h:	band-aid routine put in place while a fix
	* generic/tclLiteral.c:	for [Bug 994838] took shape.  No longer needed.

2011-06-02  Donal K. Fellows  <[email protected]>

	* generic/tclInt.h (TclInvalidateNsCmdLookup): [Bug 3185407]: Extend
	the set of epochs that are potentially bumped when a command is
	created, for a slight performance drop (in some circumstances) and
	improved semantics.

2011-06-01  Miguel Sofer  <[email protected]>

	* generic/tclBasic.c: Using the two free data elements in NRCommand to
	store objc and objv - useful for debugging.

2011-06-01  Jan Nijtmans  <[email protected]>

	* generic/tclUtil.c:   Fix for [Bug 3309871]: Valgrind finds:
	invalid read in TclMaxListLength()

2011-05-31  Don Porter  <[email protected]>

	* generic/tclInt.h:	Use a complete growth algorithm for lists
	* generic/tclListObj.c:	so that length limits do not overconstrain
	* generic/tclStringObj.c:	by a factor of 2.  [Bug 3293874]:
	* generic/tclUtil.c:	Fix includes rooting all growth routines
	by default on a commone tunable parameter TCL_MIN_GROWTH.

2011-05-25  Don Porter  <[email protected]>

	* library/msgcat/msgcat.tcl:	Bump to msgcat 1.4.4.
	* library/msgcat/pkgIndex.tcl:
	* unix/Makefile.in
	* win/Makefile.in

2011-05-25  Donal K. Fellows  <[email protected]>

	* generic/tclOO.h (TCLOO_VERSION): Bump version.

	IMPLEMENTATION OF TIP#381.

	* doc/next.n, doc/ooInfo.n, doc/self.n, generic/tclOO.c,
	* generic/tclOOBasic.c, generic/tclOOCall.c, generic/tclOOInfo.c,
	* generic/tclOOInt.h, tests/oo.test, tests/ooNext2.test: Added
	introspection of call chains ([self call], [info object call], [info
	class call]) and ability to skip ahead in chain ([nextto]).

2011-05-24  Venkat Iyer <[email protected]>

	* library/tzdata/Africa/Cairo: Update to Olson tzdata2011g

2011-05-24  Donal K. Fellows  <[email protected]>

	* library/msgcat/msgcat.tcl (msgcat::mcset, msgcat::mcmset): Remove
	some useless code; [dict set] builds dictionary levels for us.

2011-05-17  Andreas Kupries  <[email protected]>

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
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
.QW \fBunknown\fR
for the \fBunknown\fR type), a word giving the fully qualified name of the
class that defined the method, and a word describing the type of method
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.
.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 defintion is described as a two element list; the first
element is the list of arguments to the constructor in a form suitable for
passing to another call to \fBproc\fR or a method defintion, and the second

.VS 8.6
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).
.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
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
.QW \fBunknown\fR
for the \fBunknown\fR type), a word giving what defined the method (the fully
qualified name of the class, or the literal string \fBobject\fR if the method
implementation is on an instance), and a word describing the type of method
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.
.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.

puts [\fBinfo object class\fR c]
                     \fI\(-> prints "::oo::class"\fR
.CE
.PP
The introspection capabilities can be used to discover what class implements a
method and get how it is defined. This procedure illustrates how:
.PP
.CS
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 {
            return [\fBinfo class definition\fR $locus $name]
        }
    }
    error "no definition for $method"
}
.CE
.PP
This is an alternate way of implementing the definition lookup is by manually
scanning the list of methods up the inheritance tree. This code assumes that
only single inheritance is in use, and that there is no complex use of
mixed-in classes:
.PP
.CS
proc getDef {obj method} {
    if {$method in [\fBinfo object methods\fR $obj]} {
        # Assume no forwards
        return [\fBinfo object definition\fR $obj $method]
    }
    set cls [\fBinfo object class\fR $obj]

.SH NAME
next \- invoke superclass method implementations
.SH SYNOPSIS
.nf
package require TclOO

\fBnext\fR ?\fIarg ...\fR?
\fBnextto\fI class\fR ?\fIarg ...\fR?
.fi
.BE

.SH DESCRIPTION
.PP
The \fBnext\fR command is used to call implementations of a method by a class,
superclass or mixin that are overridden by the current method. It can only be
used from within a method. It is also used within filters to indicate the
point where a filter calls the actual implementation (the filter may decide to
not go along the chain, and may process the results of going along the chain
of methods as it chooses). The result of the \fBnext\fR command is the result
of the next method in the method chain; if there are no further methods in the
method chain, the result of \fBnext\fR will be an error. The arguments,
\fIarg\fR, to \fBnext\fR are the arguments to pass to the next method in the
chain.
.PP
The \fBnextto\fR command is the same as the \fBnext\fR command, except that it
takes an additional \fIclass\fR argument that identifies a class whose
implementation of the current method chain (see \fBinfo object call\fR) should
be used; the method implementation selected will be the one provided by the
given class, and it must refer to an existing non-filter invocation that lies
further along the chain than the current implementation.
.SH "THE METHOD CHAIN"
.PP
When a method of an object is invoked, things happen in several stages:
.IP [1]
The structure of the object, its class, superclasses, filters, and mixins, are
examined to build a \fImethod chain\fR, which contains a list of method
implementations to invoke.

The \fBself\fR command, which should only be used from within the context of a
call to a method (i.e. inside a method, constructor or destructor body) is
used to allow the method to discover information about how it was called. It
takes an argument, \fIsubcommand\fR, that tells it what sort of information is
actually desired; if omitted the result will be the same as if \fBself
object\fR was invoked. The supported subcommands are:
.TP
\fBself call\fR
.
This returns a two-element list describing the method implementations used to
implement the current call chain. The first element is the same as would be
reported by \fBinfo object call\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
list that indicates which actual implementation is currently executing (the
first implementation to execute is always at index 0).
.TP
\fBself caller\fR
.
When the method was invoked from inside another object method, this subcommand
returns a three element list describing the containing object and method. The
first element describes the declaring object or class of the method, the
second element is the name of the object on which the containing method was
invoked, and the third element is the name of the method (with the strings

    }
}
c create a
c create b
a foo                \fI\(-> prints "this is the ::a object"\fR
b foo                \fI\(-> prints "this is the ::b object"\fR
.CE
.PP
This demonstrates what a method call chain looks like, and how traversing
along it changes the index into it:
.PP
.CS
oo::class create c {
    method x {} {
        puts "Cls: [\fBself call\fR]"
    }
}
c create a
oo::objdefine a {
    method x {} {
        puts "Obj: [\fBself call\fR]"
        next
        puts "Obj: [\fBself call\fR]"
    }
}
a x     \fI\(-> Obj: {{method x object method} {method x ::c method}} 0\fR
        \fI\(-> Cls: {{method x object method} {method x ::c method}} 1\fR
        \fI\(-> Obj: {{method x object method} {method x ::c method}} 0\fR
.CE
.SH "SEE ALSO"
info(n), next(n)
.SH KEYWORDS
call, introspection, object
.\" Local variables:
.\" mode: nroff
.\" fill-column: 78
.\" End:

     * background errors occur here, they will be deleted below.
     *
     * Dismantle the namespace after freeing the iPtr->handle so that each
     * bytecode releases its literals without caring to update the literal
     * table, as it will be freed later in this function without further use.
     */


    TclHandleFree(iPtr->handle);
    TclTeardownNamespace(iPtr->globalNsPtr);

    /*
     * Delete all the hidden commands.
     */

     *
     * data[1] stores a marker for use by tailcalls; it will be set to 1 by
     * command redirectors (imports, alias, ensembles) so that tailcalls
     * finishes the source command and not just the target.
     */

    if (iPtr->evalFlags & TCL_EVAL_REDIRECT) {
	TclNRAddCallback(interp, NRCommand, NULL, INT2PTR(1), objc, objv);
	iPtr->evalFlags &= ~TCL_EVAL_REDIRECT;
    } else {
	TclNRAddCallback(interp, NRCommand, NULL, NULL, INT2PTR(objc), objv);
    }
    cmdPtrPtr = (Command **) &(TOP_CB(interp)->data[0]);

    TclNRSpliceDeferred(interp);

    iPtr->numLevels++;
    result = TclInterpReady(interp);

 * Minimal data required to fully reconstruct the execution state.
 */

typedef struct TEBCdata {
    ByteCode *codePtr;		/* Constant until the BC returns */
				/* -----------------------------------------*/
    const unsigned char *pc;	/* These fields are used on return TO this */
    ptrdiff_t *catchTop;	/* this level: they record the state when a */
    int cleanup;		/* new codePtr was received for NR */
    Tcl_Obj *auxObjList;	/* execution. */
    int checkInterp;
    CmdFrame cmdFrame;
    void * stack[1];            /* Start of the actual combined catch and obj
				 * stacks; the struct will be expanded as
				 * necessary */

 *
 * Side effects:
 *	Almost certainly, depending on the ByteCode's instructions.
 *
 *----------------------------------------------------------------------
 */
#define	bcFramePtr	(&TD->cmdFrame)
#define	initCatchTop	((ptrdiff_t *) (&TD->stack[-1]))
#define	initTosPtr	((Tcl_Obj **) (initCatchTop+codePtr->maxExceptDepth))
#define esPtr           (iPtr->execEnvPtr->execStackPtr)

int
TclNRExecuteByteCode(
    Tcl_Interp *interp,		/* Token for command interpreter. */
    ByteCode *codePtr)		/* The bytecode sequence to interpret. */

	/*
	 * Clear all expansions that may have started after the last
	 * INST_BEGIN_CATCH.
	 */

	while (auxObjList) {
	    if ((catchTop != initCatchTop) &&
		(*catchTop > ((ptrdiff_t) auxObjList->internalRep.ptrAndLongRep.value))) {
		break;
	    }
	    POP_TAUX_OBJ();
	}

	/*
	 * We must not catch if the script in progress has been canceled with

				 * all.*/
    Tcl_Obj *elements;		/* First list element; the struct is grown to
				 * accomodate all elements. */
} List;

#define LIST_MAX \
	(1 + (int)(((size_t)UINT_MAX - sizeof(List))/sizeof(Tcl_Obj *)))
#define LIST_SIZE(numElems) \
	(unsigned)(sizeof(List) + (((numElems) - 1) * sizeof(Tcl_Obj *)))

/*
 * Macro used to get the elements of a list object.
 */

#define ListRepPtr(listPtr) \
    ((List *) (listPtr)->internalRep.twoPtrValue.ptr1)

MODULE_SCOPE int	TclCheckBadOctal(Tcl_Interp *interp,
			    const char *value);
MODULE_SCOPE int	TclChanCaughtErrorBypass(Tcl_Interp *interp,
			    Tcl_Channel chan);
MODULE_SCOPE Tcl_ObjCmdProc TclChannelNamesCmd;
MODULE_SCOPE int	TclClearRootEnsemble(ClientData data[],
			    Tcl_Interp *interp, int result);


MODULE_SCOPE ContLineLoc *TclContinuationsEnter(Tcl_Obj *objPtr, int num,
			    int *loc);
MODULE_SCOPE void	TclContinuationsEnterDerived(Tcl_Obj *objPtr,
			    int start, int *clNext);
MODULE_SCOPE ContLineLoc *TclContinuationsGet(Tcl_Obj *objPtr);
MODULE_SCOPE void	TclContinuationsCopy(Tcl_Obj *objPtr,
			    Tcl_Obj *originObjPtr);

 * MODULE_SCOPE void	TclGrowTokenArray(Tcl_Token *tokenPtr, int used,
 *				int available, int append,
 *				Tcl_Token *staticPtr);
 * MODULE_SCOPE void	TclGrowParseTokenArray(Tcl_Parse *parsePtr,
 *				int append);
 *----------------------------------------------------------------
 */

/* General tuning for minimum growth in Tcl growth algorithms */
#ifndef TCL_MIN_GROWTH
#  ifdef TCL_GROWTH_MIN_ALLOC
     /* Support for any legacy tuners */
#    define TCL_MIN_GROWTH TCL_GROWTH_MIN_ALLOC
#  else
#    define TCL_MIN_GROWTH 1024
#  endif
#endif

/* Token growth tuning, default to the general value. */
#ifndef TCL_MIN_TOKEN_GROWTH
#define TCL_MIN_TOKEN_GROWTH TCL_MIN_GROWTH/sizeof(Tcl_Token)
#endif

#define TCL_MAX_TOKENS (int)(UINT_MAX / sizeof(Tcl_Token))
#define TclGrowTokenArray(tokenPtr, used, available, append, staticPtr)	\
    do {								\
	int needed = (used) + (append);					\
	if (needed > TCL_MAX_TOKENS) {					\
	    Tcl_Panic("max # of tokens for a Tcl parse (%d) exceeded",	\
		    TCL_MAX_TOKENS);					\
	}								\

 * the result of Tcl_UtfToUniChar. The ANSI C "prototype" for this macro is:
 *
 * MODULE_SCOPE int	TclUtfToUniChar(const char *string, Tcl_UniChar *ch);
 *----------------------------------------------------------------
 */

#define TclUtfToUniChar(str, chPtr) \
	((((unsigned char) *(str)) < 0xC0) ?		\
	    ((*(chPtr) = (Tcl_UniChar) *(str)), 1)	\
	    : Tcl_UtfToUniChar(str, chPtr))

/*
 *----------------------------------------------------------------
 * Macro counterpart of the Tcl_NumUtfChars() function. To be used in speed-
 * -sensitive points where it pays to avoid a function call in the common case
 * of counting along a string of all one-byte characters.  The ANSI C

 * counter. The ANSI C "prototype" for this macro is:
 *
 * MODULE_SCOPE void	TclInvalidateNsCmdLookup(Namespace *nsPtr);
 *----------------------------------------------------------------
 */

#define TclInvalidateNsCmdLookup(nsPtr) \
    if ((nsPtr)->numExportPatterns) {		\
	(nsPtr)->exportLookupEpoch++;		\
    }						\
    if ((nsPtr)->commandPathLength) {		\
	(nsPtr)->cmdRefEpoch++;			\
    }

/*
 *----------------------------------------------------------------------
 *
 * Core procedures added to libtommath for bignum manipulation.
 *

const Tcl_ObjType tclListType = {
    "list",			/* name */
    FreeListInternalRep,	/* freeIntRepProc */
    DupListInternalRep,		/* dupIntRepProc */
    UpdateStringOfList,		/* updateStringProc */
    SetListFromAny		/* setFromAnyProc */
};

#ifndef TCL_MIN_ELEMENT_GROWTH
#define TCL_MIN_ELEMENT_GROWTH TCL_MIN_GROWTH/sizeof(Tcl_Obj *)
#endif


/*
 *----------------------------------------------------------------------
 *
 * NewListIntRep --
 *
 *	Creates a list internal rep with space for objc elements.  objc

	if (p) {
	    Tcl_Panic("max length of a Tcl list (%d elements) exceeded",
		    LIST_MAX);
	}
	return NULL;
    }

    listRepPtr = attemptckalloc(LIST_SIZE(objc));
    if (listRepPtr == NULL) {
	if (p) {
	    Tcl_Panic("list creation failed: unable to alloc %u bytes",
		    LIST_SIZE(objc));
	}
	return NULL;
    }

    listRepPtr->canonicalFlag = 0;
    listRepPtr->refCount = 0;
    listRepPtr->maxElemCount = objc;

	if (objc > LIST_MAX) {
	    Tcl_SetObjResult(interp, Tcl_ObjPrintf(
		    "max length of a Tcl list (%d elements) exceeded",
		    LIST_MAX));
	} else {
	    Tcl_SetObjResult(interp, Tcl_ObjPrintf(
		    "list creation failed: unable to alloc %u bytes",
		    LIST_SIZE(objc)));
	}
	Tcl_SetErrorCode(interp, "TCL", "MEMORY", NULL);
    }
    return listRepPtr;
}

/*

}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_ListObjAppendList --
 *
 *	This function appends the elements in the list value referenced by
 *	elemListPtr to the list value referenced by listPtr.


 *
 * Results:
 *	The return value is normally TCL_OK. If listPtr or elemListPtr do not
 *	refer to list values, TCL_ERROR is returned and an error message is
 *	left in the interpreter's result if interp is not NULL.

 *
 * Side effects:
 *	The reference counts of the elements in elemListPtr are incremented
 *	since the list now refers to them. listPtr and elemListPtr are
 *	converted, if necessary, to list objects. Also, appending the new
 *	elements may cause listObj's array of element pointers to grow.
 *	listPtr's old string representation, if any, is invalidated.
 *
 *----------------------------------------------------------------------
 */

int
Tcl_ListObjAppendList(
    Tcl_Interp *interp,		/* Used to report errors if not NULL. */
    register Tcl_Obj *listPtr,	/* List object to append elements to. */
    Tcl_Obj *elemListPtr)	/* List obj with elements to append. */
{
    int objc;
    Tcl_Obj **objv;

    if (Tcl_IsShared(listPtr)) {
	Tcl_Panic("%s called with shared object", "Tcl_ListObjAppendList");
    }





    /* Pull the elements to append from elemListPtr */
    if (TCL_OK != TclListObjGetElements(interp, elemListPtr, &objc, &objv)) {

	return TCL_ERROR;
    }

    /*
     * Insert the new elements starting after the lists's last element.
     * Delete zero existing elements.
     */

    return Tcl_ListObjReplace(interp, listPtr, LIST_MAX, 0, objc, objv);
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_ListObjAppendElement --
 *

int
Tcl_ListObjAppendElement(
    Tcl_Interp *interp,		/* Used to report errors if not NULL. */
    Tcl_Obj *listPtr,		/* List object to append objPtr to. */
    Tcl_Obj *objPtr)		/* Object to append to listPtr's list. */
{
    register List *listRepPtr, *newPtr = NULL;

    int numElems, numRequired, needGrow, isShared, attempt;

    if (Tcl_IsShared(listPtr)) {
	Tcl_Panic("%s called with shared object", "Tcl_ListObjAppendElement");
    }
    if (listPtr->typePtr != &tclListType) {
	int result;

	if (listPtr->bytes == tclEmptyStringRep) {
	    Tcl_SetListObj(listPtr, 1, &objPtr);
	    return TCL_OK;
	}
	result = SetListFromAny(interp, listPtr);
	if (result != TCL_OK) {
	    return result;
	}
    }

    listRepPtr = ListRepPtr(listPtr);
    numElems = listRepPtr->elemCount;
    numRequired = numElems + 1 ;
    needGrow = (numRequired > listRepPtr->maxElemCount);
    isShared = (listRepPtr->refCount > 1);



    if (numRequired > LIST_MAX) {
	if (interp != NULL) {

	    Tcl_SetObjResult(interp, Tcl_ObjPrintf(
		    "max length of a Tcl list (%d elements) exceeded",
		    LIST_MAX));
	    Tcl_SetErrorCode(interp, "TCL", "MEMORY", NULL);
	}
	return TCL_ERROR;
    }

    if (needGrow && !isShared) {
	/* Need to grow + unshared intrep => try to realloc */
	attempt = 2 * numRequired;
	if (attempt <= LIST_MAX) {
	    newPtr = attemptckrealloc(listRepPtr, LIST_SIZE(attempt));
	}
	if (newPtr == NULL) {

	    attempt = numRequired + 1 + TCL_MIN_ELEMENT_GROWTH;
	    if (attempt > LIST_MAX) {
		attempt = LIST_MAX;
	    }
	    newPtr = attemptckrealloc(listRepPtr, LIST_SIZE(attempt));
	}
	if (newPtr == NULL) {
	    attempt = numRequired;
	    newPtr = attemptckrealloc(listRepPtr, LIST_SIZE(attempt));
	}
	if (newPtr) {
	    listRepPtr = newPtr;
	    listRepPtr->maxElemCount = attempt;
	    needGrow = 0;
	}
    }
    if (isShared || needGrow) {
	Tcl_Obj **dst, **src = &listRepPtr->elements;

	/*
	 * Either we have a shared intrep and we must copy to write,
	 * or we need to grow and realloc attempts failed.
	 * Attempt intrep copy.
	 */
	attempt = 2 * numRequired;
	newPtr = AttemptNewList(NULL, attempt, NULL);
	if (newPtr == NULL) {
	    attempt = numRequired + 1 + TCL_MIN_ELEMENT_GROWTH;
	    if (attempt > LIST_MAX) {
		attempt = LIST_MAX;
	    }
	    newPtr = AttemptNewList(NULL, attempt, NULL);
	}
	if (newPtr == NULL) {
	    attempt = numRequired;
	    newPtr = AttemptNewList(interp, attempt, NULL);
	}
	if (newPtr == NULL) {
	    /* All growth attempts failed; throw the error */
	    return TCL_ERROR;
	}

	dst = &newPtr->elements;
	newPtr->refCount++;
	newPtr->canonicalFlag = listRepPtr->canonicalFlag;
	newPtr->elemCount = listRepPtr->elemCount;

	if (isShared) {
	    /*
	     * The original intrep must remain undisturbed.
	     * Copy into the new one and bump refcounts
	     */
	    while (numElems--) {
		*dst = *src++;
		Tcl_IncrRefCount(*dst++);
	    }


	    listRepPtr->refCount--;
	} else {
	    /* Old intrep to be freed, re-use refCounts */
	    memcpy(dst, src, (size_t) numElems * sizeof(Tcl_Obj *));

	    ckfree(listRepPtr);
	}
	listRepPtr = newPtr;
    }
    listPtr->internalRep.twoPtrValue.ptr1 = listRepPtr;

    /*
     * Add objPtr to the end of listPtr's array of element pointers. Increment
     * the ref count for the (now shared) objPtr.
     */

    *(&listRepPtr->elements + listRepPtr->elemCount) = objPtr;

    Tcl_IncrRefCount(objPtr);
    listRepPtr->elemCount++;

    /*
     * Invalidate any old string representation since the list's internal
     * representation has changed.
     */

	if (numRequired > listRepPtr->maxElemCount){
	    newMax = 2 * numRequired;
	} else {
	    newMax = listRepPtr->maxElemCount;
	}

	listRepPtr = AttemptNewList(NULL, newMax, NULL);
	if (listRepPtr == NULL) {
	    unsigned int limit = LIST_MAX - numRequired;
	    unsigned int extra = numRequired - numElems
		    + TCL_MIN_ELEMENT_GROWTH;
	    int growth = (int) ((extra > limit) ? limit : extra);

	    listRepPtr = AttemptNewList(NULL, numRequired + growth, NULL);
	    if (listRepPtr == NULL) {
		listRepPtr = AttemptNewList(interp, numRequired, NULL);
		if (listRepPtr == NULL) {
		    return TCL_ERROR;
		}
	    }
	}

	listPtr->internalRep.twoPtrValue.ptr1 = listRepPtr;
	listRepPtr->refCount++;

	elemPtrs = &listRepPtr->elements;

	if (result != TCL_OK) {
	    return result;
	}
    }

    listRepPtr = ListRepPtr(listPtr);
    elemCount = listRepPtr->elemCount;


    /*
     * Ensure that the index is in bounds.
     */

    if (index<0 || index>=elemCount) {
	if (interp != NULL) {
	    Tcl_SetObjResult(interp,
		    Tcl_NewStringObj("list index out of range", -1));
	    Tcl_SetErrorCode(interp, "TCL", "OPERATION", "LSET", "BADINDEX",
		    NULL);
	}
	return TCL_ERROR;
    }

    /*
     * If the internal rep is shared, replace it with an unshared copy.
     */

    if (listRepPtr->refCount > 1) {
	Tcl_Obj **dst, **src = &listRepPtr->elements;
	List *newPtr = AttemptNewList(NULL, listRepPtr->maxElemCount, NULL);


	if (newPtr == NULL) {
	    newPtr = AttemptNewList(interp, elemCount, NULL);
	    if (newPtr == NULL) {
		return TCL_ERROR;
	    }
	}
	newPtr->refCount++;
	newPtr->elemCount = elemCount;
	newPtr->canonicalFlag = listRepPtr->canonicalFlag;

	dst = &newPtr->elements;
	while (elemCount--) {
	    *dst = *src++;
	    Tcl_IncrRefCount(*dst++);
	}

	listRepPtr->refCount--;

	listPtr->internalRep.twoPtrValue.ptr1 = listRepPtr = newPtr;

    }
    elemPtrs = &listRepPtr->elements;

    /*
     * Add a reference to the new list element.
     */

    Tcl_IncrRefCount(valuePtr);

    tablePtr->staticBuckets[0] = tablePtr->staticBuckets[1] = 0;
    tablePtr->staticBuckets[2] = tablePtr->staticBuckets[3] = 0;
    tablePtr->numBuckets = TCL_SMALL_HASH_TABLE;
    tablePtr->numEntries = 0;
    tablePtr->rebuildSize = TCL_SMALL_HASH_TABLE * REBUILD_MULTIPLIER;
    tablePtr->mask = 3;
}








































































/*
 *----------------------------------------------------------------------
 *
 * TclDeleteLiteralTable --
 *
 *	This function frees up everything associated with a literal table

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

    Tcl_CreateObjCommand(interp, "::oo::Helpers::next", TclOONextObjCmd, NULL,
	    NULL);
    Tcl_CreateObjCommand(interp, "::oo::Helpers::nextto", TclOONextToObjCmd,
	    NULL, NULL);
    Tcl_CreateObjCommand(interp, "::oo::Helpers::self", TclOOSelfObjCmd, NULL,
	    NULL);
    Tcl_CreateObjCommand(interp, "::oo::define", TclOODefineObjCmd, NULL,
	    NULL);
    Tcl_CreateObjCommand(interp, "::oo::objdefine", TclOOObjDefObjCmd, NULL,
	    NULL);
    Tcl_CreateObjCommand(interp, "::oo::copy", TclOOCopyObjectCmd, NULL,NULL);

 * version in the files:
 *
 * tests/oo.test
 * unix/tclooConfig.sh
 * win/tclooConfig.sh
 */

#define TCLOO_VERSION "0.6.3"
#define TCLOO_PATCHLEVEL TCLOO_VERSION

/*
 * These are opaque types.
 */

typedef struct Tcl_Class_ *Tcl_Class;

    Tcl_SetObjResult(interp, varNamePtr);
    return TCL_OK;
}

/*
 * ----------------------------------------------------------------------
 *
 * TclOONextObjCmd, TclOONextToObjCmd --
 *
 *	Implementation of the [next] and [nextto] commands. Note that these
 *	commands are only ever to be used inside the body of a procedure-like
 *	method.
 *
 * ----------------------------------------------------------------------
 */

int
TclOONextObjCmd(
    ClientData clientData,

     * that this is like [uplevel 1] and not [eval].
     */

    TclNRAddCallback(interp, RestoreFrame, framePtr, NULL, NULL, NULL);
    iPtr->varFramePtr = framePtr->callerVarPtr;
    return TclNRObjectContextInvokeNext(interp, context, objc, objv, 1);
}

int
TclOONextToObjCmd(
    ClientData clientData,
    Tcl_Interp *interp,
    int objc,
    Tcl_Obj *const *objv)
{
    Interp *iPtr = (Interp *) interp;
    CallFrame *framePtr = iPtr->varFramePtr;
    Class *classPtr;
    CallContext *contextPtr;
    int i;
    Tcl_Object object;

    /*
     * Start with sanity checks on the calling context to make sure that we
     * are invoked from a suitable method context. If so, we can safely
     * retrieve the handle to the object call context.
     */

    if (framePtr == NULL || !(framePtr->isProcCallFrame & FRAME_IS_METHOD)) {
	Tcl_AppendResult(interp, TclGetString(objv[0]),
		" may only be called from inside a method", NULL);
	Tcl_SetErrorCode(interp, "TCL", "OO", "CONTEXT_REQUIRED", NULL);
	return TCL_ERROR;
    }
    contextPtr = framePtr->clientData;

    /*
     * Sanity check the arguments; we need the first one to refer to a class.
     */

    if (objc < 2) {
	Tcl_WrongNumArgs(interp, 1, objv, "class ?arg...?");
	return TCL_ERROR;
    }
    object = Tcl_GetObjectFromObj(interp, objv[1]);
    if (object == NULL) {
	return TCL_ERROR;
    }
    classPtr = ((Object *)object)->classPtr;
    if (classPtr == NULL) {
	Tcl_AppendResult(interp, "\"", TclGetString(objv[1]),
		"\" is not a class", NULL);
	return TCL_ERROR;
    }

    /*
     * Search for an implementation of a method associated with the current
     * call on the call chain past the point where we currently are. Do not
     * allow jumping backwards!
     */

    for (i=contextPtr->index+1 ; i<contextPtr->callPtr->numChain ; i++) {
	struct MInvoke *miPtr = contextPtr->callPtr->chain + i;

	if (!miPtr->isFilter && miPtr->mPtr->declaringClassPtr == classPtr) {
	    /*
	     * Invoke the (advanced) method call context in the caller
	     * context. Note that this is like [uplevel 1] and not [eval].
	     */

	    TclNRAddCallback(interp, RestoreFrame, framePtr, contextPtr,
		    INT2PTR(contextPtr->index), NULL);
	    contextPtr->index = i-1;
	    iPtr->varFramePtr = framePtr->callerVarPtr;
	    return TclNRObjectContextInvokeNext(interp,
		    (Tcl_ObjectContext) contextPtr, objc, objv, 2);
	}
    }

    /*
     * Generate an appropriate error message, depending on whether the value
     * is on the chain but unreachable, or not on the chain at all.
     */

    for (i=contextPtr->index ; i>=0 ; i--) {
	struct MInvoke *miPtr = contextPtr->callPtr->chain + i;

	if (!miPtr->isFilter && miPtr->mPtr->declaringClassPtr == classPtr) {
	    Tcl_AppendResult(interp, "method implementation by \"",
		    TclGetString(objv[1]), "\" not reachable from here",
		    NULL);
	    return TCL_ERROR;
	}
    }
    Tcl_AppendResult(interp, "method has no non-filter implementation by \"",
	    TclGetString(objv[1]), "\"", NULL);
    return TCL_ERROR;
}

static int
RestoreFrame(
    ClientData data[],
    Tcl_Interp *interp,
    int result)
{
    Interp *iPtr = (Interp *) interp;
    CallContext *contextPtr = data[1];

    iPtr->varFramePtr = data[0];
    if (contextPtr != NULL) {
	contextPtr->index = PTR2INT(data[2]);
    }
    return result;
}

/*
 * ----------------------------------------------------------------------
 *
 * TclOOSelfObjCmd --

TclOOSelfObjCmd(
    ClientData clientData,
    Tcl_Interp *interp,
    int objc,
    Tcl_Obj *const *objv)
{
    static const char *const subcmds[] = {
	"call", "caller", "class", "filter", "method", "namespace", "next",
	"object", "target", NULL
    };
    enum SelfCmds {
	SELF_CALL, SELF_CALLER, SELF_CLASS, SELF_FILTER, SELF_METHOD, SELF_NS,
	SELF_NEXT, SELF_OBJECT, SELF_TARGET
    };
    Interp *iPtr = (Interp *) interp;
    CallFrame *framePtr = iPtr->varFramePtr;
    CallContext *contextPtr;
    Tcl_Obj *result[3];
    int index;

#define CurrentlyInvoked(contextPtr) \
    ((contextPtr)->callPtr->chain[(contextPtr)->index])

    /*
     * Start with sanity checks on the calling context and the method context.

    case SELF_FILTER:
	if (!CurrentlyInvoked(contextPtr).isFilter) {
	    Tcl_AppendResult(interp, "not inside a filtering context", NULL);
	    Tcl_SetErrorCode(interp, "TCL", "OO", "UNMATCHED_CONTEXT", NULL);
	    return TCL_ERROR;
	} else {
	    register struct MInvoke *miPtr = &CurrentlyInvoked(contextPtr);

	    Object *oPtr;
	    const char *type;

	    if (miPtr->filterDeclarer != NULL) {
		oPtr = miPtr->filterDeclarer->thisPtr;
		type = "class";
	    } else {

	    Tcl_AppendResult(interp, "caller is not an object", NULL);
	    Tcl_SetErrorCode(interp, "TCL", "OO", "CONTEXT_REQUIRED", NULL);
	    return TCL_ERROR;
	} else {
	    CallContext *callerPtr = framePtr->callerVarPtr->clientData;
	    Method *mPtr = callerPtr->callPtr->chain[callerPtr->index].mPtr;
	    Object *declarerPtr;


	    if (mPtr->declaringClassPtr != NULL) {
		declarerPtr = mPtr->declaringClassPtr->thisPtr;
	    } else if (mPtr->declaringObjectPtr != NULL) {
		declarerPtr = mPtr->declaringObjectPtr;
	    } else {
		/*

	    return TCL_OK;
	}
    case SELF_NEXT:
	if (contextPtr->index < contextPtr->callPtr->numChain-1) {
	    Method *mPtr =
		    contextPtr->callPtr->chain[contextPtr->index+1].mPtr;
	    Object *declarerPtr;


	    if (mPtr->declaringClassPtr != NULL) {
		declarerPtr = mPtr->declaringClassPtr->thisPtr;
	    } else if (mPtr->declaringObjectPtr != NULL) {
		declarerPtr = mPtr->declaringObjectPtr;
	    } else {
		/*

	if (!CurrentlyInvoked(contextPtr).isFilter) {
	    Tcl_AppendResult(interp, "not inside a filtering context", NULL);
	    Tcl_SetErrorCode(interp, "TCL", "OO", "UNMATCHED_CONTEXT", NULL);
	    return TCL_ERROR;
	} else {
	    Method *mPtr;
	    Object *declarerPtr;

	    int i;

	    for (i=contextPtr->index ; i<contextPtr->callPtr->numChain ; i++){
		if (!contextPtr->callPtr->chain[i].isFilter) {
		    break;
		}
	    }

		return TCL_ERROR;
	    }
	    result[0] = TclOOObjectName(interp, declarerPtr);
	    result[1] = mPtr->namePtr;
	    Tcl_SetObjResult(interp, Tcl_NewListObj(2, result));
	    return TCL_OK;
	}
    case SELF_CALL:
	result[0] = TclOORenderCallChain(interp, contextPtr->callPtr);
	result[1] = Tcl_NewIntObj(contextPtr->index);
	Tcl_SetObjResult(interp, Tcl_NewListObj(2, result));
	return TCL_OK;
    }
    return TCL_ERROR;
}

/*
 * ----------------------------------------------------------------------
 *

void
TclOODeleteContext(
    CallContext *contextPtr)
{
    register Object *oPtr = contextPtr->oPtr;

    TclOODeleteChain(contextPtr->callPtr);
    if (oPtr != NULL) {
	TclStackFree(oPtr->fPtr->interp, contextPtr);
	DelRef(oPtr);
    }
}

/*
 * ----------------------------------------------------------------------
 *
 * TclOODeleteChainCache --
 *

    contextPtr->index = 0;
    return contextPtr;
}

/*
 * ----------------------------------------------------------------------
 *
 * TclOOGetStereotypeCallChain --
 *
 *	Construct a call-chain for a method that would be used by a
 *	stereotypical instance of the given class (i.e., where the object has
 *	no definitions special to itself).
 *
 * ----------------------------------------------------------------------
 */

CallChain *
TclOOGetStereotypeCallChain(
    Class *clsPtr,		/* The object to get the context for. */
    Tcl_Obj *methodNameObj,	/* The name of the method to get the context
				 * for. NULL when getting a constructor or
				 * destructor chain. */
    int flags)			/* What sort of context are we looking for.
				 * Only the bits PUBLIC_METHOD, CONSTRUCTOR,
				 * PRIVATE_METHOD, DESTRUCTOR and
				 * FILTER_HANDLING are useful. */
{
    CallChain *callPtr;
    struct ChainBuilder cb;
    int i, count;
    Foundation *fPtr = clsPtr->thisPtr->fPtr;
    Tcl_HashEntry *hPtr;
    Tcl_HashTable doneFilters;
    Object obj;

    /*
     * Synthesize a temporary stereotypical object so that we can use existing
     * machinery to produce the stereotypical call chain.
     */

    memset(&obj, 0, sizeof(Object));
    obj.fPtr = fPtr;
    obj.selfCls = clsPtr;
    obj.refCount = 1;
    obj.flags = USE_CLASS_CACHE;

    /*
     * Check if we can get the chain out of the Tcl_Obj method name or out of
     * the cache. This is made a bit more complex by the fact that there are
     * multiple different layers of cache (in the Tcl_Obj, in the object, and
     * in the class).
     */

    if (clsPtr->classChainCache != NULL) {
	hPtr = Tcl_FindHashEntry(clsPtr->classChainCache,
		(char *) methodNameObj);
	if (hPtr != NULL && Tcl_GetHashValue(hPtr) != NULL) {
	    const int reuseMask =
		    ((flags & PUBLIC_METHOD) ? ~0 : ~PUBLIC_METHOD);

	    callPtr = Tcl_GetHashValue(hPtr);
	    if (IsStillValid(callPtr, &obj, flags, reuseMask)) {
		callPtr->refCount++;
		return callPtr;
	    }
	    Tcl_SetHashValue(hPtr, NULL);
	    TclOODeleteChain(callPtr);
	}
    } else {
	hPtr = NULL;
    }

    callPtr = (CallChain *) ckalloc(sizeof(CallChain));
    memset(callPtr, 0, sizeof(CallChain));
    callPtr->flags = flags & (PUBLIC_METHOD|PRIVATE_METHOD|FILTER_HANDLING);
    callPtr->epoch = fPtr->epoch;
    callPtr->objectCreationEpoch = fPtr->tsdPtr->nsCount;
    callPtr->objectEpoch = clsPtr->thisPtr->epoch;
    callPtr->refCount = 1;
    callPtr->chain = callPtr->staticChain;

    cb.callChainPtr = callPtr;
    cb.filterLength = 0;
    cb.oPtr = &obj;

    /*
     * Add all defined filters (if any, and if we're going to be processing
     * them; they're not processed for constructors, destructors or when we're
     * in the middle of processing a filter).
     */

    Tcl_InitObjHashTable(&doneFilters);
    AddClassFiltersToCallContext(&obj, clsPtr, &cb, &doneFilters);
    Tcl_DeleteHashTable(&doneFilters);
    count = cb.filterLength = callPtr->numChain;

    /*
     * Add the actual method implementations.
     */

    AddSimpleChainToCallContext(&obj, methodNameObj, &cb, NULL, flags, NULL);

    /*
     * Check to see if the method has no implementation. If so, we probably
     * need to add in a call to the unknown method. Otherwise, set up the
     * cacheing of the method implementation (if relevant).
     */

    if (count == callPtr->numChain) {
	AddSimpleChainToCallContext(&obj, fPtr->unknownMethodNameObj, &cb,
		NULL, 0, NULL);
	callPtr->flags |= OO_UNKNOWN_METHOD;
	callPtr->epoch = -1;
	if (count == callPtr->numChain) {
	    TclOODeleteChain(callPtr);
	    return NULL;
	}
    } else {
	if (hPtr == NULL) {
	    if (clsPtr->classChainCache == NULL) {
		clsPtr->classChainCache = (Tcl_HashTable *)
			ckalloc(sizeof(Tcl_HashTable));

		Tcl_InitObjHashTable(clsPtr->classChainCache);
	    }
	    hPtr = Tcl_CreateHashEntry(clsPtr->classChainCache,
		    (char *) methodNameObj, &i);
	}
	callPtr->refCount++;
	Tcl_SetHashValue(hPtr, callPtr);
	StashCallChain(methodNameObj, callPtr);
    }
    return callPtr;
}

/*
 * ----------------------------------------------------------------------
 *
 * AddClassFiltersToCallContext --
 *
 *	Logic to make extracting all the filters from the class context much
 *	easier.
 *
 * ----------------------------------------------------------------------
 */

	    AddSimpleClassChainToCallContext(superPtr, methodNameObj, cbPtr,
		    doneFilters, flags, filterDecl);
	}
    case 0:
	return;
    }
}

/*
 * ----------------------------------------------------------------------
 *
 * TclOORenderCallChain --
 *
 *	Create a description of a call chain. Used in [info object call],
 *	[info class call], and [self call].
 *
 * ----------------------------------------------------------------------
 */

Tcl_Obj *
TclOORenderCallChain(
    Tcl_Interp *interp,
    CallChain *callPtr)
{
    Tcl_Obj *filterLiteral, *methodLiteral, *objectLiteral;
    Tcl_Obj *resultObj, *descObjs[4], **objv;
    Foundation *fPtr = TclOOGetFoundation(interp);
    int i;

    /*
     * Allocate the literals (potentially) used in our description.
     */

    filterLiteral = Tcl_NewStringObj("filter", -1);
    Tcl_IncrRefCount(filterLiteral);
    methodLiteral = Tcl_NewStringObj("method", -1);
    Tcl_IncrRefCount(methodLiteral);
    objectLiteral = Tcl_NewStringObj("object", -1);
    Tcl_IncrRefCount(objectLiteral);

    /*
     * Do the actual construction of the descriptions. They consist of a list
     * of triples that describe the details of how a method is understood. For
     * each triple, the first word is the type of invokation ("method" is
     * normal, "unknown" is special because it adds the method name as an
     * extra argument when handled by some method types, and "filter" is
     * special because it's a filter method). The second word is the name of
     * the method in question (which differs for "unknown" and "filter" types)
     * and the third word is the full name of the class that declares the
     * method (or "object" if it is declared on the instance).
     */

    objv = TclStackAlloc(interp, callPtr->numChain * sizeof(Tcl_Obj *));
    for (i=0 ; i<callPtr->numChain ; i++) {
	struct MInvoke *miPtr = &callPtr->chain[i];

	descObjs[0] = miPtr->isFilter
		? filterLiteral
		: callPtr->flags & OO_UNKNOWN_METHOD
			? fPtr->unknownMethodNameObj
			: methodLiteral;
	descObjs[1] = callPtr->flags & CONSTRUCTOR
		? fPtr->constructorName
		: callPtr->flags & DESTRUCTOR
			? fPtr->destructorName
			: miPtr->mPtr->namePtr;
	descObjs[2] = miPtr->mPtr->declaringClassPtr
		? Tcl_GetObjectName(interp,
			(Tcl_Object) miPtr->mPtr->declaringClassPtr->thisPtr)
		: objectLiteral;
	descObjs[3] = Tcl_NewStringObj(miPtr->mPtr->typePtr->name, -1);

	objv[i] = Tcl_NewListObj(4, descObjs);
	Tcl_IncrRefCount(objv[i]);
    }

    /*
     * Drop the local references to the literals; if they're actually used,
     * they'll live on the description itself.
     */

    Tcl_DecrRefCount(filterLiteral);
    Tcl_DecrRefCount(methodLiteral);
    Tcl_DecrRefCount(objectLiteral);

    /*
     * Finish building the description and return it.
     */

    resultObj = Tcl_NewListObj(callPtr->numChain, objv);
    TclStackFree(interp, objv);
    return resultObj;
}

/*
 * Local Variables:
 * mode: c
 * c-basic-offset: 4
 * fill-column: 78
 * End:
 */

#ifdef HAVE_CONFIG_H
#include "config.h"
#endif
#include "tclInt.h"
#include "tclOOInt.h"

static inline Class *	GetClassFromObj(Tcl_Interp *interp, Tcl_Obj *objPtr);
static Tcl_ObjCmdProc InfoObjectCallCmd;
static Tcl_ObjCmdProc InfoObjectClassCmd;
static Tcl_ObjCmdProc InfoObjectDefnCmd;
static Tcl_ObjCmdProc InfoObjectFiltersCmd;
static Tcl_ObjCmdProc InfoObjectForwardCmd;
static Tcl_ObjCmdProc InfoObjectIsACmd;
static Tcl_ObjCmdProc InfoObjectMethodsCmd;
static Tcl_ObjCmdProc InfoObjectMethodTypeCmd;
static Tcl_ObjCmdProc InfoObjectMixinsCmd;
static Tcl_ObjCmdProc InfoObjectNsCmd;
static Tcl_ObjCmdProc InfoObjectVarsCmd;
static Tcl_ObjCmdProc InfoObjectVariablesCmd;
static Tcl_ObjCmdProc InfoClassCallCmd;
static Tcl_ObjCmdProc InfoClassConstrCmd;
static Tcl_ObjCmdProc InfoClassDefnCmd;
static Tcl_ObjCmdProc InfoClassDestrCmd;
static Tcl_ObjCmdProc InfoClassFiltersCmd;
static Tcl_ObjCmdProc InfoClassForwardCmd;
static Tcl_ObjCmdProc InfoClassInstancesCmd;
static Tcl_ObjCmdProc InfoClassMethodsCmd;
static Tcl_ObjCmdProc InfoClassMethodTypeCmd;
static Tcl_ObjCmdProc InfoClassMixinsCmd;
static Tcl_ObjCmdProc InfoClassSubsCmd;
static Tcl_ObjCmdProc InfoClassSupersCmd;
static Tcl_ObjCmdProc InfoClassVariablesCmd;

struct NameProcMap { const char *name; Tcl_ObjCmdProc *proc; };

/*
 * List of commands that are used to implement the [info object] subcommands.
 */

static const struct NameProcMap infoObjectCmds[] = {
    {"::oo::InfoObject::call",		InfoObjectCallCmd},
    {"::oo::InfoObject::class",		InfoObjectClassCmd},
    {"::oo::InfoObject::definition",	InfoObjectDefnCmd},
    {"::oo::InfoObject::filters",	InfoObjectFiltersCmd},
    {"::oo::InfoObject::forward",	InfoObjectForwardCmd},
    {"::oo::InfoObject::isa",		InfoObjectIsACmd},
    {"::oo::InfoObject::methods",	InfoObjectMethodsCmd},
    {"::oo::InfoObject::methodtype",	InfoObjectMethodTypeCmd},
    {"::oo::InfoObject::mixins",	InfoObjectMixinsCmd},
    {"::oo::InfoObject::namespace",	InfoObjectNsCmd},
    {"::oo::InfoObject::variables",	InfoObjectVariablesCmd},
    {"::oo::InfoObject::vars",		InfoObjectVarsCmd},
    {NULL, NULL}
};

/*
 * List of commands that are used to implement the [info class] subcommands.
 */

static const struct NameProcMap infoClassCmds[] = {
    {"::oo::InfoClass::call",		InfoClassCallCmd},
    {"::oo::InfoClass::constructor",	InfoClassConstrCmd},
    {"::oo::InfoClass::definition",	InfoClassDefnCmd},
    {"::oo::InfoClass::destructor",	InfoClassDestrCmd},
    {"::oo::InfoClass::filters",	InfoClassFiltersCmd},
    {"::oo::InfoClass::forward",	InfoClassForwardCmd},
    {"::oo::InfoClass::instances",	InfoClassInstancesCmd},
    {"::oo::InfoClass::methods",	InfoClassMethodsCmd},

    resultObj = Tcl_NewObj();
    FOREACH(variableObj, clsPtr->variables) {
	Tcl_ListObjAppendElement(NULL, resultObj, variableObj);
    }
    Tcl_SetObjResult(interp, resultObj);
    return TCL_OK;
}

/*
 * ----------------------------------------------------------------------
 *
 * InfoObjectCallCmd --
 *
 *	Implements [info object call $objName $methodName]
 *
 * ----------------------------------------------------------------------
 */

static int
InfoObjectCallCmd(
    ClientData clientData,
    Tcl_Interp *interp,
    int objc,
    Tcl_Obj *const objv[])
{
    Object *oPtr;
    CallContext *contextPtr;

    if (objc != 3) {
	Tcl_WrongNumArgs(interp, 1, objv, "objName methodName");
	return TCL_ERROR;
    }
    oPtr = (Object *) Tcl_GetObjectFromObj(interp, objv[1]);
    if (oPtr == NULL) {
	return TCL_ERROR;
    }

    /*
     * Get the call context and render its call chain.
     */

    contextPtr = TclOOGetCallContext(oPtr, objv[2], PUBLIC_METHOD, NULL);
    if (contextPtr == NULL) {
	Tcl_AppendResult(interp, "cannot construct any call chain", NULL);
	return TCL_ERROR;
    }
    Tcl_SetObjResult(interp,
	    TclOORenderCallChain(interp, contextPtr->callPtr));
    TclOODeleteContext(contextPtr);
    return TCL_OK;
}

/*
 * ----------------------------------------------------------------------
 *
 * InfoClassCallCmd --
 *
 *	Implements [info class call $clsName $methodName]
 *
 * ----------------------------------------------------------------------
 */

static int
InfoClassCallCmd(
    ClientData clientData,
    Tcl_Interp *interp,
    int objc,
    Tcl_Obj *const objv[])
{
    Class *clsPtr;
    CallChain *callPtr;

    if (objc != 3) {
	Tcl_WrongNumArgs(interp, 1, objv, "className methodName");
	return TCL_ERROR;
    }
    clsPtr = GetClassFromObj(interp, objv[1]);
    if (clsPtr == NULL) {
	return TCL_ERROR;
    }

    /*
     * Get an render the stereotypical call chain.
     */

    callPtr = TclOOGetStereotypeCallChain(clsPtr, objv[2], PUBLIC_METHOD);
    if (callPtr == NULL) {
	Tcl_AppendResult(interp, "cannot construct any call chain", NULL);
	return TCL_ERROR;
    }
    Tcl_SetObjResult(interp, TclOORenderCallChain(interp, callPtr));
    return TCL_OK;
}

/*
 * Local Variables:
 * mode: c
 * c-basic-offset: 4
 * fill-column: 78
 * End:
 */

			    Tcl_Interp *interp, int objc,
			    Tcl_Obj *const *objv);
MODULE_SCOPE int	TclOOCopyObjectCmd(ClientData clientData,
			    Tcl_Interp *interp, int objc,
			    Tcl_Obj *const *objv);
MODULE_SCOPE int	TclOONextObjCmd(ClientData clientData,
			    Tcl_Interp *interp, int objc,
			    Tcl_Obj *const *objv);
MODULE_SCOPE int	TclOONextToObjCmd(ClientData clientData,
			    Tcl_Interp *interp, int objc,
			    Tcl_Obj *const *objv);
MODULE_SCOPE int	TclOOSelfObjCmd(ClientData clientData,
			    Tcl_Interp *interp, int objc,
			    Tcl_Obj *const *objv);

/*
 * Method implementations (in tclOOBasic.c).

MODULE_SCOPE void	TclOODeleteChain(CallChain *callPtr);
MODULE_SCOPE void	TclOODeleteChainCache(Tcl_HashTable *tablePtr);
MODULE_SCOPE void	TclOODeleteContext(CallContext *contextPtr);
MODULE_SCOPE void	TclOODelMethodRef(Method *method);
MODULE_SCOPE CallContext *TclOOGetCallContext(Object *oPtr,
			    Tcl_Obj *methodNameObj, int flags,
			    Tcl_Obj *cacheInThisObj);
MODULE_SCOPE CallChain *TclOOGetStereotypeCallChain(Class *clsPtr,
			    Tcl_Obj *methodNameObj, int flags);
MODULE_SCOPE Foundation	*TclOOGetFoundation(Tcl_Interp *interp);
MODULE_SCOPE Tcl_Obj *	TclOOGetFwdFromMethod(Method *mPtr);
MODULE_SCOPE Proc *	TclOOGetProcFromMethod(Method *mPtr);
MODULE_SCOPE Tcl_Obj *	TclOOGetMethodBody(Method *mPtr);
MODULE_SCOPE int	TclOOGetSortedClassMethodList(Class *clsPtr,
			    int flags, const char ***stringsPtr);
MODULE_SCOPE int	TclOOGetSortedMethodList(Object *oPtr, int flags,

			    int objc, Tcl_Obj *const objv[]);
MODULE_SCOPE Tcl_Obj *	TclOOObjectName(Tcl_Interp *interp, Object *oPtr);
MODULE_SCOPE void	TclOORemoveFromInstances(Object *oPtr, Class *clsPtr);
MODULE_SCOPE void	TclOORemoveFromMixinSubs(Class *subPtr,
			    Class *mixinPtr);
MODULE_SCOPE void	TclOORemoveFromSubclasses(Class *subPtr,
			    Class *superPtr);
MODULE_SCOPE Tcl_Obj *	TclOORenderCallChain(Tcl_Interp *interp,
			    CallChain *callPtr);
MODULE_SCOPE void	TclOOStashContext(Tcl_Obj *objPtr,
			    CallContext *contextPtr);
MODULE_SCOPE void	TclOOSetupVariableResolver(Tcl_Namespace *nsPtr);
MODULE_SCOPE int	TclOOUpcatchCmd(ClientData ignored,
			    Tcl_Interp *interp, int objc,
			    Tcl_Obj *const objv[]);


     * Endgame - store the location of the decimal point and the end of the
     * string.
     */

    if (m2plus > m2minus) {
	mp_clear(&mplus);
    }
    mp_clear_multi(&b, &mminus, &temp, &dig, &S, NULL);
    *s = '\0';
    *decpt = k;
    if (endPtr) {
	*endPtr = s;
    }
    return retval;
}

 * TCL STRING GROWTH ALGORITHM
 *
 * When growing strings (during an append, for example), the following growth
 * algorithm is used:
 *
 *   Attempt to allocate 2 * (originalLength + appendLength)
 *   On failure:
 *	attempt to allocate originalLength + 2*appendLength + TCL_MIN_GROWTH

 *
 * This algorithm allows very good performance, as it rapidly increases the
 * memory allocated for a given string, which minimizes the number of
 * reallocations that must be performed. However, using only the doubling
 * algorithm can lead to a significant waste of memory. In particular, it may
 * fail even when there is sufficient memory available to complete the append
 * request (but there is not 2*totalLength memory available). So when the
 * doubling fails (because there is not enough memory available), the
 * algorithm requests a smaller amount of memory, which is still enough to
 * cover the request, but which hopefully will be less than the total
 * available memory.
 *
 * The addition of TCL_MIN_GROWTH allows for efficient handling of very
 * small appends. Without this extra slush factor, a sequence of several small
 * appends would cause several memory allocations. As long as
 * TCL_MIN_GROWTH is a reasonable size, we can avoid that behavior.
 *
 * The growth algorithm can be tuned by adjusting the following parameters:
 *
 * TCL_MIN_GROWTH		Additional space, in bytes, to allocate when
 *				the double allocation has failed. Default is
 *				1024 (1 kilobyte).  See tclInt.h.
 */

#ifndef TCL_MIN_UNICHAR_GROWTH
#define TCL_MIN_UNICHAR_GROWTH	TCL_MIN_GROWTH/sizeof(Tcl_UniChar)
#endif

static void
GrowStringBuffer(
    Tcl_Obj *objPtr,
    int needed,
    int flag)

	if (ptr == NULL) {
	    /*
	     * Take care computing the amount of modest growth to avoid
	     * overflow into invalid argument values for attempt.
	     */

	    unsigned int limit = INT_MAX - needed;
	    unsigned int extra = needed - objPtr->length + TCL_MIN_GROWTH;
	    int growth = (int) ((extra > limit) ? limit : extra);

	    attempt = needed + growth;
	    ptr = attemptckrealloc(objPtr->bytes, attempt + 1);
	}
    }
    if (ptr == NULL) {

	    /*
	     * Take care computing the amount of modest growth to avoid
	     * overflow into invalid argument values for attempt.
	     */

	    unsigned int limit = STRING_MAXCHARS - needed;
	    unsigned int extra = needed - stringPtr->numChars
		    + TCL_MIN_UNICHAR_GROWTH;
	    int growth = (int) ((extra > limit) ? limit : extra);

	    attempt = needed + growth;
	    ptr = stringAttemptRealloc(stringPtr, attempt);
	}
    }
    if (ptr == NULL) {

	if (TclIsSpaceProc(*bytes)) {
	    /* Space run started; bump count */
	    count++;
	    do {
		bytes++;
		numBytes -= (numBytes != -1);
	    } while (numBytes && TclIsSpaceProc(*bytes));
	    if ((numBytes == 0) || ((numBytes == -1) && (*bytes == '\0'))) {
		break;
	    }
	    /* (*bytes) is non-space; return to counting state */
	}
	bytes++;
	numBytes -= (numBytes != -1);
    }

	}
	Tcl_GetStringFromObj(objPtr, &length);
	if (length > 0) {
	    break;
	}
    }
    if (i == objc) {



	resPtr = NULL;
	for (i = 0;  i < objc;  i++) {









	    objPtr = objv[i];
	    if (objPtr->bytes && objPtr->length == 0) {
		continue;
	    }


	    if (resPtr) {
		Tcl_ListObjAppendList(NULL, resPtr, objPtr);
	    } else {
		resPtr = TclListObjCopy(NULL, objPtr);

	    }
	}
	if (!resPtr) {
	    resPtr = Tcl_NewObj();
	}
	return resPtr;
    }

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

package require Tcl 8.5
# When the version number changes, be sure to update the pkgIndex.tcl file,
# and the installation directory in the Makefiles.
package provide msgcat 1.4.4

namespace eval msgcat {
    namespace export mc mcload mclocale mcmax mcmset mcpreferences mcset \
	    mcunknown

    # Records the current locale as passed to mclocale
    variable Locale ""

if {![package vsatisfies [package provide Tcl] 8.5]} {return}
package ifneeded msgcat 1.4.4 [list source [file join $dir msgcat.tcl]]

    {1219957200 7200 0 EET}
    {1240524000 10800 1 EEST}
    {1250802000 7200 0 EET}
    {1272578400 10800 1 EEST}
    {1281474000 7200 0 EET}
    {1284069600 10800 1 EEST}
    {1285880400 7200 0 EET}


















































































































































































}

cd [tcltest::temporaryDirectory]
makeFile "test file" gorp.file
makeDirectory dir.dir
makeDirectory [file join dir.dir dirinside.dir]
makeFile "test file in directory" [file join dir.dir inside.file]

testConstraint unusedDrive 0
testConstraint moreThanOneDrive 0
apply {{} {
    # The variables 'drive' and 'drives' will be used below.
    variable drive {} drives {}
    if {[testConstraint win]} {
	set vols [string map [list :/ {}] [file volumes]]
	for {set i 0} {$i < 26} {incr i} {
	    set drive [format %c [expr {$i + 65}]]
	    if {$drive ni $vols} {
		testConstraint unusedDrive 1
		break
	    }
	}







	set dir [pwd]
	try {
	    foreach vol [file volumes] {
		if {![catch {cd $vol}]} {
		    lappend drives $vol
		}
	    }

	    testConstraint moreThanOneDrive [llength $drives]
	} finally {


	    cd $dir

	}
    }
} ::tcl::test::fileSystem}

proc testPathEqual {one two} {
    if {$one eq $two} {
	return "ok"


    }
    return "not equal: $one $two"
}

testConstraint hasLinks [expr {![catch {
    file link link.file gorp.file
    cd dir.dir
    file link \
	[file join linkinside.file] \

} {0}
test filesystem-1.1 {link normalisation} {hasLinks} {
   string equal [file normalize dir.dir] [file normalize dir.link]
} {0}
test filesystem-1.2 {link normalisation} {hasLinks unix} {
    testPathEqual [file normalize [file join gorp.file foo]] \
	[file normalize [file join link.file foo]]
} ok
test filesystem-1.3 {link normalisation} {hasLinks} {
    testPathEqual [file normalize [file join dir.dir foo]] \
	[file normalize [file join dir.link foo]]
} ok
test filesystem-1.4 {link normalisation} {hasLinks} {
    testPathEqual [file normalize [file join dir.dir inside.file]] \
	[file normalize [file join dir.link inside.file]]
} ok
test filesystem-1.5 {link normalisation} {hasLinks} {
    testPathEqual [file normalize [file join dir.dir linkinside.file]] \
	[file normalize [file join dir.dir linkinside.file]]
} ok
test filesystem-1.6 {link normalisation} {hasLinks} {
    string equal [file normalize [file join dir.dir linkinside.file]] \
	[file normalize [file join dir.link inside.file]]
} {0}
test filesystem-1.7 {link normalisation} {hasLinks unix} {
    testPathEqual [file normalize [file join dir.link linkinside.file foo]] \
	[file normalize [file join dir.dir inside.file foo]]
} ok
test filesystem-1.8 {link normalisation} {hasLinks} {
    string equal [file normalize [file join dir.dir linkinside.filefoo]] \
	[file normalize [file join dir.link inside.filefoo]]
} {0}
test filesystem-1.9 {link normalisation} -setup {
    file delete -force dir.link
} -constraints {unix hasLinks} -body {
    file link dir.link [file nativename dir.dir]
    testPathEqual [file normalize [file join dir.dir linkinside.file foo]] \
	[file normalize [file join dir.link inside.file foo]]
} -result ok
test filesystem-1.10 {link normalisation: double link} {unix hasLinks} {
    file link dir2.link dir.link
    testPathEqual [file normalize [file join dir.dir linkinside.file foo]] \
	[file normalize [file join dir2.link inside.file foo]]
} ok
makeDirectory dir2.file
test filesystem-1.11 {link normalisation: double link, back in tree} {unix hasLinks} {
    file link [file join dir2.file dir2.link] [file join .. dir2.link]
    testPathEqual [file normalize [file join dir.dir linkinside.file foo]] \
	[file normalize [file join dir2.file dir2.link inside.file foo]]
} ok
test filesystem-1.12 {file new native path} {} {
    for {set i 0} {$i < 10} {incr i} {
	foreach f [lsort [glob -nocomplain -type l *]] {
	    catch {file readlink $f}
	}
    }
    # If we reach here we've succeeded. We used to crash above.

} "${drive}:/a"
test filesystem-1.25 {file normalisation} {win unusedDrive} {
    file normalize ${drive}:/./.././../../a
} "${drive}:/a"
test filesystem-1.25.1 {file normalisation} {win unusedDrive} {
    file normalize ${drive}:/./.././..\\..\\a\\bb
} "${drive}:/a/bb"
test filesystem-1.26 {link normalisation: link and ..} -setup {
    file delete -force dir2.link
} -constraints {hasLinks} -body {
    set dir [file join dir2 foo bar]
    file mkdir $dir
    file link dir2.link [file join dir2 foo bar]
    testPathEqual [file normalize [file join dir2 foo x]] \
	    [file normalize [file join dir2.link .. x]]

} -result ok
test filesystem-1.27 {file normalisation: up and down with ..} {
    set dir [file join dir2 foo bar]
    file mkdir $dir
    set dir2 [file join dir2 .. dir2 foo .. foo bar]
    list [testPathEqual [file normalize $dir] [file normalize $dir2]] \
	[file exists $dir] [file exists $dir2]





} {ok 1 1}
test filesystem-1.28 {link normalisation: link with .. and ..} -setup {
    file delete -force dir2.link
} -constraints {hasLinks} -body {
    set dir [file join dir2 foo bar]
    file mkdir $dir
    set to [file join dir2 .. dir2 foo .. foo bar]
    file link dir2.link $to
    testPathEqual [file normalize [file join dir2 foo x]] \
	    [file normalize [file join dir2.link .. x]]

} -result ok
test filesystem-1.29 {link normalisation: link with ..} -setup {
    file delete -force dir2.link
} -constraints {hasLinks} -body {
    set dir [file join dir2 foo bar]
    file mkdir $dir
    set to [file join dir2 .. dir2 foo .. foo bar]
    file link dir2.link $to
    set res [file normalize [file join dir2.link x yyy z]]
    if {[string match *..* $res]} {
	return "$res must not contain '..'"
    }
    return "ok"
} -result {ok}
test filesystem-1.29.1 {link normalisation with two consecutive links} {hasLinks} {
    testPathEqual [file normalize [file join dir.link dirinside.link abc]] \
	[file normalize [file join dir.dir dirinside.dir abc]]
} ok
file delete -force dir2.file
file delete -force dir2.link
file delete -force link.file dir.link
file delete -force dir2
file delete -force [file join dir.dir dirinside.link]
removeFile [file join dir.dir inside.file]
removeDirectory [file join dir.dir dirinside.dir]

	regexp {C:/bar$} $res res
    }
    set res
} {C:/bar}
if {[testConstraint testsetplatform]} {
    testsetplatform $platform
}
test filesystem-1.34 {file normalisation with '/./'} -body {
    file normalize /foo/bar/anc/./.tml





} -match regexp -result {^(?:(?!/\./).)*$}

test filesystem-1.35a {file normalisation with '/./'} -body {
    file normalize /ffo/bar/anc/./foo/.tml

} -match regexp -result {^(?:(?!/\./).)*$}
test filesystem-1.35b {file normalisation with '/./'} {
    llength [regexp -all foo [file normalize /ffo/bar/anc/./foo/.tml]]


} 1


test filesystem-1.36a {file normalisation with '/./'} -body {
    file normalize /foo/bar/anc/././asdasd/.tml

} -match regexp -result {^(?:(?!/\./).)*$}
test filesystem-1.36b {file normalisation with '/./'} {
    llength [regexp -all asdasd [file normalize /foo/bar/anc/././asdasd/.tml]]


} 1


test filesystem-1.37 {file normalisation with '/./'} -body {
    set fname "/abc/./def/./ghi/./asda/.././.././asd/x/../../../../....."
    file norm $fname





} -match regexp -result {^(?:[^/]|/(?:[^/]|$))+$}

test filesystem-1.38 {file normalisation with volume relative} -setup {
    set dir [pwd]
} -constraints {win moreThanOneDrive} -body {
    set path "[string range [lindex $drives 0] 0 1]foo"

    cd [lindex $drives 1]
    file norm $path
} -cleanup {
    cd $dir

} -result "[lindex $drives 0]foo"
test filesystem-1.39 {file normalisation with volume relative} -setup {
    set old [pwd]
} -constraints {win} -body {
    set drv C:/
    cd [lindex [glob -type d -dir $drv *] 0]


    file norm [string range $drv 0 1]
} -cleanup {
    cd $old



} -match glob -result {*[^/]}


test filesystem-1.40 {file normalisation with repeated separators} {
    testPathEqual [file norm foo////bar] [file norm foo/bar]





} ok

test filesystem-1.41 {file normalisation with repeated separators} {win} {
    testPathEqual [file norm foo\\\\\\bar] [file norm foo/bar]





} ok

test filesystem-1.42 {file normalisation .. beyond root (Bug 1379287)} {
    testPathEqual [file norm /xxx/..] [file norm /]





} ok

test filesystem-1.42.1 {file normalisation .. beyond root (Bug 1379287)} {
    testPathEqual [file norm /xxx/../] [file norm /]





} ok

test filesystem-1.43 {file normalisation .. beyond root (Bug 1379287)} {
    testPathEqual [file norm /xxx/foo/../..] [file norm /]





} ok

test filesystem-1.43.1 {file normalisation .. beyond root (Bug 1379287)} {
    testPathEqual [file norm /xxx/foo/../../] [file norm /]





} ok

test filesystem-1.44 {file normalisation .. beyond root (Bug 1379287)} {
    testPathEqual [file norm /xxx/foo/../../bar] [file norm /bar]





} ok

test filesystem-1.45 {file normalisation .. beyond root (Bug 1379287)} {
    testPathEqual [file norm /xxx/../../bar] [file norm /bar]





} ok

test filesystem-1.46 {file normalisation .. beyond root (Bug 1379287)} {
    testPathEqual [file norm /xxx/../bar] [file norm /bar]





} ok

test filesystem-1.47 {file normalisation .. beyond root (Bug 1379287)} {
    testPathEqual [file norm /..] [file norm /]





} ok

test filesystem-1.48 {file normalisation .. beyond root (Bug 1379287)} {
    testPathEqual [file norm /../] [file norm /]





} ok

test filesystem-1.49 {file normalisation .. beyond root (Bug 1379287)} {
    testPathEqual [file norm /.] [file norm /]





} ok

test filesystem-1.50 {file normalisation .. beyond root (Bug 1379287)} {
    testPathEqual [file norm /./] [file norm /]





} ok

test filesystem-1.51 {file normalisation .. beyond root (Bug 1379287)} {
    testPathEqual [file norm /../..] [file norm /]





} ok

test filesystem-1.51.1 {file normalisation .. beyond root (Bug 1379287)} {
    testPathEqual [file norm /../../] [file norm /]





} ok


test filesystem-2.0 {new native path} {unix} {
   foreach f [lsort [glob -nocomplain /usr/bin/c*]] {
       catch {file readlink $f}
   }
   # If we reach here we've succeeded. We used to crash above.
   return ok
} ok

# Make sure the testfilesystem hasn't been registered.
if {[testConstraint testfilesystem]} {
    while {![catch {testfilesystem 0}]} {}
}

test filesystem-3.1 {Tcl_FSRegister & Tcl_FSUnregister} testfilesystem {

} {native}

test filesystem-4.0 {testfilesystem} -constraints testfilesystem -body {
    testfilesystem 1
    set filesystemReport {}
    file exists foo
    testfilesystem 0
    return $filesystemReport
} -match glob -result {*{access foo}}
test filesystem-4.1 {testfilesystem} -constraints testfilesystem -body {
    testfilesystem 1
    set filesystemReport {}
    catch {file stat foo bar}
    testfilesystem 0
    return $filesystemReport
} -match glob -result {*{stat foo}}
test filesystem-4.2 {testfilesystem} -constraints testfilesystem -body {
    testfilesystem 1
    set filesystemReport {}
    catch {file lstat foo bar}
    testfilesystem 0
    return $filesystemReport
} -match glob -result {*{lstat foo}}
test filesystem-4.3 {testfilesystem} -constraints testfilesystem -body {
    testfilesystem 1
    set filesystemReport {}
    catch {glob *}
    testfilesystem 0
    return $filesystemReport
} -match glob -result {*{matchindirectory *}*}

test filesystem-5.1 {cache and ~} -constraints testfilesystem -setup {
    set orig $::env(HOME)
} -body {
    set ::env(HOME) /foo/bar/blah
    set testdir ~

    file delete -force tilde
    cd $origdir
} -result {0 0 0 0 1}

# ----------------------------------------------------------------------

cleanupTests
unset -nocomplain drive drives
}
namespace delete ::tcl::test::fileSystem
return

# Local Variables:
# mode: tcl
# End:

	$d;[format %c 99]
    }
} -cleanup {
    namespace delete ::a
    catch {rename ::c {}}
    unset result
} -result {A 1 . A A . B B . B B . B B . B B . G G}
test namespace-51.18 {Bug 3185407} -setup {
    namespace eval ::test_ns_1 {}
} -body {
    namespace eval ::test_ns_1 {
	variable result {}
	namespace eval ns {proc foo {} {}}
	namespace eval ns2 {proc foo {} {}}
	namespace path {ns ns2}
	variable x foo
	lappend result [namespace which $x]
	proc foo {} {}
	lappend result [namespace which $x]
    }
} -cleanup {
    namespace delete ::test_ns_1
} -result {::test_ns_1::ns::foo ::test_ns_1::foo}

# TIP 181 - namespace unknown tests
test namespace-52.1 {unknown: default handler ::unknown} {
    set result [list [namespace eval foobar { namespace unknown }]]
    lappend result [namespace eval :: { namespace unknown }]
    namespace delete foobar
    set result

# This file contains a collection of tests for Tcl's built-in object system.
# Sourcing this file into Tcl runs the tests and generates output for errors.
# No output means no errors were found.
#
# Copyright (c) 2006-2008 Donal K. Fellows
#
# See the file "license.terms" for information on usage and redistribution of
# this file, and for a DISCLAIMER OF ALL WARRANTIES.

package require -exact TclOO 0.6.3 ;# Must match value in generic/tclOO.h
package require tcltest 2
if {"::tcltest" in [namespace children]} {
    namespace import -force ::tcltest::*
}

testConstraint memory [llength [info commands memory]]
if {[testConstraint memory]} {

    info object
} -returnCodes 1 -result "wrong \# args: should be \"info object subcommand ?arg ...?\""
test oo-16.2 {OO: object introspection} -body {
    info object class NOTANOBJECT
} -returnCodes 1 -result {NOTANOBJECT does not refer to an object}
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}
test oo-16.4 {OO: object introspection} -setup {
    oo::class create meta { superclass oo::class }
    [meta create instance1] create instance2
} -body {
    list [list [info object class oo::object] \
	      [info object class oo::class] \
	      [info object class meta] \

} -body {
    info class superclass foo
} -returnCodes 1 -cleanup {
    foo destroy
} -result {"foo" is not a class}
test oo-17.4 {OO: class introspection} -body {
    info class gorp oo::object
} -returnCodes 1 -result {unknown or ambiguous subcommand "gorp": must be call, constructor, definition, destructor, filters, forward, instances, methods, methodtype, mixins, subclasses, superclasses, or variables}
test oo-17.5 {OO: class introspection} -setup {
    oo::class create testClass
} -body {
    testClass create foo
    testClass create bar
    testClass create spong
    lsort [info class instances testClass]

# This file contains a collection of tests for Tcl's built-in object system.
# Sourcing this file into Tcl runs the tests and generates output for errors.
# No output means no errors were found.
#
# Copyright (c) 2006-2008 Donal K. Fellows
#
# See the file "license.terms" for information on usage and redistribution of
# this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
# RCS: @(#) $Id: oo.test,v 1.59 2011/01/18 16:10:48 dkf Exp $

package require -exact TclOO 0.6.3 ;# Must match value in configure.in
if {[lsearch [namespace children] ::tcltest] == -1} {
    package require tcltest 2
    namespace import -force ::tcltest::*
}

testConstraint memory [llength [info commands memory]]
if {[testConstraint memory]} {
    proc getbytes {} {
	set lines [split [memory info] \n]
	return [lindex $lines 3 3]
    }
    proc leaktest {script {iterations 3}} {
	set end [getbytes]
	for {set i 0} {$i < $iterations} {incr i} {
	    uplevel 1 $script
	    set tmp $end
	    set end [getbytes]
	}
	return [expr {$end - $tmp}]
    }
}

test oo-nextto-1.1 {basic nextto functionality} -setup {
    oo::class create root
} -body {
    oo::class create A {
	superclass root
	method x args {
	    lappend ::result ==A== $args
	}
    }
    oo::class create B {
	superclass A
	method x args {
	    lappend ::result ==B== $args
	    nextto A B -> A {*}$args
	}
    }
    oo::class create C {
	superclass A
	method x args {
	    lappend ::result ==C== $args
	    nextto A C -> A {*}$args
	}
    }
    oo::class create D {
	superclass B C
	method x args {
	    lappend ::result ==D== $args
	    next foo
	    nextto C bar
	}
    }
    set ::result {}
    [D new] x
    return $::result
} -cleanup {
    root destroy
} -result {==D== {} ==B== foo ==A== {B -> A foo} ==C== bar ==A== {C -> A bar}}
test oo-nextto-1.2 {basic nextto functionality} -setup {
    oo::class create root
} -body {
    oo::class create A {
	superclass root
	method x args {
	    lappend ::result ==A== $args
	}
    }
    oo::class create B {
	superclass A
	method x args {
	    lappend ::result ==B== $args
	    nextto A B -> A {*}$args
	}
    }
    oo::class create C {
	superclass A
	method x args {
	    lappend ::result ==C== $args
	    nextto A C -> A {*}$args
	}
    }
    oo::class create D {
	superclass B C
	method x args {
	    lappend ::result ==D== $args
	    nextto B foo {*}$args
	    nextto C bar {*}$args
	}
    }
    set ::result {}
    [D new] x 123
    return $::result
} -cleanup {
    root destroy
} -result {==D== 123 ==B== {foo 123} ==A== {B -> A foo 123} ==C== {bar 123} ==A== {C -> A bar 123}}
test oo-nextto-1.3 {basic nextto functionality: constructors} -setup {
    oo::class create root
} -body {
    oo::class create A {
	superclass root
	variable result
	constructor {a c} {
	    lappend result ==A== a=$a,c=$c
	}
    }
    oo::class create B {
	superclass root
	variable result
	constructor {b} {
	    lappend result ==B== b=$b
	}
    }
    oo::class create C {
	superclass A B
	variable result
	constructor {p q r} {
	    lappend result ==C== p=$p,q=$q,r=$r
	    # Route arguments to superclasses, in non-trival pattern
	    nextto B $q
	    nextto A $p $r
	}
	method result {} {return $result}
    }
    [C new x y z] result
} -cleanup {
    root destroy
} -result {==C== p=x,q=y,r=z ==B== b=y ==A== a=x,c=z}
test oo-nextto-1.4 {basic nextto functionality: destructors} -setup {
    oo::class create root {destructor return}
} -body {
    oo::class create A {
	superclass root
	destructor {
	    lappend ::result ==A==
	    next
	}
    }
    oo::class create B {
	superclass root
	destructor {
	    lappend ::result ==B==
	    next
	}
    }
    oo::class create C {
	superclass A B
	destructor {
	    lappend ::result ==C==
	    lappend ::result |
	    nextto B
	    lappend ::result |
	    nextto A
	    lappend ::result |
	    next
	}
    }
    set ::result ""
    [C new] destroy
    return $::result
} -cleanup {
    root destroy
} -result {==C== | ==B== | ==A== ==B== | ==A== ==B==}

test oo-nextto-2.1 {errors in nextto} -setup {
    oo::class create root
} -body {
    oo::class create A {
	superclass root
	method x y {error $y}
    }
    oo::class create B {
	superclass A
	method x y {nextto A $y}
    }
    [B new] x boom
} -cleanup {
    root destroy
} -result boom -returnCodes error
test oo-nextto-2.2 {errors in nextto} -setup {
    oo::class create root
} -body {
    oo::class create A {
	superclass root
	method x y {error $y}
    }
    oo::class create B {
	superclass root
	method x y {nextto A $y}
    }
    [B new] x boom
} -returnCodes error -cleanup {
    root destroy
} -result {method has no non-filter implementation by "A"}
test oo-nextto-2.3 {errors in nextto} -setup {
    oo::class create root
} -body {
    oo::class create A {
	superclass root
	method x y {nextto $y}
    }
    oo::class create B {
	superclass A
	method x y {nextto A $y}
    }
    [B new] x B
} -returnCodes error -cleanup {
    root destroy
} -result {method implementation by "B" not reachable from here}
test oo-nextto-2.4 {errors in nextto} -setup {
    oo::class create root
} -body {
    oo::class create A {
	superclass root
	method x y {nextto $y}
    }
    oo::class create B {
	superclass A
	method x y {nextto}
    }
    [B new] x B
} -returnCodes error -cleanup {
    root destroy
} -result {wrong # args: should be "nextto class ?arg...?"}
test oo-nextto-2.5 {errors in nextto} -setup {
    oo::class create root
} -body {
    oo::class create A {
	superclass root
	method x y {nextto $y}
    }
    oo::class create B {
	superclass A
	method x y {nextto $y $y $y}
    }
    [B new] x A
} -cleanup {
    root destroy
} -result {wrong # args: should be "nextto A y"} -returnCodes error
test oo-nextto-2.6 {errors in nextto} -setup {
    oo::class create root
} -body {
    oo::class create A {
	superclass root
	method x y {nextto $y}
    }
    oo::class create B {
	superclass A
	method x y {nextto $y $y $y}
    }
    [B new] x [root create notAClass]
} -cleanup {
    root destroy
} -result {"::notAClass" is not a class} -returnCodes error
test oo-nextto-2.7 {errors in nextto} -setup {
    oo::class create root
} -body {
    oo::class create A {
	superclass root
	method x y {nextto $y}
    }
    oo::class create B {
	superclass A
	filter Y
	method Y args {next {*}$args}
    }
    oo::class create C {
	superclass B
	method x y {nextto $y $y $y}
    }
    [C new] x B
} -returnCodes error -cleanup {
    root destroy
} -result {method has no non-filter implementation by "B"}

test oo-call-1.1 {object call introspection} -setup {
    oo::class create root
} -body {
    oo::class create ::A {
	superclass root
	method x {} {}
    }
    A create y
    info object call y x
} -cleanup {
    root destroy
} -result {{method x ::A method}}
test oo-call-1.2 {object call introspection} -setup {
    oo::class create root
} -body {
    oo::class create ::A {
	superclass root
	method x {} {}
    }
    oo::class create ::B {
	superclass A
	method x {} {}
    }
    B create y
    info object call y x
} -cleanup {
    root destroy
} -result {{method x ::B method} {method x ::A method}}
test oo-call-1.3 {object call introspection} -setup {
    oo::class create root
} -body {
    oo::class create ::A {
	superclass root
	method x {} {}
    }
    A create y
    oo::objdefine y method x {} {}
    info object call y x
} -cleanup {
    root destroy
} -result {{method x object method} {method x ::A method}}
test oo-call-1.4 {object object call introspection - unknown} -setup {
    oo::class create root
} -body {
    oo::class create ::A {
	superclass root
	method x {} {}
    }
    A create y
    info object call y z
} -cleanup {
    root destroy
} -result {{unknown unknown ::oo::object {core method: "unknown"}}}
test oo-call-1.5 {object call introspection - filters} -setup {
    oo::class create root
} -body {
    oo::class create ::A {
	superclass root
	method x {} {}
	method y {} {}
	filter y
    }
    A create y
    info object call y x
} -cleanup {
    root destroy
} -result {{filter y ::A method} {method x ::A method}}
test oo-call-1.6 {object call introspection - filters} -setup {
    oo::class create root
} -body {
    oo::class create ::A {
	superclass root
	method x {} {}
	method y {} {}
	filter y
    }
    oo::class create ::B {
	superclass A
	method x {} {}
    }
    B create y
    info object call y x
} -cleanup {
    root destroy
} -result {{filter y ::A method} {method x ::B method} {method x ::A method}}
test oo-call-1.7 {object call introspection - filters} -setup {
    oo::class create root
} -body {
    oo::class create ::A {
	superclass root
	method x {} {}
	method y {} {}
	filter y
    }
    oo::class create ::B {
	superclass A
	method x {} {}
	method y {} {}
    }
    B create y
    info object call y x
} -cleanup {
    root destroy
} -result {{filter y ::B method} {filter y ::A method} {method x ::B method} {method x ::A method}}
test oo-call-1.8 {object call introspection - filters} -setup {
    oo::class create root
} -body {
    oo::class create ::A {
	superclass root
	method x {} {}
	method y {} {}
	filter y
    }
    oo::class create ::B {
	superclass A
	method x {} {}
	method y {} {}
	method z {} {}
	filter z
    }
    B create y
    info object call y x
} -cleanup {
    root destroy
} -result {{filter z ::B method} {filter y ::B method} {filter y ::A method} {method x ::B method} {method x ::A method}}
test oo-call-1.9 {object call introspection - filters} -setup {
    oo::class create root
} -body {
    oo::class create ::A {
	superclass root
	method x {} {}
	method y {} {}
	filter y
    }
    oo::class create ::B {
	superclass A
	method x {} {}
	method y {} {}
	method z {} {}
	filter z
    }
    B create y
    info object call y y
} -cleanup {
    root destroy
} -result {{filter z ::B method} {filter y ::B method} {filter y ::A method} {method y ::B method} {method y ::A method}}
test oo-call-1.10 {object call introspection - filters + unknown} -setup {
    oo::class create root
} -body {
    oo::class create ::A {
	superclass root
	method y {} {}
	filter y
    }
    oo::class create ::B {
	superclass A
	method y {} {}
	method unknown {} {}
    }
    B create y
    info object call y x
} -cleanup {
    root destroy
} -result {{filter y ::B method} {filter y ::A method} {unknown unknown ::B method} {unknown unknown ::oo::object {core method: "unknown"}}}
test oo-call-1.11 {object call introspection - filters + unknown} -setup {
    oo::class create root
} -body {
    oo::class create ::A {
	superclass root
	method y {} {}
	filter y
    }
    A create y
    oo::objdefine y method unknown {} {}
    info object call y x
} -cleanup {
    root destroy
} -result {{filter y ::A method} {unknown unknown object method} {unknown unknown ::oo::object {core method: "unknown"}}}
test oo-call-1.12 {object call introspection - filters + unknown} -setup {
    oo::class create root
} -body {
    oo::class create ::A {
	superclass root
	method y {} {}
    }
    A create y
    oo::objdefine y {
	method unknown {} {}
	filter y
    }
    info object call y x
} -cleanup {
    root destroy
} -result {{filter y ::A method} {unknown unknown object method} {unknown unknown ::oo::object {core method: "unknown"}}}
test oo-call-1.13 {object call introspection - filters + unknown} -setup {
    oo::class create root
} -body {
    oo::class create ::A {
	superclass root
	method y {} {}
    }
    A create y
    oo::objdefine y {
	method unknown {} {}
	method x {} {}
	filter y
    }
    info object call y x
} -cleanup {
    root destroy
} -result {{filter y ::A method} {method x object method}}
test oo-call-1.14 {object call introspection - errors} -body {
    info object call
} -returnCodes error -result {wrong # args: should be "info object call objName methodName"}
test oo-call-1.15 {object call introspection - errors} -body {
    info object call a
} -returnCodes error -result {wrong # args: should be "info object call objName methodName"}
test oo-call-1.16 {object call introspection - errors} -body {
    info object call a b c
} -returnCodes error -result {wrong # args: should be "info object call objName methodName"}
test oo-call-1.17 {object call introspection - errors} -body {
    info object call notanobject x
} -returnCodes error -result {notanobject does not refer to an object}
test oo-call-1.18 {object call introspection - memory leaks} -body {
    leaktest {
	info object call oo::object destroy
    }
} -constraints memory -result 0

test oo-call-2.1 {class call introspection} -setup {
    oo::class create root
} -body {
    oo::class create ::A {
	superclass root
	method x {} {}
    }
    info class call A x
} -cleanup {
    root destroy
} -result {{method x ::A method}}
test oo-call-2.2 {class call introspection} -setup {
    oo::class create root
} -body {
    oo::class create ::A {
	superclass root
	method x {} {}
    }
    oo::class create ::B {
	superclass A
	method x {} {}
    }
    list [info class call A x] [info class call B x]
} -cleanup {
    root destroy
} -result {{{method x ::A method}} {{method x ::B method} {method x ::A method}}}
test oo-call-2.3 {class call introspection} -setup {
    oo::class create root
} -body {
    oo::class create ::A {
	superclass root
	method x {} {}
    }
    oo::class create ::B {
	superclass A
	method x {} {}
    }
    oo::class create ::C {
	superclass A
	method x {} {}
    }
    oo::class create ::D {
	superclass C B
	method x {} {}
    }
    info class call D x
} -cleanup {
    root destroy
} -result {{method x ::D method} {method x ::C method} {method x ::B method} {method x ::A method}}
test oo-call-2.4 {class call introspection - mixin} -setup {
    oo::class create root
} -body {
    oo::class create ::A {
	superclass root
	method x {} {}
    }
    oo::class create ::B {
	superclass A
	method x {} {}
    }
    oo::class create ::C {
	superclass A
	method x {} {}
    }
    oo::class create ::D {
	superclass C
	mixin B
	method x {} {}
    }
    info class call D x
} -cleanup {
    root destroy
} -result {{method x ::B method} {method x ::D method} {method x ::C method} {method x ::A method}}
test oo-call-2.5 {class call introspection - mixin + filter} -setup {
    oo::class create root
} -body {
    oo::class create ::A {
	superclass root
	method x {} {}
    }
    oo::class create ::B {
	superclass A
	method x {} {}
	method y {} {}
	filter y
    }
    oo::class create ::C {
	superclass A
	method x {} {}
	method y {} {}
    }
    oo::class create ::D {
	superclass C
	mixin B
	method x {} {}
    }
    info class call D x
} -cleanup {
    root destroy
} -result {{filter y ::B method} {filter y ::C method} {method x ::B method} {method x ::D method} {method x ::C method} {method x ::A method}}
test oo-call-2.6 {class call introspection - mixin + filter + unknown} -setup {
    oo::class create root
} -body {
    oo::class create ::A {
	superclass root
	method x {} {}
	method unknown {} {}
    }
    oo::class create ::B {
	superclass A
	method x {} {}
	method y {} {}
	filter y
    }
    oo::class create ::C {
	superclass A
	method x {} {}
	method y {} {}
    }
    oo::class create ::D {
	superclass C
	mixin B
	method x {} {}
	method unknown {} {}
    }
    info class call D z
} -cleanup {
    root destroy
} -result {{filter y ::B method} {filter y ::C method} {unknown unknown ::D method} {unknown unknown ::A method} {unknown unknown ::oo::object {core method: "unknown"}}}
test oo-call-2.7 {class call introspection - mixin + filter + unknown} -setup {
    oo::class create root
} -body {
    oo::class create ::A {
	superclass root
	method x {} {}
    }
    oo::class create ::B {
	superclass A
	method x {} {}
	filter x
    }
    info class call B x
} -cleanup {
    root destroy
} -result {{filter x ::B method} {filter x ::A method} {method x ::B method} {method x ::A method}}
test oo-call-2.8 {class call introspection - errors} -body {
    info class call
} -returnCodes error -result {wrong # args: should be "info class call className methodName"}
test oo-call-2.9 {class call introspection - errors} -body {
    info class call a
} -returnCodes error -result {wrong # args: should be "info class call className methodName"}
test oo-call-2.10 {class call introspection - errors} -body {
    info class call a b c
} -returnCodes error -result {wrong # args: should be "info class call className methodName"}
test oo-call-2.11 {class call introspection - errors} -body {
    info class call notaclass x
} -returnCodes error -result {notaclass does not refer to an object}
test oo-call-2.11 {class call introspection - errors} -setup {
    oo::class create root
} -body {
    root create notaclass
    info class call notaclass x
} -returnCodes error -cleanup {
    root destroy
} -result {"notaclass" is not a class}
test oo-call-2.13 {class call introspection - memory leaks} -body {
    leaktest {
	info class call oo::class destroy
    }
} -constraints memory -result 0

test oo-call-3.1 {current call introspection} -setup {
    oo::class create root
} -body {
    oo::class create A {
	superclass root
	method x {} {lappend ::result [self call]}
    }
    oo::class create B {
	superclass A
	method x {} {lappend ::result [self call];next}
    }
    B create y
    oo::objdefine y method x {} {lappend ::result [self call];next}
    set ::result {}
    y x
} -cleanup {
    root destroy
} -result {{{{method x object method} {method x ::B method} {method x ::A method}} 0} {{{method x object method} {method x ::B method} {method x ::A method}} 1} {{{method x object method} {method x ::B method} {method x ::A method}} 2}}
test oo-call-3.2 {current call introspection} -setup {
    oo::class create root
} -constraints memory -body {
    oo::class create A {
	superclass root
	method x {} {self call}
    }
    oo::class create B {
	superclass A
	method x {} {self call;next}
    }
    B create y
    oo::objdefine y method x {} {self call;next}
    leaktest {
	y x
    }
} -cleanup {
    root destroy
} -result 0
test oo-call-3.3 {current call introspection: in constructors} -setup {
    oo::class create root
} -body {
    oo::class create A {
	superclass root
	constructor {} {lappend ::result [self call]}
    }
    oo::class create B {
	superclass A
	constructor {} {lappend ::result [self call]; next}
    }
    set ::result {}
    [B new] destroy
    return $::result
} -cleanup {
    root destroy
} -result {{{{method <constructor> ::B method} {method <constructor> ::A method}} 0} {{{method <constructor> ::B method} {method <constructor> ::A method}} 1}}
test oo-call-3.4 {current call introspection: in destructors} -setup {
    oo::class create root
} -body {
    oo::class create A {
	superclass root
	destructor {lappend ::result [self call]}
    }
    oo::class create B {
	superclass A
	destructor {lappend ::result [self call]; next}
    }
    set ::result {}
    [B new] destroy
    return $::result
} -cleanup {
    root destroy
} -result {{{{method <destructor> ::B method} {method <destructor> ::A method}} 0} {{{method <destructor> ::B method} {method <destructor> ::A method}} 1}}

cleanupTests
return

# Local Variables:
# mode: tcl
# End:

    interp bgerror {} $handler
} -result {divide by zero}

test socket_$af-6.2 {
    readable fileevent on server socket
} -setup {
    set sock [socket -server dummy 0]
} -constraints [list socket supported_$af] -body {
    fileevent $sock readable dummy
} -cleanup {
    close $sock
} -returnCodes 1 -result "channel is not readable"

test socket_$af-6.3 {writable fileevent on server socket} -setup {
    set sock [socket -server dummy 0]
} -constraints [list socket supported_$af] -body {
    fileevent $sock writable dummy
} -cleanup {
    close $sock
} -returnCodes 1 -result "channel is not writable"

test socket_$af-7.1 {testing socket specific options} -setup {
    file delete $path(script)

    gets $p listen
    set f [socket $localhost $listen]
    fconfigure $f -buffering full -blocking 0
    fileevent $f readable [list getdata $f]
    # If the socket is still open after 5 seconds, the script1 process must
    # have inherited the accepted socket.
    set failed 0
    set after [after 5000 [list set failed 1]]
    proc getdata { file } {
	# Read handler on the client socket.
	global x
	global failed
	set status [catch {read $file} data]
	if {$status != 0} {
	    set x {read failed, error was $data}

	    catch { close $file }
	}
	return
    }
    vwait x
    return $x
} -cleanup {
    after cancel $after
    catch {close $p}
} -result {accepted socket was not inherited}

test socket_$af-13.1 {Testing use of shared socket between two threads} -setup {
    threadReap
    set path(script) [makeFile [string map [list @localhost@ $localhost] {
        set f [socket -server accept -myaddr @localhost@ 0]

	@echo "Installing package http 2.8.2 as a Tcl Module";
	@$(INSTALL_DATA) $(TOP_DIR)/library/http/http.tcl "$(SCRIPT_INSTALL_DIR)"/../tcl8/8.6/http-2.8.2.tm;
	@echo "Installing package opt0.4 files to $(SCRIPT_INSTALL_DIR)/opt0.4/";
	@for i in $(TOP_DIR)/library/opt/*.tcl ; \
	    do \
	    $(INSTALL_DATA) $$i "$(SCRIPT_INSTALL_DIR)"/opt0.4; \
	    done;
	@echo "Installing package msgcat 1.4.4 as a Tcl Module";
	@$(INSTALL_DATA) $(TOP_DIR)/library/msgcat/msgcat.tcl "$(SCRIPT_INSTALL_DIR)"/../tcl8/8.5/msgcat-1.4.4.tm;
	@echo "Installing package tcltest 2.3.3 as a Tcl Module";
	@$(INSTALL_DATA) $(TOP_DIR)/library/tcltest/tcltest.tcl "$(SCRIPT_INSTALL_DIR)"/../tcl8/8.5/tcltest-2.3.3.tm;

	@echo "Installing package platform 1.0.9 as a Tcl Module";
	@$(INSTALL_DATA) $(TOP_DIR)/library/platform/platform.tcl "$(SCRIPT_INSTALL_DIR)"/../tcl8/8.4/platform-1.0.9.tm;
	@echo "Installing package platform::shell 1.1.4 as a Tcl Module";
	@$(INSTALL_DATA) $(TOP_DIR)/library/platform/shell.tcl "$(SCRIPT_INSTALL_DIR)"/../tcl8/8.4/platform/shell-1.1.4.tm;

# These are mostly empty because no special steps are ever needed from Tcl 8.6
# onwards; all libraries and include files are just part of Tcl.
TCLOO_LIB_SPEC=""
TCLOO_STUB_LIB_SPEC=""
TCLOO_INCLUDE_SPEC=""
TCLOO_PRIVATE_INCLUDE_SPEC=""
TCLOO_CFLAGS=-DUSE_TCLOO_STUBS
TCLOO_VERSION=0.6.3

	@echo "Installing package http 2.8.2 as a Tcl Module";
	@$(COPY) $(ROOT_DIR)/library/http/http.tcl $(SCRIPT_INSTALL_DIR)/../tcl8/8.6/http-2.8.2.tm;
	@echo "Installing library opt0.4 directory";
	@for j in $(ROOT_DIR)/library/opt/*.tcl; \
	    do \
	    $(COPY) "$$j" "$(SCRIPT_INSTALL_DIR)/opt0.4"; \
	    done;
	@echo "Installing package msgcat 1.4.4 as a Tcl Module";
	@$(COPY) $(ROOT_DIR)/library/msgcat/msgcat.tcl $(SCRIPT_INSTALL_DIR)/../tcl8/8.5/msgcat-1.4.4.tm;
	@echo "Installing package tcltest 2.3.3 as a Tcl Module";
	@$(COPY) $(ROOT_DIR)/library/tcltest/tcltest.tcl $(SCRIPT_INSTALL_DIR)/../tcl8/8.5/tcltest-2.3.3.tm;
	@echo "Installing package platform 1.0.9 as a Tcl Module";
	@$(COPY) $(ROOT_DIR)/library/platform/platform.tcl $(SCRIPT_INSTALL_DIR)/../tcl8/8.4/platform-1.0.9.tm;
	@echo "Installing package platform::shell 1.1.4 as a Tcl Module";
	@$(COPY) $(ROOT_DIR)/library/platform/shell.tcl $(SCRIPT_INSTALL_DIR)/../tcl8/8.4/platform/shell-1.1.4.tm;
	@echo "Installing encodings";

# These are mostly empty because no special steps are ever needed from Tcl 8.6
# onwards; all libraries and include files are just part of Tcl.
TCLOO_LIB_SPEC=""
TCLOO_STUB_LIB_SPEC=""
TCLOO_INCLUDE_SPEC=""
TCLOO_PRIVATE_INCLUDE_SPEC=""
TCLOO_CFLAGS=-DUSE_TCLOO_STUBS
TCLOO_VERSION=0.6.3