Tcl Source Code

.sp
Tcl_UniChar *
\fBTcl_GetUnicodeFromObj\fR(\fIobjPtr, lengthPtr\fR)
.sp
Tcl_UniChar *
\fBTcl_GetUnicode\fR(\fIobjPtr\fR)
.sp
int
\fBTcl_GetUniChar\fR(\fIobjPtr, index\fR)
.sp
int
\fBTcl_GetCharLength\fR(\fIobjPtr\fR)
.sp
Tcl_Obj *
\fBTcl_GetRange\fR(\fIobjPtr, first, last\fR)

\fIlengthPtr\fR if it is non-NULL.  The storage referenced by the returned
byte pointer is owned by the value manager and should not be modified by
the caller.  The procedure \fBTcl_GetUnicode\fR is used in the common case
where the caller does not need the length of the unicode string
representation.
.PP
\fBTcl_GetUniChar\fR returns the \fIindex\fR'th character in the
value's Unicode representation. If the index is out of range or
it references a low surrogate preceded by a high surrogate, it returns -1;
.PP
\fBTcl_GetRange\fR returns a newly created value comprised of the
characters between \fIfirst\fR and \fIlast\fR (inclusive) in the
value's Unicode representation.  If the value's Unicode
representation is invalid, the Unicode representation is regenerated
from the value's string representation.
.PP

.BS
.SH NAME
Tcl_UniCharToUpper, Tcl_UniCharToLower, Tcl_UniCharToTitle, Tcl_UtfToUpper, Tcl_UtfToLower, Tcl_UtfToTitle \- routines for manipulating the case of Unicode characters and UTF-8 strings
.SH SYNOPSIS
.nf
\fB#include <tcl.h>\fR
.sp
int
\fBTcl_UniCharToUpper\fR(\fIch\fR)
.sp
int
\fBTcl_UniCharToLower\fR(\fIch\fR)
.sp
int
\fBTcl_UniCharToTitle\fR(\fIch\fR)
.sp
int
\fBTcl_UtfToUpper\fR(\fIstr\fR)
.sp
int
\fBTcl_UtfToLower\fR(\fIstr\fR)

.sp
const char *
\fBTcl_UtfNext\fR(\fIsrc\fR)
.sp
const char *
\fBTcl_UtfPrev\fR(\fIsrc, start\fR)
.sp
int
\fBTcl_UniCharAtIndex\fR(\fIsrc, index\fR)
.sp
const char *
\fBTcl_UtfAtIndex\fR(\fIsrc, index\fR)
.sp
int
\fBTcl_UtfBackslash\fR(\fIsrc, readPtr, dst\fR)

.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
number of bytes read from \fIsrc\fR.  The caller must ensure that the
source buffer is long enough such that this routine does not run off the
end and dereference non-existent or random memory; if the source buffer
is known to be null-terminated, this will not happen.  If the input is
a byte in the range 0x80 - 0x9F, \fBTcl_UtfToUniChar\fR assumes the
cp1252 encoding, stores the corresponding Tcl_UniChar in \fI*chPtr\fR
and returns 1. If the input is otherwise
not in proper UTF-8 format, \fBTcl_UtfToUniChar\fR will store the first
byte of \fIsrc\fR in \fI*chPtr\fR as a Tcl_UniChar between 0x0000 and
0x00ff and return 1.
.PP
\fBTcl_UniCharToUtfDString\fR converts the given Unicode string
to UTF-8, storing the result in a previously initialized \fBTcl_DString\fR.
You must specify \fIuniLength\fR, the length of the given Unicode string.

been the return value from a previous invocation of
\fBarray startsearch\fR.  Returns an empty string.
.TP
\fBarray exists \fIarrayName\fR
Returns 1 if \fIarrayName\fR is an array variable, 0 if there
is no variable by that name or if it is a scalar variable.
.TP
\fBarray for {\fIkeyVariable valueVariable\fB} \fIarrayName body\fP
The first argument is a two element list of variable names for the
key and value of each entry in the array.  The second argument is the
array name to iterate over.  The third argument is the body to execute
for each key and value returned.
The ordering of the returned keys is undefined.
If an array element is deleted or a new array element is inserted during
the \fIarray for\fP process, the command will terminate with an error.
.TP
\fBarray get \fIarrayName\fR ?\fIpattern\fR?
Returns a list containing pairs of elements.  The first
element in each pair is the name of an element in \fIarrayName\fR
and the second element of each pair is the value of the
array element.  The order of the pairs is undefined.
If \fIpattern\fR is not specified, then all of the elements of the
array are included in the result.

command) will be \fIargList\fR, and the body of the constructor will be
\fIbodyScript\fR. When the body of the constructor is evaluated, the current
namespace of the constructor will be a namespace that is unique to the object
being constructed. Within the constructor, the \fBnext\fR command should be
used to call the superclasses' constructors. If \fIbodyScript\fR is the empty
string, the constructor will be deleted.
.TP
\fBdeletemethod\fI name\fR ?\fIname ...\fR?
.
This deletes each of the methods called \fIname\fR from a class. The methods
must have previously existed in that class. Does not affect the superclasses
of the class, nor does it affect the subclasses or instances of the class
(except when they have a call chain through the class being modified).
.TP
\fBdestructor\fI bodyScript\fR

Any of the forms allowed to \fBTcl_GetBoolean\fR.
.IP \fBcontrol\fR 12
Any Unicode control character.
.IP \fBdigit\fR 12
Any Unicode digit character.  Note that this includes characters
outside of the [0\-9] range.
.IP \fBdouble\fR 12
Any of the forms allowed to \fBTcl_GetDoubleFromObj\fR.


.IP \fBentier\fR 12
.VS 8.6
Any of the valid string formats for an integer value of arbitrary size
in Tcl, with optional surrounding whitespace. The formats accepted are
exactly those accepted by the C routine \fBTcl_GetBignumFromObj\fR.
.VE
.IP \fBfalse\fR 12
Any of the forms allowed to \fBTcl_GetBoolean\fR where the value is
false.
.IP \fBgraph\fR 12
Any Unicode printing character, except space.
.IP \fBinteger\fR 12
Any of the valid string formats for a 32-bit integer value in Tcl,
with optional surrounding whitespace.  In case of overflow in
the value, 0 is returned and the \fIvarname\fR will contain \-1.
.IP \fBlist\fR 12
Any proper list structure, with optional surrounding whitespace. In
case of improper list structure, 0 is returned and the \fIvarname\fR
will contain the index of the
.QW element
where the list parsing fails, or \-1 if this cannot be determined.

.IP \fBtrue\fR 12
Any of the forms allowed to \fBTcl_GetBoolean\fR where the value is
true.
.IP \fBupper\fR 12
Any upper case alphabet character in the Unicode character set.
.IP \fBwideinteger\fR 12
Any of the valid forms for a wide integer in Tcl, with optional
surrounding whitespace.  In case of overflow in the value, 0 is
returned and the \fIvarname\fR will contain \-1.
.IP \fBwordchar\fR 12
Any Unicode word character.  That is any alphanumeric character, and
any Unicode connector punctuation characters (e.g. underscore).
.IP \fBxdigit\fR 12
Any hexadecimal digit character ([0\-9A\-Fa\-f]).
.PP

    void Tcl_ThreadAlert(Tcl_ThreadId threadId)
}
declare 319 {
    void Tcl_ThreadQueueEvent(Tcl_ThreadId threadId, Tcl_Event *evPtr,
	    Tcl_QueuePosition position)
}
declare 320 {
    int Tcl_UniCharAtIndex(const char *src, int index)
}
declare 321 {
    int Tcl_UniCharToLower(int ch)
}
declare 322 {
    int Tcl_UniCharToTitle(int ch)
}
declare 323 {
    int Tcl_UniCharToUpper(int ch)
}
declare 324 {
    int Tcl_UniCharToUtf(int ch, char *buf)
}
declare 325 {
    const char *Tcl_UtfAtIndex(const char *src, int index)
}

    void Tcl_SetUnicodeObj(Tcl_Obj *objPtr, const Tcl_UniChar *unicode,
	    int numChars)
}
declare 380 {
    int Tcl_GetCharLength(Tcl_Obj *objPtr)
}
declare 381 {
    int Tcl_GetUniChar(Tcl_Obj *objPtr, int index)
}
declare 382 {
    Tcl_UniChar *Tcl_GetUnicode(Tcl_Obj *objPtr)
}
declare 383 {
    Tcl_Obj *Tcl_GetRange(Tcl_Obj *objPtr, int first, int last)
}

#include <stdio.h>

#if defined(__GNUC__) && (__GNUC__ > 2)
#   define TCL_FORMAT_PRINTF(a,b) __attribute__ ((__format__ (__printf__, a, b)))
#   define TCL_NORETURN __attribute__ ((noreturn))
#   define TCL_NOINLINE __attribute__ ((noinline))
#   define TCL_NORETURN1 __attribute__ ((noreturn))
#else
#   define TCL_FORMAT_PRINTF(a,b)
#   if defined(_MSC_VER) && (_MSC_VER >= 1310)
#	define TCL_NORETURN _declspec(noreturn)
#	define TCL_NOINLINE __declspec(noinline)
#   else
#	define TCL_NORETURN /* nothing */
#	define TCL_NOINLINE /* nothing */
#   endif
#   define TCL_NORETURN1 /* nothing */
#endif

/*
 * Allow a part of Tcl's API to be explicitly marked as deprecated.
 *
 * Used to make TIP 330/336 generate moans even if people use the
 * compatibility macros. Change your code, guys! We won't support you forever.

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

#ifndef TCL_UTF_MAX
#define TCL_UTF_MAX		4
#endif

/*
 * This represents a Unicode character. Any changes to this should also be
 * reflected in regcustom.h.
 */

typedef int (Tcl_NRPostProc) (ClientData data[], Tcl_Interp *interp,
				int result);

/*
 *----------------------------------------------------------------------------
 * The following constant is used to test for older versions of Tcl in the
 * stubs tables. If TCL_UTF_MAX>4 use a different value.
 */

#define TCL_STUB_MAGIC		((int) 0xFCA3BACF + (TCL_UTF_MAX>4))

/*
 * The following function is required to be defined in all stubs aware
 * extensions. The function is actually implemented in the stub library, not
 * the main Tcl library, although there is a trivial implementation in the
 * main library in case an extension is statically linked into an application.
 */

    Tcl_Obj *const objv[])	/* Argument objects. */
{
    int idx, result, cflags, all, wlen, wsublen, numMatches, offset;
    int start, end, subStart, subEnd, match, command, numParts;
    Tcl_RegExp regExpr;
    Tcl_RegExpInfo info;
    Tcl_Obj *resultPtr, *subPtr, *objPtr, *startIndex = NULL;
    Tcl_UniChar ch, *wsrc, *wfirstChar, *wstring, *wsubspec = 0, *wend;

    static const char *const options[] = {
	"-all",		"-command",	"-expanded",	"-line",
	"-linestop",	"-lineanchor",	"-nocase",	"-start",
	"--",		NULL
    };
    enum options {

	Tcl_InitHashTable(&charReuseTable, TCL_ONE_WORD_KEYS);

	for ( ; stringPtr < end; stringPtr += len) {
		int fullchar;
	    len = TclUtfToUniChar(stringPtr, &ch);
	    fullchar = ch;

#if TCL_UTF_MAX <= 4
	    if (!len) {
		len += TclUtfToUniChar(stringPtr, &ch);
		fullchar = (((fullchar & 0x3ff) << 10) | (ch & 0x3ff)) + 0x10000;
	    }
#endif

	    /*

    if (objc != 3) {
	Tcl_WrongNumArgs(interp, 1, objv, "string charIndex");
	return TCL_ERROR;
    }

    /*
     * Get the char length to calculate what 'end' means.
     */

    length = Tcl_GetCharLength(objv[1]);
    if (TclGetIntForIndexM(interp, objv[2], length-1, &index) != TCL_OK) {
	return TCL_ERROR;
    }

    if ((index >= 0) && (index < length)) {
	int ch = Tcl_GetUniChar(objv[1], index);

	if (ch == -1) {
	    return TCL_OK;
	}

	/*
	 * If we have a ByteArray object, we're careful to generate a new
	 * bytearray for a result.
	 */

	if (TclIsPureByteArray(objv[1])) {
	    unsigned char uch = (unsigned char) ch;

	    Tcl_SetObjResult(interp, Tcl_NewByteArrayObj(&uch, 1));
	} else {
	    char buf[4];

	    length = Tcl_UniCharToUtf(ch, buf);
	    Tcl_SetObjResult(interp, Tcl_NewStringObj(buf, length));
	}
    }
    return TCL_OK;
}

    case STR_IS_CONTROL:
	chcomp = Tcl_UniCharIsControl;
	break;
    case STR_IS_DIGIT:
	chcomp = Tcl_UniCharIsDigit;
	break;
    case STR_IS_DOUBLE: {

	if ((objPtr->typePtr == &tclDoubleType) ||
		(objPtr->typePtr == &tclIntType) ||
		(objPtr->typePtr == &tclBignumType)) {
	    break;
	}
	string1 = TclGetStringFromObj(objPtr, &length1);
	if (length1 == 0) {

	    goto str_is_done;
	}
	end = string1 + length1;
	for (; string1 < end; string1 += length2, failat++) {
	    int fullchar;
	    length2 = TclUtfToUniChar(string1, &ch);
	    fullchar = ch;
#if TCL_UTF_MAX <= 4
	    if (!length2) {
	    	length2 = TclUtfToUniChar(string1, &ch);
	    	fullchar = (((fullchar & 0x3ff) << 10) | (ch & 0x3ff)) + 0x10000;
	    }
#endif
	    if (!chcomp(fullchar)) {
		result = 0;

    isDataEven = (isDataValid && (len & 1) == 0);

    /*
     * Special case: literal odd-length argument is always an error.
     */

    if (isDataValid && !isDataEven) {
	/* Abandon custom compile and let invocation raise the error */
	code = TclCompileBasic2ArgCmd(interp, parsePtr, cmdPtr, envPtr);
	goto done;

	/*
	 * We used to compile to the bytecode that would throw the error,
	 * but that was wrong because it would not invoke the array trace
	 * on the variable.
	 *
	PushStringLiteral(envPtr, "list must have an even number of elements");
	PushStringLiteral(envPtr, "-errorcode {TCL ARGUMENT FORMAT}");
	TclEmitInstInt4(INST_RETURN_IMM, TCL_ERROR,		envPtr);
	TclEmitInt4(		0,				envPtr);
	goto done;
	 *
	 */
    }

    /*
     * Except for the special "ensure array" case below, when we're not in
     * a proc, we cannot do a better compile than generic.
     */

    infoPtr->varLists[0]->varIndexes[1] = valVar;
    infoIndex = TclCreateAuxData(infoPtr, &newForeachInfoType, envPtr);

    /*
     * Start issuing instructions to write to the array.
     */

    TclEmitInstInt4(INST_ARRAY_EXISTS_IMM, localIndex,	envPtr);
    TclEmitInstInt1(INST_JUMP_TRUE1, 7,			envPtr);
    TclEmitInstInt4(INST_ARRAY_MAKE_IMM, localIndex,	envPtr);

    CompileWord(envPtr, dataTokenPtr, interp, 2);
    if (!isDataLiteral || !isDataValid) {
	/*
	 * Only need this safety check if we're handling a non-literal or list
	 * containing an invalid literal; with valid list literals, we've
	 * already checked (worth it because literals are a very common
	 * use-case with [array set]).

	TclEmitInstInt4(INST_RETURN_IMM, TCL_ERROR,		envPtr);
	TclEmitInt4(		0,				envPtr);
	TclAdjustStackDepth(-1, envPtr);
	fwd = CurrentOffset(envPtr) - offsetFwd;
	TclStoreInt1AtPtr(fwd, envPtr->codeStart+offsetFwd+1);
    }




    TclEmitInstInt4(INST_FOREACH_START, infoIndex,	envPtr);
    offsetBack = CurrentOffset(envPtr);
    Emit14Inst(	INST_LOAD_SCALAR, keyVar,		envPtr);
    Emit14Inst(	INST_LOAD_SCALAR, valVar,		envPtr);
    Emit14Inst(	INST_STORE_ARRAY, localIndex,		envPtr);
    TclEmitOpcode(	INST_POP,			envPtr);
    infoPtr->loopCtTemp = offsetBack - CurrentOffset(envPtr); /*misuse */

				int flags);
/* 318 */
EXTERN void		Tcl_ThreadAlert(Tcl_ThreadId threadId);
/* 319 */
EXTERN void		Tcl_ThreadQueueEvent(Tcl_ThreadId threadId,
				Tcl_Event *evPtr, Tcl_QueuePosition position);
/* 320 */
EXTERN int		Tcl_UniCharAtIndex(const char *src, int index);
/* 321 */
EXTERN int		Tcl_UniCharToLower(int ch);
/* 322 */
EXTERN int		Tcl_UniCharToTitle(int ch);
/* 323 */
EXTERN int		Tcl_UniCharToUpper(int ch);
/* 324 */
EXTERN int		Tcl_UniCharToUtf(int ch, char *buf);
/* 325 */
EXTERN const char *	Tcl_UtfAtIndex(const char *src, int index);
/* 326 */
EXTERN int		Tcl_UtfCharComplete(const char *src, int length);
/* 327 */

				int numChars);
/* 379 */
EXTERN void		Tcl_SetUnicodeObj(Tcl_Obj *objPtr,
				const Tcl_UniChar *unicode, int numChars);
/* 380 */
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);
/* 383 */
EXTERN Tcl_Obj *	Tcl_GetRange(Tcl_Obj *objPtr, int first, int last);
/* 384 */
EXTERN void		Tcl_AppendUnicodeToObj(Tcl_Obj *objPtr,
				const Tcl_UniChar *unicode, int length);

typedef struct TclStubs {
    int magic;
    const TclStubHooks *hooks;

    int (*tcl_PkgProvideEx) (Tcl_Interp *interp, const char *name, const char *version, const void *clientData); /* 0 */
    const char * (*tcl_PkgRequireEx) (Tcl_Interp *interp, const char *name, const char *version, int exact, void *clientDataPtr); /* 1 */
    TCL_NORETURN1 void (*tcl_Panic) (const char *format, ...) TCL_FORMAT_PRINTF(1, 2); /* 2 */
    char * (*tcl_Alloc) (unsigned int size); /* 3 */
    void (*tcl_Free) (char *ptr); /* 4 */
    char * (*tcl_Realloc) (char *ptr, unsigned int size); /* 5 */
    char * (*tcl_DbCkalloc) (unsigned int size, const char *file, int line); /* 6 */
    void (*tcl_DbCkfree) (char *ptr, const char *file, int line); /* 7 */
    char * (*tcl_DbCkrealloc) (char *ptr, unsigned int size, const char *file, int line); /* 8 */
#if !defined(_WIN32) && !defined(MAC_OSX_TCL) /* UNIX */

    int (*tcl_Eof) (Tcl_Channel chan); /* 126 */
    const char * (*tcl_ErrnoId) (void); /* 127 */
    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 */
    void (*reserved131)(void);
    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 */
    int (*tcl_ExprBoolean) (Tcl_Interp *interp, const char *expr, int *ptr); /* 135 */
    int (*tcl_ExprBooleanObj) (Tcl_Interp *interp, Tcl_Obj *objPtr, int *ptr); /* 136 */
    int (*tcl_ExprDouble) (Tcl_Interp *interp, const char *expr, double *ptr); /* 137 */
    int (*tcl_ExprDoubleObj) (Tcl_Interp *interp, Tcl_Obj *objPtr, double *ptr); /* 138 */
    int (*tcl_ExprLong) (Tcl_Interp *interp, const char *expr, long *ptr); /* 139 */
    int (*tcl_ExprLongObj) (Tcl_Interp *interp, Tcl_Obj *objPtr, long *ptr); /* 140 */

    Tcl_Encoding (*tcl_CreateEncoding) (const Tcl_EncodingType *typePtr); /* 287 */
    void (*tcl_CreateThreadExitHandler) (Tcl_ExitProc *proc, ClientData clientData); /* 288 */
    void (*tcl_DeleteThreadExitHandler) (Tcl_ExitProc *proc, ClientData clientData); /* 289 */
    void (*tcl_DiscardResult) (Tcl_SavedResult *statePtr); /* 290 */
    int (*tcl_EvalEx) (Tcl_Interp *interp, const char *script, int numBytes, int flags); /* 291 */
    int (*tcl_EvalObjv) (Tcl_Interp *interp, int objc, Tcl_Obj *const objv[], int flags); /* 292 */
    int (*tcl_EvalObjEx) (Tcl_Interp *interp, Tcl_Obj *objPtr, int flags); /* 293 */
    TCL_NORETURN1 void (*tcl_ExitThread) (int status); /* 294 */
    int (*tcl_ExternalToUtf) (Tcl_Interp *interp, Tcl_Encoding encoding, const char *src, int srcLen, int flags, Tcl_EncodingState *statePtr, char *dst, int dstLen, int *srcReadPtr, int *dstWrotePtr, int *dstCharsPtr); /* 295 */
    char * (*tcl_ExternalToUtfDString) (Tcl_Encoding encoding, const char *src, int srcLen, Tcl_DString *dsPtr); /* 296 */
    void (*tcl_FinalizeThread) (void); /* 297 */
    void (*tcl_FinalizeNotifier) (ClientData clientData); /* 298 */
    void (*tcl_FreeEncoding) (Tcl_Encoding encoding); /* 299 */
    Tcl_ThreadId (*tcl_GetCurrentThread) (void); /* 300 */
    Tcl_Encoding (*tcl_GetEncoding) (Tcl_Interp *interp, const char *name); /* 301 */

    int (*tcl_ReadChars) (Tcl_Channel channel, Tcl_Obj *objPtr, int charsToRead, int appendFlag); /* 313 */
    void (*tcl_RestoreResult) (Tcl_Interp *interp, Tcl_SavedResult *statePtr); /* 314 */
    void (*tcl_SaveResult) (Tcl_Interp *interp, Tcl_SavedResult *statePtr); /* 315 */
    int (*tcl_SetSystemEncoding) (Tcl_Interp *interp, const char *name); /* 316 */
    Tcl_Obj * (*tcl_SetVar2Ex) (Tcl_Interp *interp, const char *part1, const char *part2, Tcl_Obj *newValuePtr, int flags); /* 317 */
    void (*tcl_ThreadAlert) (Tcl_ThreadId threadId); /* 318 */
    void (*tcl_ThreadQueueEvent) (Tcl_ThreadId threadId, Tcl_Event *evPtr, Tcl_QueuePosition position); /* 319 */
    int (*tcl_UniCharAtIndex) (const char *src, int index); /* 320 */
    int (*tcl_UniCharToLower) (int ch); /* 321 */
    int (*tcl_UniCharToTitle) (int ch); /* 322 */
    int (*tcl_UniCharToUpper) (int ch); /* 323 */
    int (*tcl_UniCharToUtf) (int ch, char *buf); /* 324 */
    const char * (*tcl_UtfAtIndex) (const char *src, int index); /* 325 */
    int (*tcl_UtfCharComplete) (const char *src, int length); /* 326 */
    int (*tcl_UtfBackslash) (const char *src, int *readPtr, char *dst); /* 327 */
    const char * (*tcl_UtfFindFirst) (const char *src, int ch); /* 328 */
    const char * (*tcl_UtfFindLast) (const char *src, int ch); /* 329 */
    const char * (*tcl_UtfNext) (const char *src); /* 330 */

    int (*tcl_UniCharIsPrint) (int ch); /* 374 */
    int (*tcl_UniCharIsPunct) (int ch); /* 375 */
    int (*tcl_RegExpExecObj) (Tcl_Interp *interp, Tcl_RegExp regexp, Tcl_Obj *textObj, int offset, int nmatches, int flags); /* 376 */
    void (*tcl_RegExpGetInfo) (Tcl_RegExp regexp, Tcl_RegExpInfo *infoPtr); /* 377 */
    Tcl_Obj * (*tcl_NewUnicodeObj) (const Tcl_UniChar *unicode, int numChars); /* 378 */
    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_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 */
    void (*tcl_SetNotifier) (Tcl_NotifierProcs *notifierProcPtr); /* 386 */
    Tcl_Mutex * (*tcl_GetAllocMutex) (void); /* 387 */
    int (*tcl_GetChannelNames) (Tcl_Interp *interp); /* 388 */

	     * incomplete char its bytes are made to represent themselves.
	     */

	    *chPtr = (unsigned char) *src;
	    src += 1;
	    dst += Tcl_UniCharToUtf(*chPtr, dst);
	} else {
	    int len = TclUtfToUniChar(src, chPtr);
	    src += len;
	    dst += Tcl_UniCharToUtf(*chPtr, dst);
#if TCL_UTF_MAX <= 4
	    if (!len) {
		src += TclUtfToUniChar(src, chPtr);
		dst += Tcl_UniCharToUtf(*chPtr, dst);
	    }
#endif
	}
    }

    *srcReadPtr = src - srcStart;
    *dstWrotePtr = dst - dstStart;
    *dstCharsPtr = numChars;
    return result;

	     */

	    result = TCL_CONVERT_MULTIBYTE;
	    break;
	}
	len = TclUtfToUniChar(src, &ch);

#if TCL_UTF_MAX > 4
	/*
	 * This prevents a crash condition. More evaluation is required for
	 * full support of int Tcl_UniChar. [Bug 1004065]
	 */

	if (ch & 0xffff0000) {
	    word = 0;
	} else
#else
	if (!len) {
	    word = 0;
	} else
#endif
	    word = fromUnicode[(ch >> 8)][ch & 0xff];

	if ((word == 0) && (ch != 0)) {
	    if (flags & TCL_ENCODING_STOPONERROR) {
		result = TCL_CONVERT_UNKNOWN;
		break;

	}
	len = TclUtfToUniChar(src, &ch);

	/*
	 * Check for illegal characters.
	 */

	if (ch > 0xff
#if TCL_UTF_MAX <= 4
		|| !len
#endif
		) {
	    if (flags & TCL_ENCODING_STOPONERROR) {
		result = TCL_CONVERT_UNKNOWN;
		break;
	    }
#if TCL_UTF_MAX <= 4
	    if (!len) len = 4;
#endif
	    /*
	     * Plunge on, using '?' as a fallback character.
	     */

	    ch = (Tcl_UniChar) '?';
	}

	part2Ptr = OBJ_AT_TOS;
	arrayPtr = LOCAL(opnd);
	while (TclIsVarLink(arrayPtr)) {
	    arrayPtr = arrayPtr->value.linkPtr;
	}
	TRACE(("%s %u \"%.30s\" => ",
		(flags ? "normal" : "noerr"), opnd, O2S(part2Ptr)));
	if (TclIsVarArray(arrayPtr) && !UnsetTraced(arrayPtr)
		&& !(arrayPtr->flags & VAR_SEARCH_ACTIVE)) {
	    varPtr = VarHashFindVar(arrayPtr->value.tablePtr, part2Ptr);
	    if (varPtr && TclIsVarDirectUnsettable(varPtr)) {
		/*
		 * No nasty traces and element exists, so we can proceed to
		 * unset it. Might still not exist though...
		 */

	pcAdjustment = 1;
	cleanup = 1;
	part1Ptr = OBJ_AT_TOS;
	TRACE(("\"%.30s\" => ", O2S(part1Ptr)));
	varPtr = TclObjLookupVarEx(interp, part1Ptr, NULL, 0, NULL,
		/*createPart1*/0, /*createPart2*/0, &arrayPtr);
    doArrayExists:


	DECACHE_STACK_INFO();
	result = TclCheckArrayTraces(interp, varPtr, arrayPtr, part1Ptr, opnd);


	CACHE_STACK_INFO();
	if (result == TCL_ERROR) {
	    TRACE_ERROR(interp);
	    goto gotError;

	}
	if (varPtr && TclIsVarArray(varPtr) && !TclIsVarUndefined(varPtr)) {
	    objResultPtr = TCONST(1);
	} else {
	    objResultPtr = TCONST(0);
	}
	TRACE_APPEND(("%.30s\n", O2S(objResultPtr)));

	} else if (TclIsPureByteArray(valuePtr)) {
	    objResultPtr = Tcl_NewByteArrayObj(
		    Tcl_GetByteArrayFromObj(valuePtr, NULL)+index, 1);
	} else if (valuePtr->bytes && length == valuePtr->length) {
	    objResultPtr = Tcl_NewStringObj((const char *)
		    valuePtr->bytes+index, 1);
	} else {
	    char buf[4];
	    int ch = Tcl_GetUniChar(valuePtr, index);

	    /*
	     * This could be: Tcl_NewUnicodeObj((const Tcl_UniChar *)&ch, 1)
	     * 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);
	}

	TRACE_APPEND(("\"%s\"\n", O2S(objResultPtr)));
	NEXT_INST_F(1, 2, 1);

    case INST_STR_RANGE:

MODULE_SCOPE void	TclArgumentBCEnter(Tcl_Interp *interp,
			    Tcl_Obj *objv[], int objc,
			    void *codePtr, CmdFrame *cfPtr, int cmd, int pc);
MODULE_SCOPE void	TclArgumentBCRelease(Tcl_Interp *interp,
			    CmdFrame *cfPtr);
MODULE_SCOPE void	TclArgumentGet(Tcl_Interp *interp, Tcl_Obj *obj,
			    CmdFrame **cfPtrPtr, int *wordPtr);


MODULE_SCOPE void	TclBAConvertIndices(size_t index, unsigned int *hiPtr,
			    unsigned int *loPtr);
MODULE_SCOPE size_t	TclBAInvertIndices(unsigned int hi, unsigned int lo);
MODULE_SCOPE double	TclBignumToDouble(const mp_int *bignum);
MODULE_SCOPE int	TclByteArrayMatch(const unsigned char *string,
			    int strLen, const unsigned char *pattern,
			    int ptnLen, int flags);
MODULE_SCOPE double	TclCeil(const mp_int *a);
MODULE_SCOPE void	TclChannelPreserve(Tcl_Channel chan);
MODULE_SCOPE void	TclChannelRelease(Tcl_Channel chan);
MODULE_SCOPE int	TclCheckArrayTraces(Tcl_Interp *interp, Var *varPtr,
			    Var *arrayPtr, Tcl_Obj *name, int index);
MODULE_SCOPE int	TclChanCaughtErrorBypass(Tcl_Interp *interp,
			    Tcl_Channel chan);
MODULE_SCOPE Tcl_ObjCmdProc TclChannelNamesCmd;
MODULE_SCOPE Tcl_NRPostProc TclClearRootEnsemble;
MODULE_SCOPE int	TclCompareTwoNumbers(Tcl_Obj *valuePtr,
			    Tcl_Obj *value2Ptr);
MODULE_SCOPE ContLineLoc *TclContinuationsEnter(Tcl_Obj *objPtr, int num,

    ProcessInfo *info;
    TclProcessWaitStatus result;

    /*
     * First search for pid in table.
     */

    Tcl_MutexLock(&infoTablesMutex);
    entry = Tcl_FindHashEntry(&infoTablePerPid, pid);
    if (!entry) {
	/*
	 * Unknown process, just call WaitProcessStatus and return.
	 */
	
	result = WaitProcessStatus(pid, TclpGetPid(pid), options, codePtr, 
		msgObjPtr, errorObjPtr);
	if (msgObjPtr && *msgObjPtr) Tcl_IncrRefCount(*msgObjPtr);
	if (errorObjPtr && *errorObjPtr) Tcl_IncrRefCount(*errorObjPtr);
    Tcl_MutexUnlock(&infoTablesMutex);
	return result;
    }

    info = (ProcessInfo *) Tcl_GetHashValue(entry);
    if (info->purge) {
	/*
	 * Process has completed but TclProcessWait has already been called,
	 * so report no change.
	 */
    Tcl_MutexUnlock(&infoTablesMutex);
	
	return TCL_PROCESS_UNCHANGED;
    }

    RefreshProcessInfo(info, options);
    if (info->status == TCL_PROCESS_UNCHANGED) {
	/*
	 * No change, stop there.
	 */
    Tcl_MutexUnlock(&infoTablesMutex);
	
	return TCL_PROCESS_UNCHANGED;
    }

    /*
     * Set return values.
     */

	/*
	 * Eventually purge. Subsequent calls will return
	 * TCL_PROCESS_UNCHANGED.
	 */

	info->purge = 1;
    }
    Tcl_MutexUnlock(&infoTablesMutex);
    return result;
}

		    Tcl_SetStringObj(objPtr, buf, -1);
		} else {
		    TclSetIntObj(objPtr, wideValue);
		}
	    } else if (flags & SCAN_BIG) {
		if (flags & SCAN_UNSIGNED) {
		    mp_int big;
		    int code = Tcl_GetBignumFromObj(interp, objPtr, &big);

		    if (code == TCL_OK) {
			if (mp_isneg(&big)) {
			    code = TCL_ERROR;
			}
			mp_clear(&big);
		    }

		    if (code == TCL_ERROR) {
			if (objs != NULL) {
			    ckfree(objs);
			}
			Tcl_DecrRefCount(objPtr);
			Tcl_SetObjResult(interp, Tcl_NewStringObj(
				"unsigned bignum scans are invalid", -1));
			Tcl_SetErrorCode(interp, "TCL", "FORMAT",
				"BADUNSIGNED",NULL);
			return TCL_ERROR;
		    }
		}
	    } else {
		if (TclGetLongFromObj(NULL, objPtr, &value) != TCL_OK) {
		    if (TclGetString(objPtr)[0] == '-') {
			value = LONG_MIN;

}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_GetUniChar --
 *
 *	Get the index'th Unicode character from the String object. If index
 *	is out of range or it references a low surrogate preceded by a high
 *	surrogate, the result = -1;
 *
 * Results:
 *	Returns the index'th Unicode character in the Object.
 *
 * Side effects:
 *	Fills unichar with the index'th Unicode character.
 *
 *----------------------------------------------------------------------
 */

int
Tcl_GetUniChar(
    Tcl_Obj *objPtr,		/* The object to get the Unicode charater
				 * from. */
    int index)			/* Get the index'th Unicode character. */
{
    String *stringPtr;
    int ch, length;

    if (index < 0) {
	return -1;
    }

    /*
     * Optimize the case where we're really dealing with a bytearray object
     * we don't need to convert to a string to perform the indexing operation.
     */

    if (TclIsPureByteArray(objPtr)) {
	unsigned char *bytes = Tcl_GetByteArrayFromObj(objPtr, &length);
	if (index >= length) {
		return -1;
	}

	return (int) bytes[index];
    }

    /*
     * OK, need to work with the object as a string.
     */

    SetStringFromAny(NULL, objPtr);

	}
	if (stringPtr->numChars == objPtr->length) {
	    return (Tcl_UniChar) objPtr->bytes[index];
	}
	FillUnicodeRep(objPtr);
	stringPtr = GET_STRING(objPtr);
    }

    if (index >= stringPtr->numChars) {
	return -1;
    }
	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;
	    }
	}
#endif
    return ch;
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_GetUnicode --
 *

Tcl_GetRange(
    Tcl_Obj *objPtr,		/* The Tcl object to find the range of. */
    int first,			/* First index of the range. */
    int last)			/* Last index of the range. */
{
    Tcl_Obj *newObjPtr;		/* The Tcl object to find the range of. */
    String *stringPtr;
    int length;

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

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

    /*
     * OK, need to work with the object as a string.
     */

    SetStringFromAny(NULL, objPtr);
    stringPtr = GET_STRING(objPtr);

    if (stringPtr->hasUnicode == 0) {
	/*
	 * If numChars is unknown, compute it.
	 */

	if (stringPtr->numChars == -1) {
	    TclNumUtfChars(stringPtr->numChars, objPtr->bytes, objPtr->length);
	}
	if (stringPtr->numChars == objPtr->length) {
	    if (last >= stringPtr->numChars) {
		last = stringPtr->numChars - 1;
	    }
	    if (last < first) {
		return Tcl_NewObj();
	    }
	    newObjPtr = Tcl_NewStringObj(objPtr->bytes + first, last-first+1);

	    /*
	     * Since we know the char length of the result, store it.
	     */

	    SetStringFromAny(NULL, newObjPtr);
	    stringPtr = GET_STRING(newObjPtr);
	    stringPtr->numChars = newObjPtr->length;
	    return newObjPtr;
	}
	FillUnicodeRep(objPtr);
	stringPtr = GET_STRING(objPtr);
    }
	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)) {

		    numChars = precision;
		    Tcl_IncrRefCount(segment);
		    allocSegment = 1;
		}
	    }
	    break;
	case 'c': {
	    char buf[4];
	    int code, length;

	    if (TclGetIntFromObj(interp, segment, &code) != TCL_OK) {
		goto error;
	    }
	    length = Tcl_UniCharToUtf(code, buf);
	    segment = Tcl_NewStringObj(buf, length);

		    goto error;
		}
		cmpResult = mp_cmp_d(&big, 0);
		isNegative = (cmpResult == MP_LT);
		if (cmpResult == MP_EQ) gotHash = 0;
		if (ch == 'u') {
		    if (isNegative) {
			mp_clear(&big);
			msg = "unsigned bignum format is invalid";
			errCode = "BADUNSIGNED";
			goto errorMsg;
		    } else {
			ch = 'd';
		    }
		}

	    if ((objPtr->bytes == NULL) || (objPtr->length)) {
		int more;
		char *src = Tcl_GetStringFromObj(objPtr, &more);
		memcpy(dst, src, (size_t) more);
		dst += more;
	    }
	}
	/* Must NUL-terminate! */
	*dst = '\0';
    }
    return objResultPtr;

  overflow:
    if (interp) {
	Tcl_SetObjResult(interp, Tcl_ObjPrintf(
		    "max size for a Tcl value (%d bytes) exceeded", INT_MAX));

#define stringRealloc(ptr, numChars) \
    (String *) ckrealloc((ptr), STRING_SIZE(numChars))
#define stringAttemptRealloc(ptr, numChars) \
    (String *) attemptckrealloc((ptr), STRING_SIZE(numChars))
#define GET_STRING(objPtr) \
    ((String *) (objPtr)->internalRep.twoPtrValue.ptr1)
#define SET_STRING(objPtr, stringPtr) \
    ((objPtr)->internalRep.twoPtrValue.ptr2 = NULL),			\
    ((objPtr)->internalRep.twoPtrValue.ptr1 = (void *) (stringPtr))

/*
 * Local Variables:
 * mode: c
 * c-basic-offset: 4
 * fill-column: 78

Tcl_TraceObjCmd(
    ClientData dummy,		/* Not used. */
    Tcl_Interp *interp,		/* Current interpreter. */
    int objc,			/* Number of arguments. */
    Tcl_Obj *const objv[])	/* Argument objects. */
{
    int optionIndex;
#ifndef TCL_REMOVE_OBSOLETE_TRACES
    const char *name;
    const char *flagOps, *p;
#endif
    /* Main sub commands to 'trace' */
    static const char *const traceOptions[] = {
	"add", "info", "remove",
#ifndef TCL_REMOVE_OBSOLETE_TRACES
	"variable", "vdelete", "vinfo",
#endif
	NULL

	Tcl_SetObjResult(interp, resultListPtr);
	break;
    }
#endif /* TCL_REMOVE_OBSOLETE_TRACES */
    }
    return TCL_OK;

#ifndef TCL_REMOVE_OBSOLETE_TRACES
  badVarOps:
    Tcl_SetObjResult(interp, Tcl_ObjPrintf(
	    "bad operations \"%s\": should be one or more of rwua",
	    flagOps));
    Tcl_SetErrorCode(interp, "TCL", "OPERATION", "TRACE", "BADOPS", NULL);
    return TCL_ERROR;
#endif
}

/*
 *----------------------------------------------------------------------
 *
 * TraceExecutionObjCmd --
 *

	length = (size_t) commandLength;
	if ((enum traceOptions) optionIndex == TRACE_ADD) {
	    CombinedTraceVarInfo *ctvarPtr = ckalloc(
		    TclOffset(CombinedTraceVarInfo, traceCmdInfo.command)
		    + 1 + length);

	    ctvarPtr->traceCmdInfo.flags = flags;
#ifndef TCL_REMOVE_OBSOLETE_TRACES
	    if (objv[0] == NULL) {
		ctvarPtr->traceCmdInfo.flags |= TCL_TRACE_OLD_STYLE;
	    }
#endif
	    ctvarPtr->traceCmdInfo.length = length;
	    flags |= TCL_TRACE_UNSETS | TCL_TRACE_RESULT_OBJECT;
	    memcpy(ctvarPtr->traceCmdInfo.command, command, length+1);
	    ctvarPtr->traceInfo.traceProc = TraceVarProc;
	    ctvarPtr->traceInfo.clientData = &ctvarPtr->traceCmdInfo;
	    ctvarPtr->traceInfo.flags = flags;
	    name = Tcl_GetString(objv[3]);

	     */

	    name = Tcl_GetString(objv[3]);
	    FOREACH_VAR_TRACE(interp, name, clientData) {
		TraceVarInfo *tvarPtr = clientData;

		if ((tvarPtr->length == length)
			&& ((tvarPtr->flags
#ifndef TCL_REMOVE_OBSOLETE_TRACES
& ~TCL_TRACE_OLD_STYLE
#endif
						)==flags)
			&& (strncmp(command, tvarPtr->command,
				(size_t) length) == 0)) {
		    Tcl_UntraceVar2(interp, name, NULL,
			    flags | TCL_TRACE_UNSETS | TCL_TRACE_RESULT_OBJECT,
			    TraceVarProc, clientData);
		    break;
		}

    if (TclIsVarUndefined(varPtr)) {
	TclCleanupVar(varPtr, arrayPtr);
	return NULL;
    }

    return varPtr;
}

/*
 *----------------------------------------------------------------------
 *
 * TclCheckArrayTraces --
 *
 *	This function is invoked to when we operate on an array variable,
 *	to allow any array traces to fire.
 *
 * Results:
 *	Returns TCL_OK to indicate normal operation. Returns TCL_ERROR if
 *	invocation of a trace function indicated an error. When TCL_ERROR is
 *	returned, then error information is left in interp.
 *
 * Side effects:
 *	Almost anything can happen, depending on trace; this function itself
 *	doesn't have any side effects.
 *
 *----------------------------------------------------------------------
 */

int
TclCheckArrayTraces(
    Tcl_Interp *interp,
    Var *varPtr,
    Var *arrayPtr,
    Tcl_Obj *name,
    int index)
{
    int code = TCL_OK;

    if (varPtr && (varPtr->flags & VAR_TRACED_ARRAY)
	&& (TclIsVarArray(varPtr) || TclIsVarUndefined(varPtr))) {
	Interp *iPtr = (Interp *)interp;

	code = TclObjCallVarTraces(iPtr, arrayPtr, varPtr, name, NULL,
		(TCL_NAMESPACE_ONLY|TCL_GLOBAL_ONLY| TCL_TRACE_ARRAY),
		/* leaveErrMsg */ 1, index);
    }
    return code;
}

/*
 *----------------------------------------------------------------------
 *
 * TclCallVarTraces --
 *
 *	This function is invoked to find and invoke relevant trace functions

{
    if ((unsigned)(ch - 1) < (UNICODE_SELF - 1)) {
	return 1;
    }
    if (ch <= 0x7FF) {
	return 2;
    }

    if (((unsigned)(ch - 0x10000) <= 0xFFFFF)) {
	return 4;
    }

    return 3;
}

/*
 *---------------------------------------------------------------------------
 *
 * Tcl_UniCharToUtf --

int
Tcl_UniCharToUtf(
    int ch,			/* The Tcl_UniChar to be stored in the
				 * buffer. */
    char *buf)			/* Buffer in which the UTF-8 representation of
				 * the Tcl_UniChar is stored. Buffer must be
				 * large enough to hold the UTF-8 character
				 * (at most 4 bytes). */
{
    if ((unsigned)(ch - 1) < (UNICODE_SELF - 1)) {
	buf[0] = (char) ch;
	return 1;
    }
    if (ch >= 0) {
	if (ch <= 0x7FF) {
	    buf[1] = (char) ((ch | 0x80) & 0xBF);
	    buf[0] = (char) ((ch >> 6) | 0xC0);
	    return 2;
	}
	if (ch <= 0xFFFF) {

	    if ((ch & 0xF800) == 0xD800) {
		if (ch & 0x0400) {
		    /* Low surrogate */
		    if (((buf[0] & 0xF8) == 0xF0) && ((buf[1] & 0xC0) == 0x80)
			    && ((buf[2] & 0xCF) == 0)) {
			/* Previous Tcl_UniChar was a High surrogate, so combine */
			buf[3] = (char) ((ch & 0x3F) | 0x80);
			buf[2] |= (char) (((ch >> 6) & 0x0F) | 0x80);
			return 4;
		    }
		    /* Previous Tcl_UniChar was not a High surrogate, so just output */
		} else {
		    /* High surrogate */
		    ch += 0x40;
		    /* Fill buffer with specific 3-byte (invalid) byte combination,
		       so following Low surrogate can recognize it and combine */
		    buf[2] = (char) ((ch << 4) & 0x30);
		    buf[1] = (char) (((ch >> 2) & 0x3F) | 0x80);
		    buf[0] = (char) (((ch >> 8) & 0x07) | 0xF0);
		    return 0;
		}
	    }

	    goto three;
	}


	if (ch <= 0x10FFFF) {
	    buf[3] = (char) ((ch | 0x80) & 0xBF);
	    buf[2] = (char) (((ch >> 6) | 0x80) & 0xBF);
	    buf[1] = (char) (((ch >> 12) | 0x80) & 0xBF);
	    buf[0] = (char) ((ch >> 18) | 0xF0);
	    return 4;
	}

    }

    ch = 0xFFFD;
three:
    buf[2] = (char) ((ch | 0x80) & 0xBF);
    buf[1] = (char) (((ch >> 6) | 0x80) & 0xBF);
    buf[0] = (char) ((ch >> 12) | 0xE0);

				 * to this previously initialized DString. */
{
    const Tcl_UniChar *w, *wEnd;
    char *p, *string;
    int oldLength;

    /*
     * UTF-8 string length in bytes will be <= Unicode string length * 4.

     */

    oldLength = Tcl_DStringLength(dsPtr);
    Tcl_DStringSetLength(dsPtr, (oldLength + uniLength + 1) * 4);
    string = Tcl_DStringValue(dsPtr) + oldLength;

    p = string;
    wEnd = uniStr + uniLength;
    for (w = uniStr; w < wEnd; ) {
	p += Tcl_UniCharToUtf(*w, p);
	w++;

 *	number of bytes from the UTF-8 string that were consumed.
 *
 * Side effects:
 *	None.
 *
 *---------------------------------------------------------------------------
 */

static const unsigned short cp1252[32] = {
  0x20ac,   0x81, 0x201A, 0x0192, 0x201E, 0x2026, 0x2020, 0x2021,
  0x02C6, 0x2030, 0x0160, 0x2039, 0x0152,   0x8D, 0x017D,   0x8F,
    0x90, 0x2018, 0x2019, 0x201C, 0x201D, 0x2022, 0x2013, 0x2014,
   0x2DC, 0x2122, 0x0161, 0x203A, 0x0153,   0x9D, 0x017E, 0x0178
};

int
Tcl_UtfToUniChar(
    register const char *src,	/* The UTF-8 string. */
    register Tcl_UniChar *chPtr)/* Filled with the Tcl_UniChar represented by
				 * the UTF-8 string. */
{
    register int byte;

    /*
     * Unroll 1 to 3 (or 4) byte UTF-8 sequences.
     */

    byte = *((unsigned char *) src);
    if (byte < 0xC0) {
	/*
	 * Handles properly formed UTF-8 characters between 0x01 and 0x7F.
	 * Treats naked trail bytes 0x80 to 0x9F as valid characters from
	 * the cp1252 table. See: <https://en.wikipedia.org/wiki/UTF-8>
	 * Also treats \0 and other naked trail bytes 0xA0 to 0xBF as valid
	 * characters representing themselves.
	 */

	if ((unsigned)(byte-0x80) < (unsigned) 0x20) {
	    *chPtr = (Tcl_UniChar) cp1252[byte-0x80];
	} else {
	    *chPtr = (Tcl_UniChar) byte;
	}
	return 1;
    } else if (byte < 0xE0) {
	if ((src[1] & 0xC0) == 0x80) {
	    /*
	     * Two-byte-character lead-byte followed by a trail-byte.
	     */

	 */
    }
    else if (byte < 0xF8) {
	if (((src[1] & 0xC0) == 0x80) && ((src[2] & 0xC0) == 0x80) && ((src[3] & 0xC0) == 0x80)) {
	    /*
	     * Four-byte-character lead byte followed by three trail bytes.
	     */
#if TCL_UTF_MAX <= 4










	    Tcl_UniChar surrogate;

	    byte = (((byte & 0x07) << 18) | ((src[1] & 0x3F) << 12)
		    | ((src[2] & 0x3F) << 6) | (src[3] & 0x3F)) - 0x10000;
	    surrogate = (Tcl_UniChar) (0xD800 + (byte >> 10));
	    if (byte & 0x100000) {
		/* out of range, < 0x10000 or > 0x10ffff */

{
    int len, fullchar;
    Tcl_UniChar find = 0;

    while (1) {
	len = TclUtfToUniChar(src, &find);
	fullchar = find;
#if TCL_UTF_MAX <= 4
	if (!len) {
	    len += TclUtfToUniChar(src, &find);
	    fullchar = (((fullchar & 0x3ff) << 10) | (find & 0x3ff)) + 0x10000;
	}
#endif
	if (fullchar == ch) {
	    return src;

    Tcl_UniChar find = 0;
    const char *last;

    last = NULL;
    while (1) {
	len = TclUtfToUniChar(src, &find);
	fullchar = find;
#if TCL_UTF_MAX <= 4
	if (!len) {
	    len += TclUtfToUniChar(src, &find);
	    fullchar = (((fullchar & 0x3ff) << 10) | (find & 0x3ff)) + 0x10000;
	}
#endif
	if (fullchar == ch) {
	    last = src;

const char *
Tcl_UtfNext(
    const char *src)		/* The current location in the string. */
{
    Tcl_UniChar ch = 0;
    int len = TclUtfToUniChar(src, &ch);

#if TCL_UTF_MAX <= 4
    if (len == 0) {
      len = TclUtfToUniChar(src, &ch);
    }
#endif
    return src + len;
}


 *
 * Side effects:
 *	None.
 *
 *---------------------------------------------------------------------------
 */

int
Tcl_UniCharAtIndex(
    register const char *src,	/* The UTF-8 string to dereference. */
    register int index)		/* The position of the desired character. */
{
    Tcl_UniChar ch = 0;
    int fullchar = 0;
#if TCL_UTF_MAX <= 4
	int len = 1;
#endif

    while (index-- >= 0) {
#if TCL_UTF_MAX <= 4
	src += (len = TclUtfToUniChar(src, &ch));
#else
	src += TclUtfToUniChar(src, &ch);
#endif
    }
    fullchar = ch;
#if TCL_UTF_MAX <= 4
     if (!len) {
	/* If last Tcl_UniChar was an upper surrogate, combine with lower surrogate */
	(void)TclUtfToUniChar(src, &ch);
	fullchar = (((fullchar & 0x3ff) << 10) | (ch & 0x3ff)) + 0x10000;
    }
#endif
    return fullchar;
}

/*
 *---------------------------------------------------------------------------
 *
 * Tcl_UtfAtIndex --
 *
 *	Returns a pointer to the specified character (not byte) position in
 *	the UTF-8 string. If TCL_UTF_MAX <= 4, characters > U+FFFF count as
 *      2 positions, but then the pointer should never be placed between
 *      the two positions.
 *
 * Results:
 *	As above.
 *
 * Side effects:
 *	None.
 *
 *---------------------------------------------------------------------------
 */

const char *
Tcl_UtfAtIndex(
    register const char *src,	/* The UTF-8 string. */
    register int index)		/* The position of the desired character. */
{
    Tcl_UniChar ch = 0;
    int len = 1;

    while (index-- > 0) {
	len = TclUtfToUniChar(src, &ch);
	src += len;
    }
#if TCL_UTF_MAX <= 4
     if (!len) {
	/* Index points at character following High Surrogate */
	src += TclUtfToUniChar(src, &ch);
    }
#endif
    return src;
}

/*
 *---------------------------------------------------------------------------
 *
 * Tcl_UtfBackslash --

 *----------------------------------------------------------------------
 */

int
Tcl_UtfToUpper(
    char *str)			/* String to convert in place. */
{
    Tcl_UniChar ch = 0;
    int upChar;
    char *src, *dst;
    int bytes;

    /*
     * Iterate over the string until we hit the terminating null.
     */

    src = dst = str;
    while (*src) {
	bytes = TclUtfToUniChar(src, &ch);
	upChar = ch;
#if TCL_UTF_MAX <= 4
	if (!bytes) {
	    /* TclUtfToUniChar only returns 0 for chars > 0xffff ! */
	    bytes = TclUtfToUniChar(src, &ch);
	    /* Combine surrogates */
	    upChar = (((upChar & 0x3ff) << 10) | (ch & 0x3ff)) + 0x10000;
	}
#endif
	upChar = Tcl_UniCharToUpper(upChar);

	/*
	 * To keep badly formed Utf strings from getting inflated by the
	 * conversion (thereby causing a segfault), only copy the upper case
	 * char to dst if its size is <= the original char.
	 */

 *----------------------------------------------------------------------
 */

int
Tcl_UtfToLower(
    char *str)			/* String to convert in place. */
{
    Tcl_UniChar ch = 0;
    int lowChar;
    char *src, *dst;
    int bytes;

    /*
     * Iterate over the string until we hit the terminating null.
     */

    src = dst = str;
    while (*src) {
	bytes = TclUtfToUniChar(src, &ch);
	lowChar = ch;
#if TCL_UTF_MAX <= 4
	if (!bytes) {
	    /* TclUtfToUniChar only returns 0 for chars > 0xffff ! */
	    bytes = TclUtfToUniChar(src, &ch);
	    /* Combine surrogates */
	    lowChar = (((lowChar & 0x3ff) << 10) | (ch & 0x3ff)) + 0x10000;
	}
#endif
	lowChar = Tcl_UniCharToLower(lowChar);

	/*
	 * To keep badly formed Utf strings from getting inflated by the
	 * conversion (thereby causing a segfault), only copy the lower case
	 * char to dst if its size is <= the original char.
	 */

 *----------------------------------------------------------------------
 */

int
Tcl_UtfToTitle(
    char *str)			/* String to convert in place. */
{
    Tcl_UniChar ch = 0;
    int titleChar, lowChar;
    char *src, *dst;
    int bytes;

    /*
     * Capitalize the first character and then lowercase the rest of the
     * characters until we get to a null.
     */

    src = dst = str;

    if (*src) {
	bytes = TclUtfToUniChar(src, &ch);
	titleChar = ch;
#if TCL_UTF_MAX <= 4
	if (!bytes) {
	    /* TclUtfToUniChar only returns 0 for chars > 0xffff ! */
	    bytes = TclUtfToUniChar(src, &ch);
	    /* Combine surrogates */
	    titleChar = (((titleChar & 0x3ff) << 10) | (ch & 0x3ff)) + 0x10000;
	}
#endif
	titleChar = Tcl_UniCharToTitle(titleChar);

	if (bytes < TclUtfCount(titleChar)) {
	    memcpy(dst, src, (size_t) bytes);
	    dst += bytes;
	} else {
	    dst += Tcl_UniCharToUtf(titleChar, dst);
	}
	src += bytes;
    }
    while (*src) {
	bytes = TclUtfToUniChar(src, &ch);
	lowChar = ch;
#if TCL_UTF_MAX <= 4
	if (!bytes) {
	    /* TclUtfToUniChar only returns 0 for chars > 0xffff ! */
	    bytes = TclUtfToUniChar(src, &ch);
	    /* Combine surrogates */
	    lowChar = (((lowChar & 0x3ff) << 10) | (ch & 0x3ff)) + 0x10000;
	}
#endif
	lowChar = Tcl_UniCharToLower(lowChar);

	if (bytes < TclUtfCount(lowChar)) {
	    memcpy(dst, src, (size_t) bytes);
	    dst += bytes;
	} else {
	    dst += Tcl_UniCharToUtf(lowChar, dst);
	}

	 * only when both strings are of at least n chars long (no need for \0
	 * check)
	 */

	cs += TclUtfToUniChar(cs, &ch1);
	ct += TclUtfToUniChar(ct, &ch2);
	if (ch1 != ch2) {
#if TCL_UTF_MAX <= 4
	    /* Surrogates always report higher than non-surrogates */
	    if (((ch1 & 0xFC00) == 0xD800)) {
	    if ((ch2 & 0xFC00) != 0xD800) {
		return ch1;
	    }
	    } else if ((ch2 & 0xFC00) == 0xD800) {
		return -ch2;

	 * n must be interpreted as chars, not bytes.
	 * This should be called only when both strings are of
	 * at least n chars long (no need for \0 check)
	 */
	cs += TclUtfToUniChar(cs, &ch1);
	ct += TclUtfToUniChar(ct, &ch2);
	if (ch1 != ch2) {
#if TCL_UTF_MAX <= 4
	    /* Surrogates always report higher than non-surrogates */
	    if (((ch1 & 0xFC00) == 0xD800)) {
	    if ((ch2 & 0xFC00) != 0xD800) {
		return ch1;
	    }
	    } else if ((ch2 & 0xFC00) == 0xD800) {
		return -ch2;

{
    Tcl_UniChar ch1 = 0, ch2 = 0;

    while (*cs && *ct) {
	cs += TclUtfToUniChar(cs, &ch1);
	ct += TclUtfToUniChar(ct, &ch2);
	if (ch1 != ch2) {
#if TCL_UTF_MAX <= 4
	    /* Surrogates always report higher than non-surrogates */
	    if (((ch1 & 0xFC00) == 0xD800)) {
	    if ((ch2 & 0xFC00) != 0xD800) {
		return ch1;
	    }
	    } else if ((ch2 & 0xFC00) == 0xD800) {
		return -ch2;

{
    Tcl_UniChar ch1 = 0, ch2 = 0;

    while (*cs && *ct) {
	cs += TclUtfToUniChar(cs, &ch1);
	ct += TclUtfToUniChar(ct, &ch2);
	if (ch1 != ch2) {
#if TCL_UTF_MAX <= 4
	    /* Surrogates always report higher than non-surrogates */
	    if (((ch1 & 0xFC00) == 0xD800)) {
	    if ((ch2 & 0xFC00) != 0xD800) {
		return ch1;
	    }
	    } else if ((ch2 & 0xFC00) == 0xD800) {
		return -ch2;

 *
 * Side effects:
 *	None.
 *
 *----------------------------------------------------------------------
 */

int
Tcl_UniCharToUpper(
    int ch)			/* Unicode character to convert. */
{
    if (!UNICODE_OUT_OF_RANGE(ch)) {
	int info = GetUniCharInfo(ch);

	if (GetCaseType(info) & 0x04) {
	    ch -= GetDelta(info);
	}
    }
    return ch & 0x1FFFFF;
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_UniCharToLower --
 *
 *	Compute the lowercase equivalent of the given Unicode character.
 *
 * Results:
 *	Returns the lowercase Unicode character.
 *
 * Side effects:
 *	None.
 *
 *----------------------------------------------------------------------
 */

int
Tcl_UniCharToLower(
    int ch)			/* Unicode character to convert. */
{
    if (!UNICODE_OUT_OF_RANGE(ch)) {
	int info = GetUniCharInfo(ch);

	if (GetCaseType(info) & 0x02) {
	    ch += GetDelta(info);
	}
    }
    return ch & 0x1FFFFF;
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_UniCharToTitle --
 *
 *	Compute the titlecase equivalent of the given Unicode character.
 *
 * Results:
 *	Returns the titlecase Unicode character.
 *
 * Side effects:
 *	None.
 *
 *----------------------------------------------------------------------
 */

int
Tcl_UniCharToTitle(
    int ch)			/* Unicode character to convert. */
{
    if (!UNICODE_OUT_OF_RANGE(ch)) {
	int info = GetUniCharInfo(ch);
	int mode = GetCaseType(info);

	if (mode & 0x1) {
	    /*
	     * Subtract or add one depending on the original case.
	     */

	    ch += ((mode & 0x4) ? -1 : 1);
	} else if (mode == 0x4) {
	    ch -= GetDelta(info);
	}
    }
    return ch & 0x1FFFFF;
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_UniCharLen --
 *

 *----------------------------------------------------------------------
 */

int
Tcl_UniCharIsAlnum(
    int ch)			/* Unicode character to test. */
{

    if (UNICODE_OUT_OF_RANGE(ch)) {
	return 0;
    }

    return (((ALPHA_BITS | DIGIT_BITS) >> GetCategory(ch)) & 1);
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_UniCharIsAlpha --

 *----------------------------------------------------------------------
 */

int
Tcl_UniCharIsAlpha(
    int ch)			/* Unicode character to test. */
{

    if (UNICODE_OUT_OF_RANGE(ch)) {
	return 0;
    }

    return ((ALPHA_BITS >> GetCategory(ch)) & 1);
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_UniCharIsControl --

 *----------------------------------------------------------------------
 */

int
Tcl_UniCharIsControl(
    int ch)			/* Unicode character to test. */
{

    if (UNICODE_OUT_OF_RANGE(ch)) {
	ch &= 0x1FFFFF;
	if ((ch == 0xE0001) || ((ch >= 0xE0020) && (ch <= 0xE007f))) {
	    return 1;
	}
	if ((ch >= 0xF0000) && ((ch & 0xFFFF) <= 0xFFFD)) {
	    return 1;
	}
	return 0;
    }

    return ((CONTROL_BITS >> GetCategory(ch)) & 1);
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_UniCharIsDigit --

 *----------------------------------------------------------------------
 */

int
Tcl_UniCharIsDigit(
    int ch)			/* Unicode character to test. */
{

    if (UNICODE_OUT_OF_RANGE(ch)) {
	return 0;
    }

    return (GetCategory(ch) == DECIMAL_DIGIT_NUMBER);
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_UniCharIsGraph --

 *----------------------------------------------------------------------
 */

int
Tcl_UniCharIsGraph(
    int ch)			/* Unicode character to test. */
{

    if (UNICODE_OUT_OF_RANGE(ch)) {
	ch &= 0x1FFFFF;
	return (ch >= 0xE0100) && (ch <= 0xE01EF);
    }

    return ((GRAPH_BITS >> GetCategory(ch)) & 1);
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_UniCharIsLower --

 *----------------------------------------------------------------------
 */

int
Tcl_UniCharIsLower(
    int ch)			/* Unicode character to test. */
{

    if (UNICODE_OUT_OF_RANGE(ch)) {
	return 0;
    }

    return (GetCategory(ch) == LOWERCASE_LETTER);
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_UniCharIsPrint --

 *----------------------------------------------------------------------
 */

int
Tcl_UniCharIsPrint(
    int ch)			/* Unicode character to test. */
{

    if (UNICODE_OUT_OF_RANGE(ch)) {
	ch &= 0x1FFFFF;
	return (ch >= 0xE0100) && (ch <= 0xE01EF);
    }

    return (((GRAPH_BITS|SPACE_BITS) >> GetCategory(ch)) & 1);
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_UniCharIsPunct --

 *----------------------------------------------------------------------
 */

int
Tcl_UniCharIsPunct(
    int ch)			/* Unicode character to test. */
{

    if (UNICODE_OUT_OF_RANGE(ch)) {
	return 0;
    }

    return ((PUNCT_BITS >> GetCategory(ch)) & 1);
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_UniCharIsSpace --

 *----------------------------------------------------------------------
 */

int
Tcl_UniCharIsSpace(
    int ch)			/* Unicode character to test. */
{

    /* Ignore upper 11 bits. */
    ch &= 0x1FFFFF;





    /*
     * If the character is within the first 127 characters, just use the
     * standard C function, otherwise consult the Unicode table.
     */

    if (ch < 0x80) {
	return TclIsSpaceProc((char) ch);

    } else if (UNICODE_OUT_OF_RANGE(ch)) {
	return 0;

    } else if (ch == 0x0085 || ch == 0x180E || ch == 0x200B
	    || ch == 0x202F || ch == 0x2060 || ch == 0xFEFF) {
	return 1;
    } else {
	return ((SPACE_BITS >> GetCategory(ch)) & 1);
    }
}

 *----------------------------------------------------------------------
 */

int
Tcl_UniCharIsUpper(
    int ch)			/* Unicode character to test. */
{

    if (UNICODE_OUT_OF_RANGE(ch)) {
	return 0;
    }

    return (GetCategory(ch) == UPPERCASE_LETTER);
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_UniCharIsWordChar --

 *----------------------------------------------------------------------
 */

int
Tcl_UniCharIsWordChar(
    int ch)			/* Unicode character to test. */
{

    if (UNICODE_OUT_OF_RANGE(ch)) {
	return 0;
    }

    return ((WORD_BITS >> GetCategory(ch)) & 1);
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_UniCharCaseMatch --

/*
 * Forward references to functions defined later in this file:
 */

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 Tcl_NRPostProc   ArrayForLoopCallback;
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);
static int		LocateArray(Tcl_Interp *interp, Tcl_Obj *name,
			    Var **varPtrPtr, int *isArrayPtr);
static int		NotArrayError(Tcl_Interp *interp, Tcl_Obj *name);
static Tcl_Var		ObjFindNamespaceVar(Tcl_Interp *interp,
			    Tcl_Obj *namePtr, Tcl_Namespace *contextNsPtr,
			    int flags);
static int		ObjMakeUpvar(Tcl_Interp *interp,
			    CallFrame *framePtr, Tcl_Obj *otherP1Ptr,
			    const char *otherP2, const int otherFlags,
			    Tcl_Obj *myNamePtr, int myFlags, int index);
static ArraySearch *	ParseSearchId(Tcl_Interp *interp, const Var *varPtr,
			    Tcl_Obj *varNamePtr, Tcl_Obj *handleObj);
static void		UnsetVarStruct(Var *varPtr, Var *arrayPtr,
			    Interp *iPtr, Tcl_Obj *part1Ptr,
			    Tcl_Obj *part2Ptr, int flags, int index);


/*
 * Functions defined in this file that may be exported in the future for use
 * by the bytecode compiler and engine or to the public interface.
 */

MODULE_SCOPE Var *	TclLookupSimpleVar(Tcl_Interp *interp,

    keyPtr = Tcl_NewStringObj(key, -1);
    Tcl_IncrRefCount(keyPtr);
    varPtr = VarHashCreateVar(tablePtr, keyPtr, newPtr);
    Tcl_DecrRefCount(keyPtr);

    return varPtr;
}

static int
LocateArray(
    Tcl_Interp *interp,
    Tcl_Obj *name,
    Var **varPtrPtr,
    int *isArrayPtr)
{
    Var *arrayPtr, *varPtr = TclObjLookupVarEx(interp, name, NULL, /*flags*/ 0,
	    /*msg*/ 0, /*createPart1*/ 0, /*createPart2*/ 0, &arrayPtr);

    if (TclCheckArrayTraces(interp, varPtr, arrayPtr, name, -1) == TCL_ERROR) {
	return TCL_ERROR;
    }
    if (varPtrPtr) {
	*varPtrPtr = varPtr;
    }
    if (isArrayPtr) {
	*isArrayPtr = varPtr && !TclIsVarUndefined(varPtr)
		&& TclIsVarArray(varPtr);
    }
    return TCL_OK;
}

static int
NotArrayError(
    Tcl_Interp *interp,
    Tcl_Obj *name)
{
    const char *nameStr = Tcl_GetString(name);

    Tcl_SetObjResult(interp,
	    Tcl_ObjPrintf("\"%s\" isn't an array", nameStr));
    Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "ARRAY", nameStr, NULL);
    return TCL_ERROR;
}

/*
 *----------------------------------------------------------------------
 *
 * TclCleanupVar --
 *
 *	This function is called when it looks like it may be OK to free up a

    Tcl_SetObjResult(interp, newValuePtr);
    return TCL_OK;
}

/*
 *----------------------------------------------------------------------
 *
 * 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.
 *

 *  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() 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.
 *
 *----------------------------------------------------------------------
 */

static int
ArrayObjNext(
    Tcl_Interp *interp,
    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
				 * value written into, or NULL.*/
    )
{
    Tcl_Obj *keyObj;
    Tcl_Obj *valueObj = NULL;
    int     gotValue;
    int     donerc;

    donerc = TCL_BREAK;

    if ((varPtr->flags & VAR_SEARCH_ACTIVE) != VAR_SEARCH_ACTIVE) {
      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;
          }
        }
	varPtr = VarHashGetValue(hPtr);
	if (!TclIsVarUndefined(varPtr)) {
	    gotValue = 1;
	    break;
	}
    }

    if (! gotValue) {
	return donerc;
    }

    donerc = TCL_CONTINUE;

    keyObj = VarHashGetKey(varPtr);
    *keyPtrPtr = keyObj;
    valueObj = Tcl_ObjGetVar2(interp, arrayNameObj,
        keyObj, TCL_LEAVE_ERR_MSG);
    *valuePtrPtr = valueObj;

    return donerc;
}

int
ArrayForObjCmd(
    ClientData dummy,		/* Not used. */
    Tcl_Interp *interp,		/* Current interpreter. */
    int objc,			/* Number of arguments. */
    Tcl_Obj *const objv[])	/* Argument objects. */
{
    return Tcl_NRCallObjProc(interp, ArrayForNRCmd, dummy, objc, objv);
}

static int
ArrayForNRCmd(
    ClientData dummy,
    Tcl_Interp *interp,
    int objc,
    Tcl_Obj *const *objv)
{
    Tcl_Obj *varListObj, *arrayNameObj, *scriptObj;
    ArraySearch *searchPtr = NULL;
    Var *varPtr;
    int isArray, numVars;

    /*
     * array for {k v} a body
     */

    if (objc != 4) {
	Tcl_WrongNumArgs(interp, 1, objv,
		"{key value} arrayName script");
	return TCL_ERROR;
    }

    /*
     * Parse arguments.
     */

    if (Tcl_ListObjLength(interp, objv[1], &numVars) != TCL_OK) {
	return TCL_ERROR;
    }

    if (numVars != 2) {
	Tcl_SetObjResult(interp, Tcl_NewStringObj(
		"must have two variable names", -1));
	Tcl_SetErrorCode(interp, "TCL", "SYNTAX", "array", "for", NULL);
	return TCL_ERROR;
    }

    arrayNameObj = objv[2];

    if (TCL_ERROR == LocateArray(interp, arrayNameObj, &varPtr, &isArray)) {
	return TCL_ERROR;
    }

    if (!isArray) {
	return NotArrayError(interp, arrayNameObj);
    }

    /*
     * Make a new array search, put it on the stack.
     */

    searchPtr = ckalloc(sizeof(ArraySearch));
    ArrayPopulateSearch (interp, arrayNameObj, varPtr, searchPtr);

    /*
     * Make sure that these objects (which we need throughout the body of the
     * loop) don't vanish.
     */

    varListObj = TclListObjCopy(NULL, objv[1]);
    scriptObj = objv[3];
    Tcl_IncrRefCount(scriptObj);

    /*
     * Run the script.
     */

    TclNRAddCallback(interp, ArrayForLoopCallback, searchPtr, varListObj,
	    arrayNameObj, scriptObj);
    return TCL_OK;
}

static int
ArrayForLoopCallback(
    ClientData data[],
    Tcl_Interp *interp,
    int result)
{
    Interp *iPtr = (Interp *) interp;
    ArraySearch *searchPtr = data[0];
    Tcl_Obj *varListObj = data[1];
    Tcl_Obj *arrayNameObj = data[2];
    Tcl_Obj *scriptObj = data[3];
    Tcl_Obj **varv;
    Tcl_Obj *keyObj, *valueObj;
    Var *varPtr;
    Var *arrayPtr;
    int done, varc;

    /*
     * Process the result from the previous execution of the script body.
     */

    done = TCL_ERROR;

    if (result == TCL_CONTINUE) {
	result = TCL_OK;
    } else if (result != TCL_OK) {
	if (result == TCL_BREAK) {
	    Tcl_ResetResult(interp);
	    result = TCL_OK;
	} else if (result == TCL_ERROR) {
	    Tcl_AppendObjToErrorInfo(interp, Tcl_ObjPrintf(
		    "\n    (\"array for\" body line %d)",
		    Tcl_GetErrorLine(interp)));
	}
	goto arrayfordone;
    }

    /*
     * Get the next mapping from the array.
     */

    keyObj = NULL;
    valueObj = NULL;
    varPtr = TclObjLookupVarEx(interp, arrayNameObj, NULL, /*flags*/ 0,

	    /*msg*/ 0, /*createPart1*/ 0, /*createPart2*/ 0, &arrayPtr);
    if (varPtr == NULL) {
      done = TCL_ERROR;
    } else {
      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;
        }
	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 (valueObj != NULL) {
      if (Tcl_ObjSetVar2(interp, varv[1], NULL, valueObj, TCL_LEAVE_ERR_MSG) == NULL) {

        result = TCL_ERROR;
        goto arrayfordone;
      }


    }

    /*

     * Run the script.
     */

    TclNRAddCallback(interp, ArrayForLoopCallback, searchPtr, varListObj,
	    arrayNameObj, scriptObj);
    return TclNREvalObjEx(interp, scriptObj, 0, iPtr->cmdFramePtr, 3);




    /*
     * For unwinding everything once the iterating is done.
     */

  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);
	Tcl_DecrRefCount(searchPtr->name);
      ckfree(searchPtr);
    }

    TclDecrRefCount(varListObj);
    TclDecrRefCount(scriptObj);
    return result;
}


/*

 * ArrayPopulateSearch
 */
static void
ArrayPopulateSearch(
    Tcl_Interp  *interp,
    Tcl_Obj     *arrayNameObj,
    Var         *varPtr,
    ArraySearch *searchPtr)
{
    Interp *iPtr = (Interp *)interp;


    Tcl_HashEntry *hPtr;

    int isNew;



    hPtr = Tcl_CreateHashEntry(&iPtr->varSearches, varPtr, &isNew);
    if (isNew) {
	searchPtr->id = 1;
	varPtr->flags |= VAR_SEARCH_ACTIVE;
	searchPtr->nextPtr = NULL;
    } else {




	searchPtr->id = ((ArraySearch *) Tcl_GetHashValue(hPtr))->id + 1;


	searchPtr->nextPtr = Tcl_GetHashValue(hPtr);




    }









    searchPtr->varPtr = varPtr;





    searchPtr->nextEntry = VarHashFirstEntry(varPtr->value.tablePtr,




	    &searchPtr->search);










    Tcl_SetHashValue(hPtr, searchPtr);




    searchPtr->name = Tcl_ObjPrintf("s-%d-%s", searchPtr->id,






        TclGetString(arrayNameObj));






    Tcl_IncrRefCount(searchPtr->name);




}







/*
 *----------------------------------------------------------------------
 *
 * ArrayStartSearchCmd --
 *
 *	This object-based function is invoked to process the "array
 *	startsearch" Tcl command. See the user documentation for details on
 *	what it does.
 *
 * Results:
 *	A standard Tcl result object.
 *
 * Side effects:
 *	See the user documentation.
 *
 *----------------------------------------------------------------------
 */

	/* ARGSUSED */















































static int
ArrayStartSearchCmd(
    ClientData clientData,
    Tcl_Interp *interp,
    int objc,
    Tcl_Obj *const objv[])
{

    Var *varPtr;

    int isArray;
    ArraySearch *searchPtr;

    if (objc != 2) {
	Tcl_WrongNumArgs(interp, 1, objv, "arrayName");
	return TCL_ERROR;
    }

    if (TCL_ERROR == LocateArray(interp, objv[1], &varPtr, &isArray)) {

	return TCL_ERROR;
    }

    if (!isArray) {
	return NotArrayError(interp, objv[1]);
    }

    /*
     * Make a new array search with a free name.
     */

    searchPtr = ckalloc(sizeof(ArraySearch));
    ArrayPopulateSearch (interp, objv[1], varPtr, searchPtr);
    Tcl_SetObjResult(interp, searchPtr->name);
    return TCL_OK;
}

/*
 *----------------------------------------------------------------------
 *
 * ArrayDoneSearch --
 *
 *      Removes the search from the hash of active searches.
 *
 *----------------------------------------------------------------------
 */
static void
ArrayDoneSearch (
    Interp *iPtr,
    Var *varPtr,
    ArraySearch *searchPtr)
{
    Tcl_HashEntry *hPtr;
    ArraySearch *prevPtr;

    /*
     * Unhook the search from the list of searches associated with the
     * variable.
     */

    hPtr = Tcl_FindHashEntry(&iPtr->varSearches, varPtr);
    if (hPtr == NULL) {
      return;
    }
    if (searchPtr == Tcl_GetHashValue(hPtr)) {

	if (searchPtr->nextPtr) {
	    Tcl_SetHashValue(hPtr, searchPtr->nextPtr);

	} else {
	    varPtr->flags &= ~VAR_SEARCH_ACTIVE;
	    Tcl_DeleteHashEntry(hPtr);
	}
    } else {
	for (prevPtr=Tcl_GetHashValue(hPtr) ;; prevPtr=prevPtr->nextPtr) {
	    if (prevPtr->nextPtr == searchPtr) {
		prevPtr->nextPtr = searchPtr->nextPtr;
		break;
	    }
	}
    }
}

/*
 *----------------------------------------------------------------------
 *
 * ArrayAnyMoreCmd --
 *
 *	This object-based function is invoked to process the "array anymore"

    Tcl_Interp *interp,
    int objc,
    Tcl_Obj *const objv[])
{
    Interp *iPtr = (Interp *) interp;
    Var *varPtr;
    Tcl_Obj *varNameObj, *searchObj;
    int gotValue, isArray;
    ArraySearch *searchPtr;

    if (objc != 3) {
	Tcl_WrongNumArgs(interp, 1, objv, "arrayName searchId");
	return TCL_ERROR;
    }
    varNameObj = objv[1];
    searchObj = objv[2];

    if (TCL_ERROR == LocateArray(interp, varNameObj, &varPtr, &isArray)) {

	return TCL_ERROR;
    }

    if (!isArray) {
	return NotArrayError(interp, varNameObj);
    }

    /*
     * Get the search.
     */

    searchPtr = ParseSearchId(interp, varPtr, varNameObj, searchObj);
    if (searchPtr == NULL) {

    Tcl_Interp *interp,
    int objc,
    Tcl_Obj *const objv[])
{
    Var *varPtr;
    Tcl_Obj *varNameObj, *searchObj;
    ArraySearch *searchPtr;
    int isArray;

    if (objc != 3) {
	Tcl_WrongNumArgs(interp, 1, objv, "arrayName searchId");
	return TCL_ERROR;
    }
    varNameObj = objv[1];
    searchObj = objv[2];

    if (TCL_ERROR == LocateArray(interp, varNameObj, &varPtr, &isArray)) {

	return TCL_ERROR;
    }

    if (!isArray) {
	return NotArrayError(interp, varNameObj);
    }

    /*
     * Get the search.
     */

    searchPtr = ParseSearchId(interp, varPtr, varNameObj, searchObj);
    if (searchPtr == NULL) {

    ClientData clientData,
    Tcl_Interp *interp,
    int objc,
    Tcl_Obj *const objv[])
{
    Interp *iPtr = (Interp *) interp;
    Var *varPtr;

    Tcl_Obj *varNameObj, *searchObj;
    ArraySearch *searchPtr;
    int isArray;

    if (objc != 3) {
	Tcl_WrongNumArgs(interp, 1, objv, "arrayName searchId");
	return TCL_ERROR;
    }
    varNameObj = objv[1];
    searchObj = objv[2];

    if (TCL_ERROR == LocateArray(interp, varNameObj, &varPtr, &isArray)) {

	return TCL_ERROR;
    }

    if (!isArray) {
	return NotArrayError(interp, varNameObj);
    }

    /*
     * Get the search.
     */

    searchPtr = ParseSearchId(interp, varPtr, varNameObj, searchObj);
    if (searchPtr == NULL) {
	return TCL_ERROR;
    }





    ArrayDoneSearch (iPtr, varPtr, searchPtr);
















    Tcl_DecrRefCount(searchPtr->name);
    ckfree(searchPtr);
    return TCL_OK;
}

/*
 *----------------------------------------------------------------------

static int
ArrayExistsCmd(
    ClientData clientData,
    Tcl_Interp *interp,
    int objc,
    Tcl_Obj *const objv[])
{
    Interp *iPtr = (Interp *)interp;


    int isArray;

    if (objc != 2) {
	Tcl_WrongNumArgs(interp, 1, objv, "arrayName");
	return TCL_ERROR;
    }





    if (TCL_ERROR == LocateArray(interp, objv[1], NULL, &isArray)) {













	return TCL_ERROR;
    }








    Tcl_SetObjResult(interp, iPtr->execEnvPtr->constants[isArray]);
    return TCL_OK;
}

/*
 *----------------------------------------------------------------------
 *
 * ArrayGetCmd --

static int
ArrayGetCmd(
    ClientData clientData,
    Tcl_Interp *interp,
    int objc,
    Tcl_Obj *const objv[])
{

    Var *varPtr, *varPtr2;
    Tcl_Obj *varNameObj, *nameObj, *valueObj, *nameLstObj, *tmpResObj;
    Tcl_Obj **nameObjPtr, *patternObj;
    Tcl_HashSearch search;
    const char *pattern;
    int i, count, result, isArray;

    switch (objc) {
    case 2:
	varNameObj = objv[1];
	patternObj = NULL;
	break;
    case 3:
	varNameObj = objv[1];
	patternObj = objv[2];
	break;
    default:
	Tcl_WrongNumArgs(interp, 1, objv, "arrayName ?pattern?");
	return TCL_ERROR;
    }




    if (TCL_ERROR == LocateArray(interp, varNameObj, &varPtr, &isArray)) {













	return TCL_ERROR;
    }





    /* If not an array, it's an empty result. */

    if (!isArray) {


	return TCL_OK;
    }

    pattern = (patternObj ? TclGetString(patternObj) : NULL);

    /*
     * Store the array names in a new object.

    int objc,
    Tcl_Obj *const objv[])
{
    static const char *const options[] = {
	"-exact", "-glob", "-regexp", NULL
    };
    enum options { OPT_EXACT, OPT_GLOB, OPT_REGEXP };

    Var *varPtr, *varPtr2;
    Tcl_Obj *nameObj, *resultObj, *patternObj;
    Tcl_HashSearch search;
    const char *pattern = NULL;
    int isArray, mode = OPT_GLOB;

    if ((objc < 2) || (objc > 4)) {
	Tcl_WrongNumArgs(interp, 1, objv, "arrayName ?mode? ?pattern?");
	return TCL_ERROR;
    }

    patternObj = (objc > 2 ? objv[objc-1] : NULL);




    if (TCL_ERROR == LocateArray(interp, objv[1], &varPtr, &isArray)) {













	return TCL_ERROR;

    }

    /*
     * Finish parsing the arguments.
     */

    if ((objc == 4) && Tcl_GetIndexFromObj(interp, objv[2], options, "option",
	    0, &mode) != TCL_OK) {
	return TCL_ERROR;
    }




    /* If not an array, the result is empty. */


    if (!isArray) {

	return TCL_OK;
    }

    /*
     * Check for the trivial cases where we can use a direct lookup.
     */

static int
ArraySetCmd(
    ClientData clientData,
    Tcl_Interp *interp,
    int objc,
    Tcl_Obj *const objv[])
{
    Tcl_Obj *arrayNameObj;
    Tcl_Obj *arrayElemObj;
    Var *varPtr, *arrayPtr;
    int result, i;

    if (objc != 3) {
	Tcl_WrongNumArgs(interp, 1, objv, "arrayName list");
	return TCL_ERROR;
    }

    if (TCL_ERROR == LocateArray(interp, objv[1], NULL, NULL)) {
	return TCL_ERROR;
    }

    arrayNameObj = objv[1];
    varPtr = TclObjLookupVarEx(interp, arrayNameObj, NULL,
	    /*flags*/ TCL_LEAVE_ERR_MSG, /*msg*/ "set", /*createPart1*/ 1,
	    /*createPart2*/ 1, &arrayPtr);
    if (varPtr == NULL) {
	return TCL_ERROR;
    }
    if (arrayPtr) {
	CleanupVar(varPtr, arrayPtr);
	TclObjVarErrMsg(interp, arrayNameObj, NULL, "set", needArray, -1);
	Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "VARNAME",
		TclGetString(arrayNameObj), NULL);
	return TCL_ERROR;
    }

    /*
     * Install the contents of the dictionary or list into the array.
     */

    arrayElemObj = objv[2];
    if (arrayElemObj->typePtr == &tclDictType && arrayElemObj->bytes == NULL) {
	Tcl_Obj *keyPtr, *valuePtr;
	Tcl_DictSearch search;
	int done;

	if (Tcl_DictObjSize(interp, arrayElemObj, &done) != TCL_OK) {
	    return TCL_ERROR;
	}
	if (done == 0) {
	    /*
	     * Empty, so we'll just force the array to be properly existing
	     * instead.
	     */

	    goto ensureArray;
	}

	/*
	 * Don't need to look at result of Tcl_DictObjFirst as we've just
	 * successfully used a dictionary operation on the same object.
	 */

	for (Tcl_DictObjFirst(interp, arrayElemObj, &search,
		&keyPtr, &valuePtr, &done) ; !done ;
		Tcl_DictObjNext(&search, &keyPtr, &valuePtr, &done)) {
	    /*
	     * At this point, it would be nice if the key was directly usable
	     * by the array. This isn't the case though.
	     */

	    Var *elemVarPtr = TclLookupArrayElement(interp, arrayNameObj,
		    keyPtr, TCL_LEAVE_ERR_MSG, "set", 1, 1, varPtr, -1);

	    if ((elemVarPtr == NULL) ||
		    (TclPtrSetVarIdx(interp, elemVarPtr, varPtr, arrayNameObj,
		    keyPtr, valuePtr, TCL_LEAVE_ERR_MSG, -1) == NULL)) {
		Tcl_DictObjDone(&search);
		return TCL_ERROR;
	    }
	}
	return TCL_OK;
    } else {
	/*
	 * Not a dictionary, so assume (and convert to, for backward-
	 * -compatibility reasons) a list.
	 */

	int elemLen;
	Tcl_Obj **elemPtrs, *copyListObj;

	result = TclListObjGetElements(interp, arrayElemObj,
		&elemLen, &elemPtrs);
	if (result != TCL_OK) {
	    return result;
	}
	if (elemLen & 1) {
	    Tcl_SetObjResult(interp, Tcl_NewStringObj(
		    "list must have an even number of elements", -1));
	    Tcl_SetErrorCode(interp, "TCL", "ARGUMENT", "FORMAT", NULL);
	    return TCL_ERROR;
	}
	if (elemLen == 0) {
	    goto ensureArray;
	}

	/*
	 * We needn't worry about traces invalidating arrayPtr: should that be
	 * the case, TclPtrSetVarIdx will return NULL so that we break out of
	 * the loop and return an error.
	 */

	copyListObj = TclListObjCopy(NULL, arrayElemObj);
	for (i=0 ; i<elemLen ; i+=2) {
	    Var *elemVarPtr = TclLookupArrayElement(interp, arrayNameObj,
		    elemPtrs[i], TCL_LEAVE_ERR_MSG, "set", 1, 1, varPtr, -1);

	    if ((elemVarPtr == NULL) ||
		    (TclPtrSetVarIdx(interp, elemVarPtr, varPtr, arrayNameObj,
		    elemPtrs[i],elemPtrs[i+1],TCL_LEAVE_ERR_MSG,-1) == NULL)){
		result = TCL_ERROR;
		break;
	    }
	}
	Tcl_DecrRefCount(copyListObj);
	return result;
    }

    /*
     * The list is empty make sure we have an array, or create one if
     * necessary.
     */

  ensureArray:
    if (varPtr != NULL) {
	if (TclIsVarArray(varPtr)) {
	    /*
	     * Already an array, done.
	     */

	    return TCL_OK;
	}
	if (TclIsVarArrayElement(varPtr) || !TclIsVarUndefined(varPtr)) {
	    /*
	     * Either an array element, or a scalar: lose!
	     */

	    TclObjVarErrMsg(interp, arrayNameObj, NULL, "array set",
		    needArray, -1);
	    Tcl_SetErrorCode(interp, "TCL", "WRITE", "ARRAY", NULL);
	    return TCL_ERROR;
	}
    }
    TclSetVarArray(varPtr);
    varPtr->value.tablePtr = ckalloc(sizeof(TclVarHashTable));
    TclInitVarHashTable(varPtr->value.tablePtr, TclGetVarNsPtr(varPtr));
    return TCL_OK;
}

/*
 *----------------------------------------------------------------------
 *
 * ArraySizeCmd --
 *

static int
ArraySizeCmd(
    ClientData clientData,
    Tcl_Interp *interp,
    int objc,
    Tcl_Obj *const objv[])
{

    Var *varPtr;

    Tcl_HashSearch search;
    Var *varPtr2;
    int isArray, size = 0;

    if (objc != 2) {
	Tcl_WrongNumArgs(interp, 1, objv, "arrayName");
	return TCL_ERROR;
    }





    if (TCL_ERROR == LocateArray(interp, objv[1], &varPtr, &isArray)) {













	return TCL_ERROR;
    }





    /* We can only iterate over the array if it exists... */


    if (isArray) {
	/*
	 * Must iterate in order to get chance to check for present but
	 * "undefined" entries.
	 */

	for (varPtr2=VarHashFirstVar(varPtr->value.tablePtr, &search);
		varPtr2!=NULL ; varPtr2=VarHashNextVar(&search)) {

static int
ArrayStatsCmd(
    ClientData clientData,
    Tcl_Interp *interp,
    int objc,
    Tcl_Obj *const objv[])
{

    Var *varPtr;
    Tcl_Obj *varNameObj;
    char *stats;
    int isArray;

    if (objc != 2) {
	Tcl_WrongNumArgs(interp, 1, objv, "arrayName");
	return TCL_ERROR;
    }
    varNameObj = objv[1];




    if (TCL_ERROR == LocateArray(interp, varNameObj, &varPtr, &isArray)) {













	return TCL_ERROR;
    }

    if (!isArray) {





	return NotArrayError(interp, varNameObj);







    }

    stats = Tcl_HashStats((Tcl_HashTable *) varPtr->value.tablePtr);
    if (stats == NULL) {
	Tcl_SetObjResult(interp, Tcl_NewStringObj(
		"error reading array statistics", -1));
	return TCL_ERROR;

static int
ArrayUnsetCmd(
    ClientData clientData,
    Tcl_Interp *interp,
    int objc,
    Tcl_Obj *const objv[])
{

    Var *varPtr, *varPtr2, *protectedVarPtr;
    Tcl_Obj *varNameObj, *patternObj, *nameObj;
    Tcl_HashSearch search;
    const char *pattern;
    const int unsetFlags = 0;	/* Should this be TCL_LEAVE_ERR_MSG? */
    int isArray;

    switch (objc) {
    case 2:
	varNameObj = objv[1];
	patternObj = NULL;
	break;
    case 3:
	varNameObj = objv[1];
	patternObj = objv[2];
	break;
    default:
	Tcl_WrongNumArgs(interp, 1, objv, "arrayName ?pattern?");
	return TCL_ERROR;
    }




    if (TCL_ERROR == LocateArray(interp, varNameObj, &varPtr, &isArray)) {













	return TCL_ERROR;
    }

    if (!isArray) {








	return TCL_OK;
    }

    if (!patternObj) {
	/*
	 * When no pattern is given, just unset the whole array.
	 */

TclInitArrayCmd(
    Tcl_Interp *interp)		/* Current interpreter. */
{
    static const EnsembleImplMap arrayImplMap[] = {
	{"anymore",	ArrayAnyMoreCmd,	TclCompileBasic2ArgCmd, NULL, NULL, 0},
	{"donesearch",	ArrayDoneSearchCmd,	TclCompileBasic2ArgCmd, NULL, NULL, 0},
	{"exists",	ArrayExistsCmd,		TclCompileArrayExistsCmd, NULL, NULL, 0},
	{"for",		ArrayForObjCmd,		TclCompileBasic3ArgCmd, ArrayForNRCmd, NULL, 0},
	{"get",		ArrayGetCmd,		TclCompileBasic1Or2ArgCmd, NULL, NULL, 0},
	{"names",	ArrayNamesCmd,		TclCompileBasic1To3ArgCmd, NULL, NULL, 0},
	{"nextelement",	ArrayNextElementCmd,	TclCompileBasic2ArgCmd, NULL, NULL, 0},
	{"set",		ArraySetCmd,		TclCompileArraySetCmd, NULL, NULL, 0},
	{"size",	ArraySizeCmd,		TclCompileBasic1ArgCmd, NULL, NULL, 0},
	{"startsearch",	ArrayStartSearchCmd,	TclCompileBasic1ArgCmd, NULL, NULL, 0},
	{"statistics",	ArrayStatsCmd,		TclCompileBasic1ArgCmd, NULL, NULL, 0},

    Tcl_HashSearch search;
    Tcl_HashEntry *tPtr;
    register Var *elPtr;
    ActiveVarTrace *activePtr;
    Tcl_Obj *objPtr;
    VarTrace *tracePtr;




    for (elPtr = VarHashFirstVar(varPtr->value.tablePtr, &search);
	    elPtr != NULL; elPtr = VarHashNextVar(&search)) {
	if (TclIsVarScalar(elPtr) && (elPtr->value.objPtr != NULL)) {
	    objPtr = elPtr->value.objPtr;
	    TclDecrRefCount(objPtr);
	    elPtr->value.objPtr = NULL;
	}

# http.tcl --
#
#	Client-side HTTP for GET, POST, and HEAD commands. These routines can
#	be used in untrusted code that uses the Safesock security policy.
#	These procedures use a callback interface to avoid using vwait, which
#	is not defined in the safe base.
#
# 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.6-
# Keep this in sync with pkgIndex.tcl and with the install directories in
# Makefiles
package provide http 2.8.13

namespace eval http {
    # Allow resourcing to not clobber existing data

    variable http
    if {![info exists http]} {
	array set http {

	set state(connection) {}
    }
    if {![info exists sock]} {
	# Pass -myaddr directly to the socket command
	if {[info exists state(-myaddr)]} {
	    lappend sockopts -myaddr $state(-myaddr)
	}
        if {[catch {eval $defcmd $sockopts $targetAddr} sock errdict]} {
	    # something went wrong while trying to establish the connection.
	    # Clean up after events and such, but DON'T call the command
	    # callback (if available) because we're going to throw an
	    # exception from here instead.

	    set state(sock) $sock
	    Finish $token "" 1
	    cleanup $token
	    dict unset errdict -level
	    return -options $errdict $sock
        }
    }
    set state(sock) $sock
    Log "Using $sock for $state(socketinfo)" \
        [expr {$state(-keepalive)?"keepalive":""}]
    if {$state(-keepalive)} {
        set socketmap($state(socketinfo)) $sock

if {![package vsatisfies [package provide Tcl] 8.6-]} {return}
package ifneeded http 2.8.13 [list tclPkgSetup $dir http 2.8.13 {{http.tcl source {::http::config ::http::formatQuery ::http::geturl ::http::reset ::http::wait ::http::register ::http::unregister ::http::mapReply}}}]

    } -body {
	::msgcat::mcn [namespace current]::bar con1
    } -result con1bar


    interp bgerror {} $bgerrorsaved

    # Tests msgcat-18.*: [mcutil]

    test msgcat-18.1 {mcutil - no argument} -body {
	mcutil
    } -returnCodes 1\
    -result {wrong # args: should be "mcutil subcommand ?arg ...?"}

    test msgcat-18.2 {mcutil - wrong argument} -body {
	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
    test msgcat-18.7 {mcutil getsystemlocale} -body {
	mcutil getsystemlocale
	set ok ok
    } -result {ok}
    
    
    cleanupTests
}

    }
    foo
} {1 {"x" isn't an array}}
test set-old-8.6 {array command} {
    catch {unset a}
    set a(22) 3
    list [catch {array gorp a} msg] $msg
} {1 {unknown or ambiguous subcommand "gorp": must be anymore, donesearch, exists, for, get, names, nextelement, set, size, startsearch, statistics, or unset}}
test set-old-8.7 {array command, anymore option} {
    catch {unset a}
    list [catch {array anymore a x} msg] $msg
} {1 {"a" isn't an array}}
test set-old-8.8 {array command, anymore option, array doesn't exist yet but has compiler-allocated procedure slot} {
    proc foo {x} {
        if {$x==1} {

proc makeShared {s} {uplevel 1 [list lappend copy $s]; return $s}

# Some tests require the testobj command

testConstraint testobj [expr {[info commands testobj] ne {}}]
testConstraint testindexobj [expr {[info commands testindexobj] ne {}}]
testConstraint testevalex [expr {[info commands testevalex] ne {}}]
testConstraint tip389 [expr {[string length \U010000] == 2}]

# Used for constraining memory leak tests
testConstraint memory [llength [info commands memory]]
if {[testConstraint memory]} {
    proc getbytes {} {
        set lines [split [memory info] \n]
        return [lindex $lines 3 3]

} -match glob -result {1 {*}}
test string-5.19.$noComp {string index, bytearray object out of bounds} {
    run {string index [binary format I* {0x50515253 0x52}] -1}
} {}
test string-5.20.$noComp {string index, bytearray object out of bounds} {
    run {string index [binary format I* {0x50515253 0x52}] 20}
} {}
test string-5.21.$noComp {string index, surrogates, bug [11ae2be95dac9417]} tip389 {
    run {list [string index a\U100000b 1] [string index a\U100000b 2] [string index a\U100000b 3]}
} [list \U100000 {} b]


proc largest_int {} {
    # This will give us what the largest valid int on this machine is,
    # so we can test for overflow properly below on >32 bit systems
    set int 1
    set exp 7; # assume we get at least 8 bits

    list $input_hex $rxBuffer_hex $rxCRC_hex
} {000341 000341 0341}
test string-12.22.$noComp {string range, shimmering binary/index} {
    set s 0000000001
    binary scan $s a* x
    run {string range $s $s end}
} 000000001
test string-12.23.$noComp {string range, surrogates, bug [11ae2be95dac9417]} tip389 {
    run {list [string range a\U100000b 1 1] [string range a\U100000b 2 2] [string range a\U100000b 3 3]}
} [list \U100000 {} b]

test string-13.1.$noComp {string repeat} {
    list [catch {run {string repeat}} msg] $msg
} {1 {wrong # args: should be "string repeat string count"}}
test string-13.2.$noComp {string repeat} {

} "Abcabc\xe7\xe7"
test string-17.7.$noComp {string totitle, unicode} {
    run {string totitle \u01f3BCabc\xc7\xe7}
} "\u01f2bcabc\xe7\xe7"
test string-17.8.$noComp {string totitle, compiled} {
    lindex [run {string totitle [list aa bb [list cc]]}] 0
} Aa
test string-17.9.$noComp {string totitle, surrogates, bug [11ae2be95dac9417]} tip389 {
    run {list [string totitle a\U118c0c 1 1] [string totitle a\U118c0c 2 2] \
	[string totitle a\U118c0c 3 3]}
} [list a\U118a0c a\U118c0C a\U118c0C]

test string-18.1.$noComp {string trim} {
    list [catch {run {string trim}} msg] $msg
} {1 {wrong # args: should be "string trim string ?chars?"}}
test string-18.2.$noComp {string trim} {
    list [catch {run {string trim a b c}} msg] $msg
} {1 {wrong # args: should be "string trim string ?chars?"}}

    namespace eval :: {
	set t(1) 1
	trace variable t(1) u foo
	unset t
    }
    set x "If you see this, it worked"
} -result "If you see this, it worked"
test var-13.2 {unset array with search, bug 46a2410650} -body {
    apply {{} {
	array set a {aa 11 bb 22 cc 33 dd 44 ee 55 ff 66}
	set s [array startsearch a]
	unset a([array nextelement a $s])
	array nextelement a $s
    }}
} -returnCodes error -result {couldn't find search "s-1-a"}
test var-13.3 {unset array with search, SIGSEGV, bug 46a2410650} -body {
    apply {{} {
	array set a {aa 11 bb 22 cc 33 dd 44 ee 55 ff 66}
	set s [array startsearch a]
        unset a(ff)
	array nextelement a $s
    }}
} -returnCodes error -result {couldn't find search "s-1-a"}

test var-14.1 {array names syntax} -body {
    array names foo bar baz snafu
} -returnCodes 1 -match glob -result *
test var-14.2 {array names -glob} -body {
    array names tcl_platform -glob os
} -result os

	set elements {1 2 3 4}
	trace add variable a write "string length \$elements ;#"
	array set a $elements
    }
} -cleanup {
    unset -nocomplain ::a ::elements
} -result {}
test var-17.2 {TclArraySet Dict shortcut only on pure value} -setup {
    unset -nocomplain a d
    set d {p 1 p 2}
    dict get $d p
    set foo 0
} -body {
    trace add variable a write "[list incr [namespace which -variable foo]];#"
    array set a $d
    set foo
} -cleanup {
    unset -nocomplain a d foo
} -result 2

test var-18.1 {array unset and unset traces: Bug 2939073} -setup {
    set already 0
    unset -nocomplain x
} -body {
    array set x {e 1 i 1}
    trace add variable x unset {apply {args {

    vwait [namespace which -variable foo]
} -cleanup {
    unset -nocomplain lambda foo
} -result {}
test var-20.10 {[bc1a96407a] array set don't compile bad varname} -body {
    apply {{} {set name foo(bar); array set $name {a 1}}}
} -returnCodes error -match glob -result *
test var-20.11 {array set don't compile bad initializer} -setup {
    unset -nocomplain foo
    trace add variable foo array {set foo(bar) baz;#}
} -body {
    catch {array set foo bad}
    set foo(bar)
} -cleanup {
    unset -nocomplain foo
} -result baz
test var-20.12 {array set don't compile bad initializer} -setup {
    unset -nocomplain ::foo
    trace add variable ::foo array {set ::foo(bar) baz;#}
} -body {
    catch {apply {{} {
	set value bad
	array set ::foo $value

    }}}
    set ::foo(bar)
} -cleanup {
    unset -nocomplain ::foo
} -result baz

test var-21.0 {PushVarNameWord OBOE in compiled unset} -setup {
    proc linenumber {} {dict get [info frame -1] line}
} -body {
    apply {n {
	set foo bar
        unset foo {*}{

} -result 0
test var-22.2 {leak in parsedVarName} -constraints memory -body {
    set i 0
    leaktest {lappend x($i)}
} -cleanup {
    unset -nocomplain i x
} -result 0

unset -nocomplain a k v
test var-23.1 {array command, for loop, too many args} -returnCodes error -body {
    array for {k v} c d e {}
} -result {wrong # args: should be "array for {key value} arrayName script"}
test var-23.2 {array command, for loop, not enough args} -returnCodes error -body {
    array for {k v} {}
} -result {wrong # args: should be "array for {key value} arrayName script"}
test var-23.3 {array command, for loop, too many list args} -setup {
    unset -nocomplain a
} -returnCodes error -body {
    array for {k v w} a {}
} -result {must have two variable names}
test var-23.4 {array command, for loop, not enough list args} -setup {
    unset -nocomplain a
} -returnCodes error -body {
    array for {k} a {}
} -result {must have two variable names}
test var-23.5 {array command, for loop, no array} -setup {
    unset -nocomplain a
} -returnCodes error -body {
    array for {k v} a {}
} -result {"a" isn't an array}
test var-23.6 {array command, for loop, array doesn't exist yet but has compiler-allocated procedure slot} -setup {
    catch {rename p ""}
} -returnCodes error -body {
    apply {{x} {
        if {$x==1} {
            return [array for {k v} a {}]
        }
        set a(x) 123
    }} 1
} -result {"a" isn't an array}
test var-23.7 {array enumeration} -setup {
    unset -nocomplain a
    set reslist [list]
} -body {
    array set a {a 1 b 2 c 3}
    array for {k v} a {
	lappend reslist $k $v
    }
    lsort -stride 2 -index 0 $reslist
} -cleanup {
    unset -nocomplain a
    unset -nocomplain reslist
} -result {a 1 b 2 c 3}
test var-23.9 {array enumeration, nested} -setup {
    unset -nocomplain a
    set reslist [list]
} -body {
    array set a {a 1 b 2 c 3}
    array for {k1 v1} a {
	lappend reslist $k1 $v1
	set r2 {}
	array for {k2 v2} a {
	    lappend r2 $k2 $v2
	}
	lappend reslist [lsort -stride 2 -index 0 $r2]
    }
    # there is no guarantee in which order the array contents will be
    # returned.
    lsort -stride 3 -index 0 $reslist
} -cleanup {
    unset -nocomplain a
    unset -nocomplain reslist
} -result {a 1 {a 1 b 2 c 3} b 2 {a 1 b 2 c 3} c 3 {a 1 b 2 c 3}}
test var-23.10 {array enumeration, delete key} -match glob -setup {
    unset -nocomplain a
    set reslist [list]
} -body {
    set retval {}
    try {
      array set a {a 1 b 2 c 3 d 4}
      array for {k v} a {
  	lappend reslist $k $v
          if { $k eq "a" } {
            unset a(c)
          }
      }
      lsort -stride 2 -index 0 $reslist
    } on error {err res} {
      set retval [dict get $res -errorinfo]
    }
    set retval
} -cleanup {
    unset -nocomplain a
    unset -nocomplain reslist
    unset -nocomplain retval
} -result {array changed during iteration*}
test var-23.11 {array enumeration, insert key} -match glob -setup {
    unset -nocomplain a
    set reslist [list]
} -body {
    set retval {}
    try {
      array set a {a 1 b 2 c 3 d 4}
      array for {k v} a {
  	lappend reslist $k $v
          if { $k eq "a" } {
            set a(e) 5
          }
      }
      lsort -stride 2 -index 0 $reslist
    } on error {err res} {
      set retval [dict get $res -errorinfo]
    }
} -cleanup {
    unset -nocomplain a
    unset -nocomplain reslist
} -result {array changed during iteration*}
test var-23.12 {array enumeration, change value} -setup {
    unset -nocomplain a
    set reslist [list]
} -body {
    array set a {a 1 b 2 c 3}
    array for {k v} a {
	lappend reslist $k $v
        if { $k eq "a" } {
          set a(c) 9
        }
    }
    lsort -stride 2 -index 0 $reslist
} -cleanup {
    unset -nocomplain a
    unset -nocomplain reslist
} -result {a 1 b 2 c 9}
test var-23.13 {array enumeration, number of traces} -setup {
    set ::countarrayfor 0
    proc ::tracearrayfor { args } {
      incr ::countarrayfor
    }
    unset -nocomplain ::a
    set reslist [list]
} -body {
    array set ::a {a 1 b 2 c 3}
    foreach {k} [array names a] {
      trace add variable ::a($k) read ::tracearrayfor
    }
    array for {k v} ::a {
	lappend reslist $k $v
    }
    set ::countarrayfor
} -cleanup {
    unset -nocomplain ::countarrayfor
    unset -nocomplain ::a
    unset -nocomplain reslist
} -result 3
test var-23.14 {array for, shared arguments} -setup {
    set vn {k v}
    unset -nocomplain $vn
} -body {
    array set $vn {a 1 b 2 c 3}
    array for $vn $vn {}
} -cleanup {
    unset -nocomplain $vn vn
} -result {}

catch {namespace delete ns}
catch {unset arr}
catch {unset v}

catch {rename getbytes ""}
catch {rename p ""}

    }
    if {$args eq ""} {
	append text $rtype " *" $lfname "; /* $index */\n"
	return $text
    }
    if {[string range $rtype end-8 end] eq "__stdcall"} {
	append text [string trim [string range $rtype 0 end-9]] " (__stdcall *" $lfname ") "
    } elseif {[string range $rtype 0 11] eq "TCL_NORETURN"} {
	append text "TCL_NORETURN1 " [string trim [string range $rtype 12 end]] " (*" $lfname ") "
    } else {
	append text $rtype " (*" $lfname ") "
    }
    set arg1 [lindex $args 0]
    switch -exact $arg1 {
	void {
	    append text "(void)"

	    done;
	@echo "Installing library files to $(SCRIPT_INSTALL_DIR)/";
	@for i in $(TOP_DIR)/library/*.tcl $(TOP_DIR)/library/tclIndex \
		$(UNIX_DIR)/tclAppInit.c @LDAIX_SRC@ @DTRACE_SRC@; \
	    do \
	    $(INSTALL_DATA) $$i "$(SCRIPT_INSTALL_DIR)"; \
	    done;
	@echo "Installing package http 2.8.13 as a Tcl Module";
	@$(INSTALL_DATA) $(TOP_DIR)/library/http/http.tcl "$(SCRIPT_INSTALL_DIR)"/../tcl9/9.0/http-2.8.13.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.7.0 as a Tcl Module";
	@$(INSTALL_DATA) $(TOP_DIR)/library/msgcat/msgcat.tcl "$(SCRIPT_INSTALL_DIR)"/../tcl9/9.0/msgcat-1.7.0.tm;

	    $(COPY) "$$i" "$(INCLUDE_INSTALL_DIR)"; \
	    done;
	@echo "Installing library files to $(SCRIPT_INSTALL_DIR)";
	@for i in $(ROOT_DIR)/library/*.tcl $(ROOT_DIR)/library/tclIndex; \
	    do \
	    $(COPY) "$$i" "$(SCRIPT_INSTALL_DIR)"; \
	    done;
	@echo "Installing package http 2.8.13 as a Tcl Module";
	@$(COPY) $(ROOT_DIR)/library/http/http.tcl $(SCRIPT_INSTALL_DIR)/../tcl9/9.0/http-2.8.13.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.7.0 as a Tcl Module";
	@$(COPY) $(ROOT_DIR)/library/msgcat/msgcat.tcl $(SCRIPT_INSTALL_DIR)/../tcl9/9.0/msgcat-1.7.0.tm;