2008-10-23  Miguel Sofer  <msofer@users.sf.net>

	* generic/tclCmdAH.c (ForNextCallback): handle TCL_CONTINUE in
	the for body [Bug 2186888].

2008-10-22  Jan Nijtmans  <nijtmans@users.sf.net>

	* generic/tcl.h:              CONST -> const and white-spacing
	* generic/tclCompile.h:
	* generic/tclEncoding.c:
	* generic/tclStubInit.c:

	* generic/tclTomMathDecls.h:  (regenerated)
	* generic/tclIntDecls.h:      (regenerated)
	* tools/genStubs.tcl:         CONST -> const and white-spacing

2008-10-19  Don Porter  <dgp@users.sourceforge.net>

	* generic/tclProc.c:    Reset -level and -code values to defaults
	after they are used.  [Bug 2152286].

2008-10-19  Donal K. Fellows  <dkf@users.sf.net>

	* generic/tclBasic.c (TclInfoCoroutineCmd): Added code to make this
	check for being invoked in a syntactically correct way.

	* doc/info.n: Added documentation of [info coroutine].

'\"
'\" Copyright (c) 1997 Sun Microsystems, Inc.
'\"
'\" See the file "license.terms" for information on usage and redistribution
'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES.
'\" 
'\" RCS: @(#) $Id: ByteArrObj.3,v 1.3.20.2 2004/10/28 18:46:07 dgp Exp $
'\" 
.so man.macros
.TH Tcl_ByteArrayObj 3 8.1 Tcl "Tcl Library Procedures"
.BS
.SH NAME
Tcl_NewByteArrayObj, Tcl_SetByteArrayObj, Tcl_GetByteArrayFromObj, Tcl_SetByteArrayLength \- manipulate Tcl objects as a arrays of bytes 
.SH SYNOPSIS

\fBTcl_GetByteArrayFromObj\fR(\fIobjPtr, lengthPtr\fR)
.sp
unsigned char *
\fBTcl_SetByteArrayLength\fR(\fIobjPtr, length\fR)
.SH ARGUMENTS
.AS "const unsigned char" *lengthPtr in/out
.AP "const unsigned char" *bytes in
The array of bytes used to initialize or set a byte-array object.

.AP int length in
The length of the array of bytes.  It must be >= 0.
.AP Tcl_Obj *objPtr in/out
For \fBTcl_SetByteArrayObj\fR, this points to the object to be converted to
byte-array type.  For \fBTcl_GetByteArrayFromObj\fR and
\fBTcl_SetByteArrayLength\fR, this points to the object from which to get
the byte-array value; if \fIobjPtr\fR does not already point to a byte-array

string.  Conceptually, a string is an array of Unicode characters, while a
byte-array is an array of 8-bit quantities with no implicit meaning.
Accessor functions are provided to get the string representation of a
byte-array or to convert an arbitrary object to a byte-array.  Obtaining the
string representation of a byte-array object (by calling
\fBTcl_GetStringFromObj\fR) produces a properly formed UTF-8 sequence with a
one-to-one mapping between the bytes in the internal representation and the
UTF-8 characters in the string representation.  
.PP
\fBTcl_NewByteArrayObj\fR and \fBTcl_SetByteArrayObj\fR will
create a new object of byte-array type or modify an existing object to have a
byte-array type.  Both of these procedures set the object's type to be
byte-array and set the object's internal representation to a copy of the
array of bytes given by \fIbytes\fR. \fBTcl_NewByteArrayObj\fR returns a
pointer to a newly allocated object with a reference count of zero.
\fBTcl_SetByteArrayObj\fR invalidates any old string representation and, if
the object is not already a byte-array object, frees any old internal
representation.

.PP
\fBTcl_GetByteArrayFromObj\fR converts a Tcl object to byte-array type and
returns a pointer to the object's new internal representation as an array of
bytes.  The length of this array is stored in \fIlengthPtr\fR if
\fIlengthPtr\fR is non-NULL.  The storage for the array of bytes is owned by
the object and should not be freed.  The contents of the array may be
modified by the caller only if the object is not shared and the caller
invalidates the string representation.  
.PP
\fBTcl_SetByteArrayLength\fR converts the Tcl object to byte-array type
and changes the length of the object's internal representation as an
array of bytes.  If \fIlength\fR is greater than the space currently
allocated for the array, the array is reallocated to the new length; the
newly allocated bytes at the end of the array have arbitrary values.  If
\fIlength\fR is less than the space currently allocated for the array,

    /*
     * Count occurrences.
     */

    i = 0;
    for (p = begin; p <= stop && (i < max || max == INFINITY); p += len) {
	if ((*v->g->compare)(paren, p, len) != 0) {
	    break;
	}
	i++;
    }
    MDEBUG(("cbackref found %d\n", i));

    /*

/*
 * tclAsync.c --
 *
 *	This file provides low-level support needed to invoke signal handlers
 *	in a safe way. The code here doesn't actually handle signals, though.
 *	This code is based on proposals made by Mark Diekhans and Don Libes.
 *
 * Copyright (c) 1993 The Regents of the University of California.
 * Copyright (c) 1994 Sun Microsystems, Inc.
 *
 * See the file "license.terms" for information on usage and redistribution of
 * this file, and for a DISCLAIMER OF ALL WARRANTIES.
 *
 * RCS: @(#) $Id: tclAsync.c,v 1.6.14.6 2008/05/11 04:22:35 dgp Exp $
 */

#include "tclInt.h"

/* Forward declaration */
struct ThreadSpecificData;

	    }
	}
	if (asyncPtr == NULL) {
	    break;
	}
	asyncPtr->ready = 0;
	Tcl_MutexUnlock(&tsdPtr->asyncMutex);
	code = (*asyncPtr->proc)(asyncPtr->clientData, interp, code);
	Tcl_MutexLock(&tsdPtr->asyncMutex);
    }
    tsdPtr->asyncActive = 0;
    Tcl_MutexUnlock(&tsdPtr->asyncMutex);
    return code;
}


 * Copyright (c) 2007 Daniel A. Steffen <das@users.sourceforge.net>
 * Copyright (c) 2006-2008 by Joe Mistachkin.  All rights reserved.
 * Copyright (c) 2008 Miguel Sofer <msofer@users.sourceforge.net>
 *
 * See the file "license.terms" for information on usage and redistribution of
 * this file, and for a DISCLAIMER OF ALL WARRANTIES.
 *
 * RCS: @(#) $Id: tclBasic.c,v 1.82.2.113 2008/10/23 15:51:09 dgp Exp $
 */

#include "tclInt.h"
#include "tclOOInt.h"
#include "tclCompile.h"
#include <float.h>
#include <limits.h>

    {"switch",		Tcl_SwitchObjCmd,	TclCompileSwitchCmd,	NULL,	1},
    {"trace",		Tcl_TraceObjCmd,	NULL,			NULL,	1},
    {"unset",		Tcl_UnsetObjCmd,	NULL,			NULL,	1},
    {"uplevel",		Tcl_UplevelObjCmd,	NULL,			TclNRUplevelObjCmd,	1},
    {"upvar",		Tcl_UpvarObjCmd,	TclCompileUpvarCmd,	NULL,	1},
    {"variable",	Tcl_VariableObjCmd,	TclCompileVariableCmd,	NULL,	1},
    {"while",		Tcl_WhileObjCmd,	TclCompileWhileCmd,	TclNRWhileObjCmd,	1},
    
    {"coroutine",       NULL,                   NULL,                   TclNRCoroutineObjCmd,   1},
    {"yield",           NULL,                   NULL,                   TclNRYieldObjCmd,       1},
    
    /*
     * Commands in the OS-interface. Note that many of these are unsafe.
     */

    {"after",		Tcl_AfterObjCmd,	NULL,			NULL,	1},
    {"cd",		Tcl_CdObjCmd,		NULL,			NULL,	0},
    {"close",		Tcl_CloseObjCmd,	NULL,			NULL,	1},

	    a[i] = i < objc ? TclGetString(objv[i]) : NULL; i++;
	}
	TCL_DTRACE_CMD_ARGS(a[0], a[1], a[2], a[3], a[4], a[5], a[6], a[7],
		a[8], a[9]);
    }
    if (TCL_DTRACE_CMD_INFO_ENABLED() && iPtr->cmdFramePtr) {
	Tcl_Obj *info = TclInfoFrame(interp, iPtr->cmdFramePtr);
	char *a[6]; int i[2];

	TclDTraceInfo(info, a, i);
	TCL_DTRACE_CMD_INFO(a[0], a[1], a[2], a[3], i[0], i[1], a[4], a[5]);
	TclDecrRefCount(info);
    }
    if (TCL_DTRACE_CMD_RETURN_ENABLED() || TCL_DTRACE_CMD_RESULT_ENABLED()) {
	TclNRAddCallback(interp, DTraceCmdReturn, objv[0], NULL, NULL, NULL);

    }

    /*
     * We are returning to level 0, so should process TclResetCancellation. As
     * numLevels has not *yet* been decreased, do not call it: do the thing
     * here directly.
     */
    
    iPtr->flags &= (~(CANCELED | TCL_CANCEL_UNWIND));    
    return result;
}

static int
TEOV_Error(
    ClientData data[],
    Tcl_Interp *interp,

	    ProcessUnexpectedResult(interp, result);
	    result = TCL_ERROR;
	    script = Tcl_GetStringFromObj(objPtr, &numSrcBytes);
	    Tcl_LogCommandInfo(interp, script, script, numSrcBytes);
	}

	/*
	 * We are returning to level 0, so should call TclResetCancellation. 
	 * Let us just unset the flags inline.
	 */
	
	iPtr->flags &= (~(CANCELED | TCL_CANCEL_UNWIND));
    }
    iPtr->evalFlags = 0;

    /*
     * Restore the callFrame if this was a TCL_EVAL_GLOBAL.
     */

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

void
TclDTraceInfo(
    Tcl_Obj *info,
    char **args,
    int *argsi)
{
    static Tcl_Obj *keys[10] = { NULL };
    Tcl_Obj **k = keys, *val;
    int i = 0;

    if (!*k) {

	    a[i] = i < objc ? TclGetString(objv[i]) : NULL; i++;
	}
	TCL_DTRACE_CMD_ARGS(a[0], a[1], a[2], a[3], a[4], a[5], a[6], a[7],
		a[8], a[9]);
    }
    if (TCL_DTRACE_CMD_INFO_ENABLED() && ((Interp *) interp)->cmdFramePtr) {
	Tcl_Obj *info = TclInfoFrame(interp, ((Interp *) interp)->cmdFramePtr);
	char *a[6]; int i[2];

	TclDTraceInfo(info, a, i);
	TCL_DTRACE_CMD_INFO(a[0], a[1], a[2], a[3], i[0], i[1], a[4], a[5]);
	TclDecrRefCount(info);
    }
    if ((TCL_DTRACE_CMD_RETURN_ENABLED() || TCL_DTRACE_CMD_RESULT_ENABLED())
	    && objc) {

    ClientData clientData,
    Tcl_Interp *interp,
    int objc,
    Tcl_Obj *const objv[])
{
    CoroutineData *corPtr = iPtr->execEnvPtr->corPtr;
    int numLevels = iPtr->numLevels;
    
    if (objc > 2) {
	Tcl_WrongNumArgs(interp, 1, objv, "?returnValue?");
	return TCL_ERROR;
    }

    if (!corPtr) {
	Tcl_SetResult(interp, "yield can only be called in a coroutine",
		TCL_STATIC);
	return TCL_ERROR;
    }

    if (objc == 2) {
	Tcl_SetObjResult(interp, objv[1]);
    }

    iPtr->numLevels = corPtr->auxNumLevels;
    corPtr->auxNumLevels = numLevels - corPtr->auxNumLevels;
    
    TclNRAddCallback(interp, NRCallTEBC, INT2PTR(TCL_NR_YIELD_TYPE),
	    NULL, NULL, NULL);
    return TCL_OK;
}

static int
RewindCoroutine(

static void
DeleteCoroutine(
    ClientData clientData)
{
    CoroutineData *corPtr = clientData;
    Tcl_Interp *interp = corPtr->eePtr->interp;
    TEOV_callback *rootPtr = TOP_CB(interp);
    
    if (COR_IS_SUSPENDED(corPtr)) {
	TclNRRunCallbacks(interp, RewindCoroutine(corPtr,TCL_OK), rootPtr, 0);
    }
}

static void
PlugCoroutineChains(

    ClientData clientData,
    Tcl_Interp *interp,		/* Current interpreter. */
    int objc,			/* Number of arguments. */
    Tcl_Obj *const objv[])	/* Argument objects. */
{
    CoroutineData *corPtr = clientData;
    int nestNumLevels = corPtr->auxNumLevels;
    
    if ((objc != 1) && (objc != 2)) {
	Tcl_WrongNumArgs(interp, 1, objv, "?arg?");
	return TCL_ERROR;
    }

    if (!COR_IS_SUSPENDED(corPtr)) {
	Tcl_ResetResult(interp);

    corPtr->eePtr->corPtr = corPtr;
    corPtr->stackLevel = NULL;

    /*
     * On first run just set a 0 level-offset, the natural numbering is
     * correct. The offset will be fixed for later runs.
     */
    
    Tcl_DStringInit(&ds);
    if (nsPtr != iPtr->globalNsPtr) {
	Tcl_DStringAppend(&ds, nsPtr->fullName, -1);
	Tcl_DStringAppend(&ds, "::", 2);
    }
    Tcl_DStringAppend(&ds, procName, -1);

     * clumsy for now: we have the "lambda is a nameless proc" hack, we'd need
     * the cleaner "proc is a named lambda" to do this properly.
     */

    iPtr->varFramePtr = iPtr->rootFramePtr;
    iPtr->lookupNsPtr = iPtr->framePtr->nsPtr;
    corPtr->auxNumLevels = iPtr->numLevels;
    
    TclNRAddCallback(interp, NRCoroutineExitCallback, corPtr, NULL,NULL,NULL);
    return TclNRRunCallbacks(interp,
	    TclNREvalObjEx(interp, cmdObjPtr, 0, NULL, 0), rootPtr, 0);
}

/*
 * This is used in the [info] ensemble

    CoroutineData *corPtr = iPtr->execEnvPtr->corPtr;

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

    if (corPtr && !(corPtr->cmdPtr->flags & CMD_IS_DELETED)) { 
	Tcl_Obj *namePtr;

	TclNewObj(namePtr);
	Tcl_GetCommandFullName(interp, (Tcl_Command) corPtr->cmdPtr, namePtr);
	Tcl_SetObjResult(interp, namePtr);
    }
    return TCL_OK;

/*
 * tclBinary.c --
 *
 *	This file contains the implementation of the "binary" Tcl built-in
 *	command and the Tcl binary data object.
 *
 * Copyright (c) 1997 by Sun Microsystems, Inc.
 * Copyright (c) 1998-1999 by Scriptics Corporation.
 *
 * See the file "license.terms" for information on usage and redistribution of
 * this file, and for a DISCLAIMER OF ALL WARRANTIES.
 *
 * RCS: @(#) $Id: tclBinary.c,v 1.13.4.23 2008/10/17 20:52:23 dgp Exp $
 */

#include "tclInt.h"
#include "tommath.h"

#include <math.h>

			    int flags, Tcl_HashTable **numberCachePtr);
static int		SetByteArrayFromAny(Tcl_Interp *interp,
			    Tcl_Obj *objPtr);
static void		UpdateStringOfByteArray(Tcl_Obj *listPtr);
static void		DeleteScanNumberCache(Tcl_HashTable *numberCachePtr);
static int		NeedReversing(int format);
static void		CopyNumber(const void *from, void *to,
			    unsigned int length, int type);
/* Binary ensemble commands */
static int		BinaryFormatCmd(ClientData clientData, Tcl_Interp *interp,
			    int objc, Tcl_Obj *const objv[]);
static int		BinaryScanCmd(ClientData clientData, Tcl_Interp *interp,
			    int objc, Tcl_Obj *const objv[]);
/* Binary encoding sub-ensemble commands */
static int		BinaryEncodeHex(ClientData clientData, Tcl_Interp *interp,

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

void
Tcl_SetByteArrayObj(
    Tcl_Obj *objPtr,		/* Object to initialize as a ByteArray. */
    const unsigned char *bytes,	/* The array of bytes to use as the new
				 * value. */
    int length)			/* Length of the array of bytes, which must be
				 * >= 0. */
{
    ByteArray *byteArrayPtr;

    if (Tcl_IsShared(objPtr)) {
	Tcl_Panic("%s called with shared object", "Tcl_SetByteArrayObj");
    }
    TclFreeIntRep(objPtr);
    Tcl_InvalidateStringRep(objPtr);


    byteArrayPtr = (ByteArray *) ckalloc(BYTEARRAY_SIZE(length));

    byteArrayPtr->used = length;
    byteArrayPtr->allocated = length;

    memcpy(byteArrayPtr->bytes, bytes, (size_t) length);


    objPtr->typePtr = &tclByteArrayType;
    SET_BYTEARRAY(objPtr, byteArrayPtr);
}

/*
 *----------------------------------------------------------------------

    if (objPtr->typePtr != &tclByteArrayType) {
	src = TclGetStringFromObj(objPtr, &length);
	srcEnd = src + length;

	byteArrayPtr = (ByteArray *) ckalloc(BYTEARRAY_SIZE(length));
	for (dst = byteArrayPtr->bytes; src < srcEnd; ) {
	    src += Tcl_UtfToUniChar(src, &ch);
	    *dst++ = (unsigned char) ch;
	}

	byteArrayPtr->used = dst - byteArrayPtr->bytes;
	byteArrayPtr->allocated = length;

	TclFreeIntRep(objPtr);
	objPtr->typePtr = &tclByteArrayType;

}

/*
 *----------------------------------------------------------------------
 *
 * TclInitBinaryCmd --
 *
 *	This function is called to create the "binary" Tcl command. See the user
 *	documentation for details on what it does.
 *
 * Results:
 *	A command token for the new command.
 *
 * Side effects:
 *	Creates a new binary command as a mapped ensemble.
 *
 *----------------------------------------------------------------------
 */

Tcl_Command
TclInitBinaryCmd(Tcl_Interp *interp)
{
    Tcl_Namespace *nsTclPtr, *nsBinPtr, *nsEncPtr, *nsDecPtr;
    Tcl_Command binEnsemble, encEnsemble, decEnsemble;
    Tcl_Obj *binDict, *encDict, *decDict;

    /*
     * FIX ME: I so ugly - please make me pretty ...
     */

    nsTclPtr = Tcl_FindNamespace(interp, "::tcl",
	NULL, TCL_CREATE_NS_IF_UNKNOWN);
    if (nsTclPtr == NULL) {
	Tcl_Panic("unable to find or create ::tcl namespace!");
    }
    nsBinPtr = Tcl_FindNamespace(interp, "::tcl::binary",
	NULL, TCL_CREATE_NS_IF_UNKNOWN);
    if (nsBinPtr == NULL) {
	Tcl_Panic("unable to find or create ::tcl::binary namespace!");
    }
    binEnsemble = Tcl_CreateEnsemble(interp, "::binary",
	nsBinPtr, TCL_ENSEMBLE_PREFIX);

    nsEncPtr = Tcl_FindNamespace(interp, "::tcl::binary::encode",
	NULL, TCL_CREATE_NS_IF_UNKNOWN);
    if (nsEncPtr == NULL) {
	Tcl_Panic("unable to find or create ::tcl::binary::encode namespace!");
    }
    encEnsemble = Tcl_CreateEnsemble(interp, "encode",
	nsBinPtr, 0);

    nsDecPtr = Tcl_FindNamespace(interp, "::tcl::binary::decode",
	NULL, TCL_CREATE_NS_IF_UNKNOWN);
    if (nsDecPtr == NULL) {
	Tcl_Panic("unable to find or create ::tcl::binary::decode namespace!");
    }
    decEnsemble = Tcl_CreateEnsemble(interp, "decode",
	nsBinPtr, 0);

    TclNewObj(binDict);
    Tcl_DictObjPut(NULL, binDict, Tcl_NewStringObj("format",-1),
	Tcl_NewStringObj("::tcl::binary::format",-1));
    Tcl_DictObjPut(NULL, binDict, Tcl_NewStringObj("scan",-1),
	Tcl_NewStringObj("::tcl::binary::scan",-1));
    Tcl_DictObjPut(NULL, binDict, Tcl_NewStringObj("encode",-1),
	Tcl_NewStringObj("::tcl::binary::encode",-1));
    Tcl_DictObjPut(NULL, binDict, Tcl_NewStringObj("decode",-1),
	Tcl_NewStringObj("::tcl::binary::decode",-1));
    Tcl_CreateObjCommand(interp, "::tcl::binary::format",
	BinaryFormatCmd, NULL, NULL);
    Tcl_CreateObjCommand(interp, "::tcl::binary::scan",
	BinaryScanCmd, NULL, NULL);
    Tcl_SetEnsembleMappingDict(interp, binEnsemble, binDict);

    TclNewObj(encDict);
    Tcl_DictObjPut(NULL, encDict, Tcl_NewStringObj("hex",-1),
	Tcl_NewStringObj("::tcl::binary::encode::hex",-1));
    Tcl_DictObjPut(NULL, encDict, Tcl_NewStringObj("uuencode",-1),
	Tcl_NewStringObj("::tcl::binary::encode::uuencode",-1));
    Tcl_DictObjPut(NULL, encDict, Tcl_NewStringObj("base64",-1),
	Tcl_NewStringObj("::tcl::binary::encode::base64",-1));
    Tcl_CreateObjCommand(interp, "::tcl::binary::encode::hex",
	BinaryEncodeHex, (ClientData)HexDigits, NULL);
    Tcl_CreateObjCommand(interp, "::tcl::binary::encode::uuencode",
	BinaryEncode64, (ClientData)UueDigits, NULL);
    Tcl_CreateObjCommand(interp, "::tcl::binary::encode::base64",
	BinaryEncode64, (ClientData)B64Digits, NULL);
    Tcl_SetEnsembleMappingDict(interp, encEnsemble, encDict);

    TclNewObj(decDict);
    Tcl_DictObjPut(NULL, decDict, Tcl_NewStringObj("hex",-1),
	Tcl_NewStringObj("::tcl::binary::decode::hex",-1));
    Tcl_DictObjPut(NULL, decDict, Tcl_NewStringObj("uuencode",-1),
	Tcl_NewStringObj("::tcl::binary::decode::uuencode",-1));
    Tcl_DictObjPut(NULL, decDict, Tcl_NewStringObj("base64",-1),
	Tcl_NewStringObj("::tcl::binary::decode::base64",-1));
    Tcl_CreateObjCommand(interp, "::tcl::binary::decode::hex",
	BinaryDecodeHex, (ClientData)NULL, NULL);
    Tcl_CreateObjCommand(interp, "::tcl::binary::decode::uuencode",
	BinaryDecodeUu, (ClientData)NULL, NULL);
    Tcl_CreateObjCommand(interp, "::tcl::binary::decode::base64",
	BinaryDecode64, (ClientData)NULL, NULL);
    Tcl_SetEnsembleMappingDict(interp, decEnsemble, decDict);

    return binEnsemble;
}

/*
 *----------------------------------------------------------------------
 *
 * BinaryFormatCmd --
 *

			    value |= 1;
			} else if (str[offset] != '0') {
			    errorValue = str;
			    Tcl_DecrRefCount(resultPtr);
			    goto badValue;
			}
			if (((offset + 1) % 8) == 0) {
			    *cursor++ = (unsigned char) value;
			    value = 0;
			}
		    }
		} else {
		    for (offset = 0; offset < count; offset++) {
			value >>= 1;
			if (str[offset] == '1') {
			    value |= 128;
			} else if (str[offset] != '0') {
			    errorValue = str;
			    Tcl_DecrRefCount(resultPtr);
			    goto badValue;
			}
			if (!((offset + 1) % 8)) {
			    *cursor++ = (unsigned char) value;
			    value = 0;
			}
		    }
		}
		if ((offset % 8) != 0) {
		    if (cmd == 'B') {
			value <<= 8 - (offset % 8);
		    } else {
			value >>= 8 - (offset % 8);
		    }
		    *cursor++ = (unsigned char) value;
		}
		while (cursor < last) {
		    *cursor++ = '\0';
		}
		break;
	    }
	    case 'h':

			    c += ('0' - 'A') + 10;
			}
			if (c > 16) {
			    c += ('A' - 'a');
			}
			value |= ((c << 4) & 0xf0);
			if (offset % 2) {
			    *cursor++ = (unsigned char)(value & 0xff);
			    value = 0;
			}
		    }
		}
		if (offset % 2) {
		    if (cmd == 'H') {
			value <<= 4;
		    } else {
			value >>= 4;
		    }
		    *cursor++ = (unsigned char) value;
		}

		while (cursor < last) {
		    *cursor++ = '\0';
		}
		break;
	    }

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

static void
CopyNumber(
    const void *from,		/* source */
    void *to,			/* destination */
    unsigned int length,	/* Number of bytes to copy */
    int type)			/* What type of thing are we copying? */
{
    switch (NeedReversing(type)) {
    case 0:
	memcpy(to, from, length);
	break;
    case 1: {

    case 'w':
    case 'W':
    case 'm':
	if (Tcl_GetWideIntFromObj(interp, src, &wvalue) != TCL_OK) {
	    return TCL_ERROR;
	}
	if (NeedReversing(type)) {
	    *(*cursorPtr)++ = (unsigned char) wvalue;
	    *(*cursorPtr)++ = (unsigned char) (wvalue >> 8);
	    *(*cursorPtr)++ = (unsigned char) (wvalue >> 16);
	    *(*cursorPtr)++ = (unsigned char) (wvalue >> 24);
	    *(*cursorPtr)++ = (unsigned char) (wvalue >> 32);
	    *(*cursorPtr)++ = (unsigned char) (wvalue >> 40);
	    *(*cursorPtr)++ = (unsigned char) (wvalue >> 48);
	    *(*cursorPtr)++ = (unsigned char) (wvalue >> 56);
	} else {
	    *(*cursorPtr)++ = (unsigned char) (wvalue >> 56);
	    *(*cursorPtr)++ = (unsigned char) (wvalue >> 48);
	    *(*cursorPtr)++ = (unsigned char) (wvalue >> 40);
	    *(*cursorPtr)++ = (unsigned char) (wvalue >> 32);
	    *(*cursorPtr)++ = (unsigned char) (wvalue >> 24);
	    *(*cursorPtr)++ = (unsigned char) (wvalue >> 16);
	    *(*cursorPtr)++ = (unsigned char) (wvalue >> 8);
	    *(*cursorPtr)++ = (unsigned char) wvalue;
	}
	return TCL_OK;

	/*
	 * 32-bit integer values.
	 */
    case 'i':
    case 'I':
    case 'n':
	if (TclGetLongFromObj(interp, src, &value) != TCL_OK) {
	    return TCL_ERROR;
	}
	if (NeedReversing(type)) {
	    *(*cursorPtr)++ = (unsigned char) value;
	    *(*cursorPtr)++ = (unsigned char) (value >> 8);
	    *(*cursorPtr)++ = (unsigned char) (value >> 16);
	    *(*cursorPtr)++ = (unsigned char) (value >> 24);
	} else {
	    *(*cursorPtr)++ = (unsigned char) (value >> 24);
	    *(*cursorPtr)++ = (unsigned char) (value >> 16);
	    *(*cursorPtr)++ = (unsigned char) (value >> 8);
	    *(*cursorPtr)++ = (unsigned char) value;
	}
	return TCL_OK;

	/*
	 * 16-bit integer values.
	 */
    case 's':
    case 'S':
    case 't':
	if (TclGetLongFromObj(interp, src, &value) != TCL_OK) {
	    return TCL_ERROR;
	}
	if (NeedReversing(type)) {
	    *(*cursorPtr)++ = (unsigned char) value;
	    *(*cursorPtr)++ = (unsigned char) (value >> 8);
	} else {
	    *(*cursorPtr)++ = (unsigned char) (value >> 8);
	    *(*cursorPtr)++ = (unsigned char) value;
	}
	return TCL_OK;

	/*
	 * 8-bit integer values.
	 */
    case 'c':
	if (TclGetLongFromObj(interp, src, &value) != TCL_OK) {
	    return TCL_ERROR;
	}
	*(*cursorPtr)++ = (unsigned char) value;
	return TCL_OK;

    default:
	Tcl_Panic("unexpected fallthrough");
	return TCL_ERROR;
    }
}

		    + (buffer[1] << 8)
		    + (buffer[2] << 16)
		    + (((long)buffer[3]) << 24));
	} else {
	    value = (long) (buffer[3]
		    + (buffer[2] << 8)
		    + (buffer[1] << 16)
		    + (((long)buffer[0]) << 24));
	}

	/*
	 * Check to see if the value was sign extended properly on systems
	 * where an int is more than 32-bits.
	 * We avoid caching unsigned integers as we cannot distinguish between
	 * 32bit signed and unsigned in the hash (short and char are ok).
	 */

	if (flags & BINARY_UNSIGNED) {
	    return Tcl_NewWideIntObj((Tcl_WideInt)(unsigned long)value);
	}
	if ((value & (((unsigned int)1)<<31)) && (value > 0)) {
	    value -= (((unsigned int)1)<<31);
	    value -= (((unsigned int)1)<<31);
	}

    returnNumericObject:
	if (*numberCachePtrPtr == NULL) {
	    return Tcl_NewLongObj(value);
	} else {
	    register Tcl_HashTable *tablePtr = *numberCachePtrPtr;
	    register Tcl_HashEntry *hPtr;
	    int isNew;

	    hPtr = Tcl_CreateHashEntry(tablePtr, (char *)value, &isNew);
	    if (!isNew) {
		return (Tcl_Obj *) Tcl_GetHashValue(hPtr);
	    }
	    if (tablePtr->numEntries <= BINARY_SCAN_MAX_CACHE) {
		register Tcl_Obj *objPtr = Tcl_NewLongObj(value);

		Tcl_IncrRefCount(objPtr);
		Tcl_SetHashValue(hPtr, (ClientData) objPtr);
		return objPtr;
	    }

	    /*
	     * We've overflowed the cache! Someone's parsing a LOT of varied
	     * binary data in a single call! Bail out by switching back to the
	     * old behaviour for the rest of the scan.

	for (i=0 ; i<2 ; i++) {
	    if (data < dataend) {
		c = *data++;

		if (!isxdigit((int) c)) {
		    if (strict) {
			goto badChar;
		    } else {

			i--;
			continue;
		    }
		}
		value <<= 4;
		c -= '0';
		if (c > 9) {
		    c += ('0' - 'A') + 10;
		}
		if (c > 16) {

	for (i=0 ; i<4 ; i++) {
	    if (data < dataend) {
		d[i] = c = *data++;
		if (c < 33 || c > 96) {
		    if (strict) {
			goto badUu;
		    } else {

			i--;
			continue;
		    }
		}
	    } else {
		++cut;
	    }
	}
	*cursor++ = (((d[0] - 0x20) & 0x3f) << 2)
		| (((d[1] - 0x20) & 0x3f) >> 4);

/*
 * Local Variables:
 * mode: c
 * c-basic-offset: 4
 * fill-column: 78
 * End:
 */

/*
 * tclClock.c --
 *
 *	Contains the time and date related commands. This code is derived from
 *	the time and date facilities of TclX, by Mark Diekhans and Karl
 *	Lehenbauer.
 *
 * Copyright 1991-1995 Karl Lehenbauer and Mark Diekhans.
 * Copyright (c) 1995 Sun Microsystems, Inc.
 * Copyright (c) 2004 by Kevin B. Kenny.  All rights reserved.
 *
 * See the file "license.terms" for information on usage and redistribution of
 * this file, and for a DISCLAIMER OF ALL WARRANTIES.
 *
 * RCS: @(#) $Id: tclClock.c,v 1.23.2.26 2008/10/17 20:52:23 dgp Exp $
 */

#include "tclInt.h"

/*
 * Windows has mktime. The configurators do not check.
 */

#ifdef __WIN32__
#define HAVE_MKTIME 1
#endif

/*
 * Constants
 */

#define JULIAN_DAY_POSIX_EPOCH		2440588
#define SECONDS_PER_DAY			86400
#define JULIAN_SEC_POSIX_EPOCH	      (((Tcl_WideInt) JULIAN_DAY_POSIX_EPOCH) \
					* SECONDS_PER_DAY)
#define FOUR_CENTURIES			146097 /* days */
#define JDAY_1_JAN_1_CE_JULIAN		1721424
#define JDAY_1_JAN_1_CE_GREGORIAN	1721426
#define ONE_CENTURY_GREGORIAN		36524  /* days */
#define FOUR_YEARS			1461   /* days */
#define ONE_YEAR			365    /* days */

/*
 * Table of the days in each month, leap and common years
 */

static const int hath[2][12] = {
    {31, 28, 31, 30, 31, 30, 31, 31, 30, 31, 30, 31},

};

/*
 * Structure containing the client data for [clock]
 */

typedef struct ClockClientData {
    int refCount;		/* Number of live references */
    Tcl_Obj** literals;		/* Pool of object literals */
} ClockClientData;

/*
 * Structure containing the fields used in [clock format] and [clock scan]
 */

typedef struct TclDateFields {
    Tcl_WideInt seconds;	/* Time expressed in seconds from the Posix
				 * epoch */
    Tcl_WideInt localSeconds;	/* Local time expressed in nominal seconds
				 * from the Posix epoch */
    int tzOffset;		/* Time zone offset in seconds east of
				 * Greenwich */
    Tcl_Obj* tzName;		/* Time zone name */
    int julianDay;		/* Julian Day Number in local time zone */
    enum {BCE=1, CE=0} era;	/* Era */
    int gregorian;		/* Flag == 1 if the date is Gregorian */
    int year;			/* Year of the era */
    int dayOfYear;		/* Day of the year (1 January == 1) */
    int month;			/* Month number */
    int dayOfMonth;		/* Day of the month */

TCL_DECLARE_MUTEX(clockMutex)

/*
 * Function prototypes for local procedures in this file:
 */

static int		ConvertUTCToLocal(Tcl_Interp*,
			    TclDateFields*, Tcl_Obj*, int);
static int		ConvertUTCToLocalUsingTable(Tcl_Interp*,
			    TclDateFields*, int, Tcl_Obj *const[]);
static int		ConvertUTCToLocalUsingC(Tcl_Interp*,
			    TclDateFields*, int);
static int		ConvertLocalToUTC(Tcl_Interp*,
			    TclDateFields*, Tcl_Obj*, int);
static int		ConvertLocalToUTCUsingTable(Tcl_Interp*,
			    TclDateFields*, int, Tcl_Obj *const[]);
static int		ConvertLocalToUTCUsingC(Tcl_Interp*,
			    TclDateFields*, int);
static Tcl_Obj*		LookupLastTransition(Tcl_Interp*, Tcl_WideInt,
			    int, Tcl_Obj *const *);
static void		GetYearWeekDay(TclDateFields*, int);
static void		GetGregorianEraYearDay(TclDateFields*, int);
static void		GetMonthDay(TclDateFields*);
static void		GetJulianDayFromEraYearWeekDay(TclDateFields*, int);
static void		GetJulianDayFromEraYearMonthDay(TclDateFields*, int);
static int		IsGregorianLeapYear(TclDateFields*);
static int		WeekdayOnOrBefore(int, int);
static int		ClockClicksObjCmd(
			    ClientData clientData, Tcl_Interp *interp,
			    int objc, Tcl_Obj *const objv[]);
static int		ClockConvertlocaltoutcObjCmd(
			    ClientData clientData, Tcl_Interp *interp,
			    int objc, Tcl_Obj *const objv[]);

static int		ClockMicrosecondsObjCmd(
			    ClientData clientData, Tcl_Interp *interp,
			    int objc, Tcl_Obj *const objv[]);
static int		ClockMillisecondsObjCmd(
			    ClientData clientData, Tcl_Interp *interp,
			    int objc, Tcl_Obj *const objv[]);
static int		ClockParseformatargsObjCmd(
			    ClientData clientData, Tcl_Interp* interp,
			    int objc, Tcl_Obj *const objv[]);
static int		ClockSecondsObjCmd(
			    ClientData clientData, Tcl_Interp *interp,
			    int objc, Tcl_Obj *const objv[]);
static struct tm *	ThreadSafeLocalTime(const time_t *);
static void		TzsetIfNecessary(void);
static void		ClockDeleteCmdProc(ClientData);

    { "GetJulianDayFromEraYearMonthDay",
		ClockGetjuliandayfromerayearmonthdayObjCmd },
    { "GetJulianDayFromEraYearWeekDay",
    		ClockGetjuliandayfromerayearweekdayObjCmd },
    { "ParseFormatArgs",	ClockParseformatargsObjCmd },
    { NULL, NULL }
};

/*
 *----------------------------------------------------------------------
 *
 * TclClockInit --
 *
 *	Registers the 'clock' subcommands with the Tcl interpreter and
 *	initializes its client data (which consists mostly of constant

    /*
     * Create the client data, which is a refcounted literal pool.
     */

    data = (ClockClientData *) ckalloc(sizeof(ClockClientData));
    data->refCount = 0;
    data->literals = (Tcl_Obj**) ckalloc(LIT__END * sizeof(Tcl_Obj*));
    for (i = 0; i < LIT__END; ++i) {
	data->literals[i] = Tcl_NewStringObj(literals[i], -1);
	Tcl_IncrRefCount(data->literals[i]);
    }

    /*
     * Install the commands.
     */

    strcpy(cmdName, "::tcl::clock::");
#define TCL_CLOCK_PREFIX_LEN 14 /* == strlen("::tcl::clock::") */
    for (clockCmdPtr=clockCommands ; clockCmdPtr->name!=NULL ; clockCmdPtr++) {
	strcpy(cmdName + TCL_CLOCK_PREFIX_LEN, clockCmdPtr->name);
	data->refCount++;
	Tcl_CreateObjCommand(interp, cmdName, clockCmdPtr->objCmdProc, data,
		ClockDeleteCmdProc);
    }
}

/*
 *----------------------------------------------------------------------
 *
 * ClockConvertlocaltoutcObjCmd --
 *
 *	Tcl command that converts a UTC time to a local time by whatever means
 *	is available.

 *	leaves an error message in the interpreter result.
 *
 *----------------------------------------------------------------------
 */

static int
ClockConvertlocaltoutcObjCmd(
    ClientData clientData,	/* Client data  */
    Tcl_Interp* interp,		/* Tcl interpreter */
    int objc,			/* Parameter count */
    Tcl_Obj *const *objv)	/* Parameter vector */
{
    ClockClientData* data = (ClockClientData*) clientData;
    Tcl_Obj* const * literals = data->literals;
    Tcl_Obj* secondsObj;
    Tcl_Obj* dict;
    int changeover;
    TclDateFields fields;
    int created = 0;
    int status;

    /*
     * Check params and convert time.
     */

    if (objc != 4) {
	Tcl_WrongNumArgs(interp, 1, objv, "dict tzdata changeover");
	return TCL_ERROR;
    }
    dict = objv[1];
    if (Tcl_DictObjGet(interp, dict, literals[LIT_LOCALSECONDS],
		       &secondsObj)!= TCL_OK) {
	return TCL_ERROR;
    }
    if (secondsObj == NULL) {
	Tcl_SetObjResult(interp, Tcl_NewStringObj("key \"localseconds\" not "
						  "found in dictionary", -1));
	return TCL_ERROR;
    }
    if ((Tcl_GetWideIntFromObj(interp, secondsObj,
			      &(fields.localSeconds)) != TCL_OK)
	|| (TclGetIntFromObj(interp, objv[3], &changeover) != TCL_OK)
	|| ConvertLocalToUTC(interp, &fields, objv[2], changeover)) {
	return TCL_ERROR;
    }

    /*
     * Copy-on-write; set the 'seconds' field in the dictionary and place the

	Tcl_SetObjResult(interp, dict);
    }
    if (created) {
	Tcl_DecrRefCount(dict);
    }
    return status;
}

/*
 *----------------------------------------------------------------------
 *
 * ClockGetdatefieldsObjCmd --
 *
 *	Tcl command that determines the values that [clock format] will use in
 *	formatting a date, and populates a dictionary with them.
 *
 * Usage:
 *	::tcl::clock::GetDateFields seconds tzdata changeover
 *
 * Parameters:
 *	seconds - Time expressed in seconds from the Posix epoch.
 *	tzdata - Time zone data of the time zone in which time is to
 *                 be expressed.
 *	changeover - Julian Day Number at which the current locale adopted
 *		     the Gregorian calendar
 *
 * Results:
 *	Returns a dictonary populated with the fields:
 *		seconds - Seconds from the Posix epoch
 *		localSeconds - Nominal seconds from the Posix epoch in
 *			       the local time zone.
 *		tzOffset - Time zone offset in seconds east of Greenwich
 *		tzName - Time zone name
 *		julianDay - Julian Day Number in the local time zone
 *
 *----------------------------------------------------------------------
 */

int
ClockGetdatefieldsObjCmd(
    ClientData clientData,	/* Opaque pointer to literal pool, etc. */
    Tcl_Interp* interp,		/* Tcl interpreter */
    int objc,			/* Parameter count */
    Tcl_Obj *const *objv)	/* Parameter vector */
{
    TclDateFields fields;
    Tcl_Obj* dict;
    ClockClientData* data = (ClockClientData*) clientData;
    Tcl_Obj* const * literals = data->literals;
    int changeover;

    /*
     * Check params.
     */

    if (objc != 4) {
	Tcl_WrongNumArgs(interp, 1, objv, "seconds tzdata changeover");
	return TCL_ERROR;
    }
    if (Tcl_GetWideIntFromObj(interp, objv[1], &(fields.seconds)) != TCL_OK
	    || TclGetIntFromObj(interp, objv[3], &changeover) != TCL_OK) {
	return TCL_ERROR;
    }

    /*
     * fields.seconds could be an unsigned number that overflowed.  Make
     * sure that it isn't.
     */

    if (objv[1]->typePtr == &tclBignumType) {
	Tcl_SetObjResult(interp, literals[LIT_INTEGER_VALUE_TOO_LARGE]);
	return TCL_ERROR;
    }

	    Tcl_NewIntObj(fields.iso8601Week));
    Tcl_DictObjPut(NULL, dict, literals[LIT_DAYOFWEEK],
	    Tcl_NewIntObj(fields.dayOfWeek));
    Tcl_SetObjResult(interp, dict);

    return TCL_OK;
}

/*
 *----------------------------------------------------------------------
 *
 * ClockGetjuliandayfromerayearmonthdayObjCmd --
 *
 *	Tcl command that converts a time from era-year-month-day to a Julian
 *	Day Number.

 *	dictionary augmented with a 'julianDay' key, or TCL_ERROR,
 *	with the result being an error message.
 *
 *----------------------------------------------------------------------
 */

static int
ClockGetjuliandayfromerayearmonthdayObjCmd (
    ClientData clientData,	/* Opaque pointer to literal pool, etc. */
    Tcl_Interp* interp,		/* Tcl interpreter */
    int objc,			/* Parameter count */
    Tcl_Obj *const *objv)	/* Parameter vector */
{
    TclDateFields fields;
    Tcl_Obj* dict;
    ClockClientData* data = (ClockClientData*) clientData;
    Tcl_Obj* const * literals = data->literals;
    Tcl_Obj* fieldPtr;
    int changeover;
    int copied = 0;
    int status;
    int era = 0;

    /*
     * Check params.
     */

    if (objc != 3) {
	Tcl_WrongNumArgs(interp, 1, objv, "dict changeover");
	return TCL_ERROR;
    }
    dict = objv[1];
    if (Tcl_DictObjGet(interp, dict, literals[LIT_ERA], &fieldPtr) != TCL_OK
	    || Tcl_GetIndexFromObj(interp, fieldPtr, eras, "era", TCL_EXACT,
		&era) != TCL_OK
	    || Tcl_DictObjGet(interp, dict, literals[LIT_YEAR],
		&fieldPtr) != TCL_OK
	    || TclGetIntFromObj(interp, fieldPtr, &(fields.year)) != TCL_OK
	    || Tcl_DictObjGet(interp, dict, literals[LIT_MONTH],
		&fieldPtr) != TCL_OK
	    || TclGetIntFromObj(interp, fieldPtr, &(fields.month)) != TCL_OK
	    || Tcl_DictObjGet(interp, dict, literals[LIT_DAYOFMONTH],
		&fieldPtr) != TCL_OK
	    || TclGetIntFromObj(interp, fieldPtr,
		&(fields.dayOfMonth)) != TCL_OK
	    || TclGetIntFromObj(interp, objv[2], &changeover) != TCL_OK) {
	return TCL_ERROR;
    }
    fields.era = era;

    /*
     * Get Julian day.

	Tcl_SetObjResult(interp, dict);
    }
    if (copied) {
	Tcl_DecrRefCount(dict);
    }
    return status;
}

/*
 *----------------------------------------------------------------------
 *
 * ClockGetjuliandayfromerayearweekdayObjCmd --
 *
 *	Tcl command that converts a time from the ISO calendar to a Julian Day
 *	Number.

 *	dictionary augmented with a 'julianDay' key, or TCL_ERROR, with the
 *	result being an error message.
 *
 *----------------------------------------------------------------------
 */

static int
ClockGetjuliandayfromerayearweekdayObjCmd (
    ClientData clientData,	/* Opaque pointer to literal pool, etc. */
    Tcl_Interp* interp,		/* Tcl interpreter */
    int objc,			/* Parameter count */
    Tcl_Obj *const *objv)	/* Parameter vector */
{
    TclDateFields fields;
    Tcl_Obj* dict;
    ClockClientData* data = (ClockClientData*) clientData;
    Tcl_Obj* const * literals = data->literals;
    Tcl_Obj* fieldPtr;
    int changeover;
    int copied = 0;
    int status;
    int era = 0;

    /*
     * Check params.
     */

    if (objc != 3) {
	Tcl_WrongNumArgs(interp, 1, objv, "dict changeover");
	return TCL_ERROR;
    }
    dict = objv[1];
    if (Tcl_DictObjGet(interp, dict, literals[LIT_ERA], &fieldPtr) != TCL_OK
	    || Tcl_GetIndexFromObj(interp, fieldPtr, eras, "era", TCL_EXACT,
		&era) != TCL_OK
	    || Tcl_DictObjGet(interp, dict, literals[LIT_ISO8601YEAR],
		&fieldPtr) != TCL_OK
	    || TclGetIntFromObj(interp, fieldPtr,
		&(fields.iso8601Year)) != TCL_OK
	    || Tcl_DictObjGet(interp, dict, literals[LIT_ISO8601WEEK],
		&fieldPtr) != TCL_OK
	    || TclGetIntFromObj(interp, fieldPtr,
		&(fields.iso8601Week)) != TCL_OK
	    || Tcl_DictObjGet(interp, dict, literals[LIT_DAYOFWEEK],
		&fieldPtr) != TCL_OK
	    || TclGetIntFromObj(interp, fieldPtr,
		&(fields.dayOfWeek)) != TCL_OK
	    || TclGetIntFromObj(interp, objv[2], &changeover) != TCL_OK) {
	return TCL_ERROR;
    }
    fields.era = era;

    /*
     * Get Julian day.

	Tcl_SetObjResult(interp, dict);
    }
    if (copied) {
	Tcl_DecrRefCount(dict);
    }
    return status;
}

/*
 *----------------------------------------------------------------------
 *
 * ConvertLocalToUTC --
 *
 *	Converts a time (in a TclDateFields structure) from the local wall
 *	clock to UTC.
 *
 * Results:
 *	Returns a standard Tcl result.
 *
 * Side effects:
 *	Populates the 'seconds' field if successful; stores an error message
 *	in the interpreter result on failure.
 *
 *----------------------------------------------------------------------
 */

static int
ConvertLocalToUTC(
    Tcl_Interp* interp,		/* Tcl interpreter */
    TclDateFields* fields,	/* Fields of the time */
    Tcl_Obj* tzdata,		/* Time zone data */
    int changeover)		/* Julian Day of the Gregorian transition */
{
    int rowc;			/* Number of rows in tzdata */
    Tcl_Obj** rowv;		/* Pointers to the rows */

    /*
     * Unpack the tz data.
     */

    if (TclListObjGetElements(interp, tzdata, &rowc, &rowv) != TCL_OK) {
	return TCL_ERROR;
    }

    /*
     * Special case: If the time zone is :localtime, the tzdata will be empty.
     * Use 'mktime' to convert the time to local
     */

    if (rowc == 0) {
	return ConvertLocalToUTCUsingC(interp, fields, changeover);
    } else {
	return ConvertLocalToUTCUsingTable(interp, fields, rowc, rowv);
    }
}

/*
 *----------------------------------------------------------------------
 *
 * ConvertLocalToUTCUsingTable --
 *
 *	Converts a time (in a TclDateFields structure) from local time in a
 *	given time zone to UTC.
 *
 * Results:
 *	Returns a standard Tcl result.
 *
 * Side effects:
 *	Stores an error message in the interpreter if an error occurs; if
 *	successful, stores the 'seconds' field in 'fields.
 *
 *----------------------------------------------------------------------
 */

static int
ConvertLocalToUTCUsingTable(
    Tcl_Interp* interp,		/* Tcl interpreter */
    TclDateFields* fields,	/* Time to convert, with 'seconds' filled in */
    int rowc,			/* Number of points at which time changes */
    Tcl_Obj *const rowv[])	/* Points at which time changes */
{
    Tcl_Obj* row;
    int cellc;
    Tcl_Obj** cellv;
    int have[8];
    int nHave = 0;
    int i;
    int found;

    /*
     * Perform an initial lookup assuming that local == UTC, and locate the

    fields->seconds = fields->localSeconds;
    while (!found) {
	row = LookupLastTransition(interp, fields->seconds, rowc, rowv);
	if ((row == NULL)
		|| TclListObjGetElements(interp, row, &cellc,
		    &cellv) != TCL_OK
		|| TclGetIntFromObj(interp, cellv[1],
		    &(fields->tzOffset)) != TCL_OK) {
	    return TCL_ERROR;
	}
	found = 0;
	for (i = 0; !found && i < nHave; ++i) {
	    if (have[i] == fields->tzOffset) {
		found = 1;
		break;

	}
	fields->seconds = fields->localSeconds - fields->tzOffset;
    }
    fields->tzOffset = have[i];
    fields->seconds = fields->localSeconds - fields->tzOffset;
    return TCL_OK;
}

/*
 *----------------------------------------------------------------------
 *
 * ConvertLocalToUTCUsingC --
 *
 *	Converts a time from local wall clock to UTC when the local time zone
 *	cannot be determined. Uses 'mktime' to do the job.
 *
 * Results:
 *	Returns a standard Tcl result.
 *
 * Side effects:
 *	Stores an error message in the interpreter if an error occurs; if
 *	successful, stores the 'seconds' field in 'fields.
 *
 *----------------------------------------------------------------------
 */

static int
ConvertLocalToUTCUsingC(
    Tcl_Interp* interp,		/* Tcl interpreter */
    TclDateFields* fields,	/* Time to convert, with 'seconds' filled in */
    int changeover)		/* Julian Day of the Gregorian transition */
{
    struct tm timeVal;
    int localErrno;
    int secondOfDay;
    Tcl_WideInt jsec;

	    || (fields->seconds == -1 && timeVal.tm_yday == -1)) {
	Tcl_SetResult(interp, "time value too large/small to represent",
		TCL_STATIC);
	return TCL_ERROR;
    }
    return TCL_OK;
}

/*
 *----------------------------------------------------------------------
 *
 * ConvertUTCToLocal --
 *
 *	Converts a time (in a TclDateFields structure) from UTC to local time.
 *
 * Results:
 *	Returns a standard Tcl result.
 *
 * Side effects:
 *	Populates the 'tzName' and 'tzOffset' fields.
 *
 *----------------------------------------------------------------------
 */

static int
ConvertUTCToLocal(
    Tcl_Interp* interp,		/* Tcl interpreter */
    TclDateFields* fields,	/* Fields of the time */
    Tcl_Obj* tzdata,		/* Time zone data */
    int changeover)		/* Julian Day of the Gregorian transition */
{
    int rowc;			/* Number of rows in tzdata */
    Tcl_Obj** rowv;		/* Pointers to the rows */

    /*
     * Unpack the tz data.
     */

    if (TclListObjGetElements(interp, tzdata, &rowc, &rowv) != TCL_OK) {
	return TCL_ERROR;
    }

    /*
     * Special case: If the time zone is :localtime, the tzdata will be empty.
     * Use 'localtime' to convert the time to local
     */

    if (rowc == 0) {
	return ConvertUTCToLocalUsingC(interp, fields, changeover);
    } else {
	return ConvertUTCToLocalUsingTable(interp, fields, rowc, rowv);
    }
}

/*
 *----------------------------------------------------------------------
 *
 * ConvertUTCToLocalUsingTable --
 *
 *	Converts UTC to local time, given a table of transition points
 *
 * Results:
 *	Returns a standard Tcl result
 *
 * Side effects:
 *	On success, fills fields->tzName, fields->tzOffset and
 *	fields->localSeconds. On failure, places an error message in the
 *	interpreter result.
 *
 *----------------------------------------------------------------------
 */

static int
ConvertUTCToLocalUsingTable(
    Tcl_Interp* interp,		/* Tcl interpreter */
    TclDateFields* fields,	/* Fields of the date */
    int rowc,			/* Number of rows in the conversion table
				 * (>= 1) */
    Tcl_Obj *const rowv[])	/* Rows of the conversion table */
{
    Tcl_Obj* row;		/* Row containing the current information */
    int cellc;			/* Count of cells in the row (must be 4) */
    Tcl_Obj** cellv;		/* Pointers to the cells */

    /*
     * Look up the nearest transition time.
     */

    row = LookupLastTransition(interp, fields->seconds, rowc, rowv);
    if (row == NULL ||
	    TclListObjGetElements(interp, row, &cellc, &cellv) != TCL_OK ||
	    TclGetIntFromObj(interp,cellv[1],&(fields->tzOffset)) != TCL_OK) {
	return TCL_ERROR;
    }

    /*
     * Convert the time.
     */

    fields->tzName = cellv[3];
    Tcl_IncrRefCount(fields->tzName);
    fields->localSeconds = fields->seconds + fields->tzOffset;
    return TCL_OK;
}

/*
 *----------------------------------------------------------------------
 *
 * ConvertUTCToLocalUsingC --
 *
 *	Converts UTC to localtime in cases where the local time zone is not
 *	determinable, using the C 'localtime' function to do it.

 *	interpreter result.
 *
 *----------------------------------------------------------------------
 */

static int
ConvertUTCToLocalUsingC(
    Tcl_Interp* interp,		/* Tcl interpreter */
    TclDateFields* fields,	/* Time to convert, with 'seconds' filled in */
    int changeover)		/* Julian Day of the Gregorian transition */
{
    time_t tock;
    struct tm* timeVal;		/* Time after conversion */
    int diff;			/* Time zone diff local-Greenwich */
    char buffer[8];		/* Buffer for time zone name */

    /*
     * Use 'localtime' to determine local year, month, day, time of day.
     */

    if (diff > 0) {
	sprintf(buffer+5, "%02d", diff);
    }
    fields->tzName = Tcl_NewStringObj(buffer, -1);
    Tcl_IncrRefCount(fields->tzName);
    return TCL_OK;
}

/*
 *----------------------------------------------------------------------
 *
 * LookupLastTransition --
 *
 *	Given a UTC time and a tzdata array, looks up the last transition on
 *	or before the given time.
 *
 * Results:
 *	Returns a pointer to the row, or NULL if an error occurs.
 *
 *----------------------------------------------------------------------
 */

static Tcl_Obj*
LookupLastTransition(
    Tcl_Interp* interp,		/* Interpreter for error messages */
    Tcl_WideInt tick,		/* Time from the epoch */
    int rowc,			/* Number of rows of tzdata */
    Tcl_Obj *const *rowv)	/* Rows in tzdata */
{
    int l;
    int u;
    Tcl_Obj* compObj;
    Tcl_WideInt compVal;

    /*
     * Examine the first row to make sure we're in bounds.
     */

    if (Tcl_ListObjIndex(interp, rowv[0], 0, &compObj) != TCL_OK

	    l = m;
	} else {
	    u = m-1;
	}
    }
    return rowv[l];
}

/*
 *----------------------------------------------------------------------
 *
 * GetYearWeekDay --
 *
 *	Given a date with Julian Calendar Day, compute the year, week, and day
 *	in the ISO8601 calendar.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	Stores 'iso8601Year', 'iso8601Week' and 'dayOfWeek' in the date
 *	fields.
 *
 *----------------------------------------------------------------------
 */

static void
GetYearWeekDay(
    TclDateFields* fields,	/* Date to convert, must have 'julianDay' */
    int changeover)		/* Julian Day Number of the Gregorian
				 * transition */
{
    TclDateFields temp;
    int dayOfFiscalYear;

    /*

    dayOfFiscalYear = fields->julianDay - temp.julianDay;
    fields->iso8601Week = (dayOfFiscalYear / 7) + 1;
    fields->dayOfWeek = (dayOfFiscalYear + 1) % 7;
    if (fields->dayOfWeek < 1) {
	fields->dayOfWeek += 7;
    }
}

/*
 *----------------------------------------------------------------------
 *
 * GetGregorianEraYearDay --
 *
 *	Given a Julian Day Number, extracts the year and day of the year and
 *	puts them into TclDateFields, along with the era (BCE or CE) and a
 *	flag indicating whether the date is Gregorian or Julian.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	Stores 'era', 'gregorian', 'year', and 'dayOfYear'.
 *
 *----------------------------------------------------------------------
 */

static void
GetGregorianEraYearDay(
    TclDateFields* fields,	/* Date fields containing 'julianDay' */
    int changeover)		/* Gregorian transition date */
{
    int jday = fields->julianDay;
    int day;
    int year;
    int n;

	     * 31 December in the last year of a 400-year cycle.
	     */

	    n = 3;
	    day += ONE_CENTURY_GREGORIAN;
	}
	year += 100 * n;

    } else {
	/*
	 * Julian calendar.
	 */

	fields->gregorian = 0;
	year = 1;
	day = jday - JDAY_1_JAN_1_CE_JULIAN;

    }

    /*
     * n = number of 4-year cycles; days = remaining days.
     */

    n = day / FOUR_YEARS;

	fields->year = 1 - year;
    } else {
	fields->era = CE;
	fields->year = year;
    }
    fields->dayOfYear = day + 1;
}

/*
 *----------------------------------------------------------------------
 *
 * GetMonthDay --
 *
 *	Given a date as year and day-of-year, find month and day.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	Stores 'month' and 'dayOfMonth' in the 'fields' structure.
 *
 *----------------------------------------------------------------------
 */

static void
GetMonthDay(
    TclDateFields* fields)	/* Date to convert */
{
    int day = fields->dayOfYear;
    int month;
    const int* h = hath[IsGregorianLeapYear(fields)];

    for (month = 0; month < 12 && day > h[month]; ++month) {
	day -= h[month];
    }
    fields->month = month+1;
    fields->dayOfMonth = day;
}

/*
 *----------------------------------------------------------------------
 *
 * GetJulianDayFromEraYearWeekDay --
 *
 *	Given a TclDateFields structure containing era, ISO8601 year, ISO8601
 *	week, and day of week, computes the Julian Day Number.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	Stores 'julianDay' in the fields.
 *
 *----------------------------------------------------------------------
 */

static void
GetJulianDayFromEraYearWeekDay(
    TclDateFields* fields,	/* Date to convert */
    int changeover)		/* Julian Day Number of the Gregorian
				 * transition */
{
    int firstMonday;		/* Julian day number of week 1, day 1 in the
				 * given year */


    /*
     * Find January 4 in the ISO8601 year, which will always be in week 1.
     */

    TclDateFields firstWeek;
    firstWeek.era = fields->era;
    firstWeek.year = fields->iso8601Year;
    firstWeek.month = 1;
    firstWeek.dayOfMonth = 4;
    GetJulianDayFromEraYearMonthDay(&firstWeek, changeover);

    /*
     * Find Monday of week 1.
     */

    firstMonday = WeekdayOnOrBefore(1, firstWeek.julianDay);

    /*
     * Advance to the given week and day.
     */

    fields->julianDay = firstMonday + 7 * (fields->iso8601Week - 1)
	    + fields->dayOfWeek - 1;
}

/*
 *----------------------------------------------------------------------
 *
 * GetJulianDayFromEraYearMonthDay --
 *
 *	Given era, year, month, and dayOfMonth (in TclDateFields), and the
 *	Gregorian transition date, computes the Julian Day Number.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	Stores day number in 'julianDay'
 *
 *----------------------------------------------------------------------
 */

static void
GetJulianDayFromEraYearMonthDay(
    TclDateFields* fields,	/* Date to convert */
    int changeover)		/* Gregorian transition date as a Julian Day */
{
    int year;  int ym1;
    int month; int mm1;
    int q; int r;
    int ym1o4; int ym1o100; int ym1o400;

    if (fields->era == BCE) {
	year = 1 - fields->year;
    } else {
	year = fields->year;
    }

    if (fields->julianDay < changeover) {
	fields->gregorian = 0;
	fields->julianDay = JDAY_1_JAN_1_CE_JULIAN - 1
		+ fields->dayOfMonth
		+ daysInPriorMonths[year%4 == 0][month - 1]
		+ (365 * ym1)
	        + ym1o4;
    }
}

/*
 *----------------------------------------------------------------------
 *
 * IsGregorianLeapYear --
 *
 *	Tests whether a given year is a leap year, in either Julian or
 *	Gregorian calendar.
 *
 * Results:
 *	Returns 1 for a leap year, 0 otherwise.
 *
 *----------------------------------------------------------------------
 */

static int
IsGregorianLeapYear(
    TclDateFields* fields)	/* Date to test */
{
    int year;

    if (fields->era == BCE) {
	year = 1 - fields->year;
    } else {
	year = fields->year;
    }
    if (year%4 != 0) {
	return 0;
    } else if (!(fields->gregorian)) {
	return 1;
    } else if (year%400 == 0) {
	return 1;
    } else if (year%100 == 0) {
	return 0;
    } else {
	return 1;
    }
}

/*
 *----------------------------------------------------------------------
 *
 * WeekdayOnOrBefore --
 *
 *	Finds the Julian Day Number of a given day of the week that falls on
 *	or before a given date, expressed as Julian Day Number.

{
    int k = (dayOfWeek + 6) % 7;
    if (k < 0) {
	k += 7;
    }
    return julianDay - ((julianDay - k) % 7);
}

/*
 *----------------------------------------------------------------------
 *
 * ClockGetenvObjCmd --
 *
 *	Tcl command that reads an environment variable from the system
 *

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

int
ClockGetenvObjCmd(
    ClientData clientData,
    Tcl_Interp* interp,
    int objc,
    Tcl_Obj *const objv[])
{
    const char* varName;
    const char* varValue;

    if (objc != 2) {
	Tcl_WrongNumArgs(interp, 1, objv, "name");
	return TCL_ERROR;
    }
    varName = TclGetString(objv[1]);
    varValue = getenv(varName);
    if (varValue == NULL) {
	varValue = "";
    }
    Tcl_SetObjResult(interp, Tcl_NewStringObj(varValue, -1));
    return TCL_OK;
}

/*
 *----------------------------------------------------------------------
 *
 * ThreadSafeLocalTime --
 *
 *	Wrapper around the 'localtime' library function to make it thread
 *	safe.

    const time_t *timePtr)	/* Pointer to the number of seconds since the
				 * local system's epoch */
{
    /*
     * Get a thread-local buffer to hold the returned time.
     */

    struct tm *tmPtr = (struct tm *)
	    Tcl_GetThreadData(&tmKey, (int) sizeof(struct tm));
#ifdef HAVE_LOCALTIME_R
    localtime_r(timePtr, tmPtr);
#else
    struct tm *sysTmPtr;

    Tcl_MutexLock(&clockMutex);
    sysTmPtr = localtime(timePtr);
    if (sysTmPtr == NULL) {
	Tcl_MutexUnlock(&clockMutex);
	return NULL;
    } else {

	memcpy((void *) tmPtr, (void *) localtime(timePtr), sizeof(struct tm));
	Tcl_MutexUnlock(&clockMutex);
    }
#endif
    return tmPtr;
}

/*----------------------------------------------------------------------
 *
 * ClockClicksObjCmd --
 *
 *	Returns a high-resolution counter.
 *
 * Results:

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

int
ClockClicksObjCmd(
    ClientData clientData,	/* Client data is unused */
    Tcl_Interp* interp,		/* Tcl interpreter */
    int objc,			/* Parameter count */
    Tcl_Obj* const* objv)	/* Parameter values */
{
    static const char *const clicksSwitches[] = {
	"-milliseconds", "-microseconds", NULL
    };
    enum ClicksSwitch {
	CLICKS_MILLIS,   CLICKS_MICROS,   CLICKS_NATIVE
    };
    int index = CLICKS_NATIVE;
    Tcl_Time now;


    switch (objc) {
    case 1:
	break;
    case 2:
	if (Tcl_GetIndexFromObj(interp, objv[1], clicksSwitches, "switch", 0,
		&index) != TCL_OK) {
	    return TCL_ERROR;
	}
	break;
    default:
	Tcl_WrongNumArgs(interp, 1, objv, "?-switch?");
	return TCL_ERROR;
    }

    switch (index) {
    case CLICKS_MILLIS:
	Tcl_GetTime(&now);
	Tcl_SetObjResult(interp, Tcl_NewWideIntObj((Tcl_WideInt)
		now.sec * 1000 + now.usec / 1000));
	break;
    case CLICKS_NATIVE: {
#ifndef TCL_WIDE_CLICKS
	unsigned long clicks = TclpGetClicks();
#else
	Tcl_WideInt clicks = TclpGetWideClicks();
#endif
	Tcl_SetObjResult(interp, Tcl_NewWideIntObj((Tcl_WideInt) clicks));
	break;
    }
    case CLICKS_MICROS:
	Tcl_GetTime(&now);
	Tcl_SetObjResult(interp, Tcl_NewWideIntObj(
		((Tcl_WideInt) now.sec * 1000000) + now.usec));
	break;
    }


    return TCL_OK;
}

/*----------------------------------------------------------------------
 *
 * ClockMillisecondsObjCmd -
 *
 *	Returns a count of milliseconds since the epoch.
 *
 * Results:

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

int
ClockMillisecondsObjCmd(
    ClientData clientData,	/* Client data is unused */
    Tcl_Interp* interp,		/* Tcl interpreter */
    int objc,			/* Parameter count */
    Tcl_Obj* const* objv)	/* Parameter values */
{
    Tcl_Time now;

    if (objc != 1) {
	Tcl_WrongNumArgs(interp, 1, objv, NULL);
	return TCL_ERROR;
    }
    Tcl_GetTime(&now);
    Tcl_SetObjResult(interp, Tcl_NewWideIntObj( (Tcl_WideInt)
	    now.sec * 1000 + now.usec / 1000));
    return TCL_OK;
}

/*----------------------------------------------------------------------
 *
 * ClockMicrosecondsObjCmd -
 *
 *	Returns a count of microseconds since the epoch.
 *
 * Results:

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

int
ClockMicrosecondsObjCmd(
    ClientData clientData,	/* Client data is unused */
    Tcl_Interp* interp,		/* Tcl interpreter */
    int objc,			/* Parameter count */
    Tcl_Obj* const* objv)	/* Parameter values */
{
    Tcl_Time now;

    if (objc != 1) {
	Tcl_WrongNumArgs(interp, 1, objv, NULL);
	return TCL_ERROR;
    }
    Tcl_GetTime(&now);
    Tcl_SetObjResult(interp, Tcl_NewWideIntObj(
	    ((Tcl_WideInt) now.sec * 1000000) + now.usec));
    return TCL_OK;
}

/*
 *-----------------------------------------------------------------------------
 *
 * ClockParseformatargsObjCmd --
 *
 *	Parses the arguments for [clock format].
 *
 * Results:
 *	Returns a standard Tcl result, whose value is a four-element
 *	list comprising the time format, the locale, and the timezone.
 *
 * This function exists because the loop that parses the [clock format]
 * options is a known performance "hot spot", and is implemented in an
 * effort to speed that particular code up.
 *
 *-----------------------------------------------------------------------------
 */

static int
ClockParseformatargsObjCmd(
    ClientData clientData,	/* Client data containing literal pool */
    Tcl_Interp* interp,		/* Tcl interpreter */
    int objc,			/* Parameter count */
    Tcl_Obj *const objv[]	/* Parameter vector */
) {

    ClockClientData* dataPtr = (ClockClientData*) clientData;
    Tcl_Obj** litPtr = dataPtr->literals;

    /* Format, locale and timezone */

    Tcl_Obj* results[3];
#define formatObj results[0]
#define localeObj results[1]
#define timezoneObj results[2]
    int gmtFlag = 0;

    /* Command line options expected */

    static const char *const options[] = {
	"-format",		"-gmt",			"-locale",
	"-timezone",		NULL };
    enum optionInd {
	CLOCK_FORMAT_FORMAT,	CLOCK_FORMAT_GMT,	CLOCK_FORMAT_LOCALE,
	CLOCK_FORMAT_TIMEZONE
    };
    int optionIndex;		/* Index of an option */
    int saw = 0;		/* Flag == 1 if option was seen already */
    Tcl_WideInt clockVal;	/* Clock value - just used to parse */
    int i;


    /* Args consist of a time followed by keyword-value pairs */


    if (objc < 2 || (objc % 2) != 0) {
	Tcl_WrongNumArgs(interp, 0, objv,
			 "clock format clockval ?-format string? "
			 "?-gmt boolean? ?-locale LOCALE? ?-timezone ZONE?");
	Tcl_SetErrorCode(interp, "CLOCK", "wrongNumArgs", NULL);
	return TCL_ERROR;
    }


    /* Extract values for the keywords */


    formatObj = litPtr[LIT__DEFAULT_FORMAT];
    localeObj = litPtr[LIT_C];
    timezoneObj = litPtr[LIT__NIL];
    for (i = 2; i < objc; i+=2) {
	if (Tcl_GetIndexFromObj(interp, objv[i], options, "switch", 0,
				&optionIndex) != TCL_OK) {
	    Tcl_SetErrorCode(interp, "CLOCK", "badSwitch",
			     Tcl_GetString(objv[i]), NULL);
	    return TCL_ERROR;
	}
	switch (optionIndex) {
	case CLOCK_FORMAT_FORMAT:
	    formatObj = objv[i+1];
	    break;
	case CLOCK_FORMAT_GMT:
	    if (Tcl_GetBooleanFromObj(interp, objv[i+1], &gmtFlag) != TCL_OK) {
		return TCL_ERROR;
	    }
	    break;
	case CLOCK_FORMAT_LOCALE:
	    localeObj = objv[i+1];
	    break;
	case CLOCK_FORMAT_TIMEZONE:
	    timezoneObj = objv[i+1];
	    break;
	}
	saw |= (1 << optionIndex);
    }


    /* Check options */


    if (Tcl_GetWideIntFromObj(interp, objv[1], &clockVal) != TCL_OK) {
	return TCL_ERROR;
    }
    if ((saw & (1 << CLOCK_FORMAT_GMT))
	&& (saw & (1 << CLOCK_FORMAT_TIMEZONE))) {
	Tcl_SetObjResult(interp, litPtr[LIT_CANNOT_USE_GMT_AND_TIMEZONE]);
	Tcl_SetErrorCode(interp, "CLOCK", "gmtWithTimezone", NULL);
	return TCL_ERROR;
    }
    if (gmtFlag) {
	timezoneObj = litPtr[LIT_GMT];
    }


    /* Return options as a list */


    Tcl_SetObjResult(interp, Tcl_NewListObj(3, results));
    return TCL_OK;

#undef timezoneObj
#undef localeObj
#undef formatObj

}

/*----------------------------------------------------------------------
 *
 * ClockSecondsObjCmd -
 *
 *	Returns a count of microseconds since the epoch.
 *
 * Results:

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

int
ClockSecondsObjCmd(
    ClientData clientData,	/* Client data is unused */
    Tcl_Interp* interp,		/* Tcl interpreter */
    int objc,			/* Parameter count */
    Tcl_Obj* const* objv)	/* Parameter values */
{
    Tcl_Time now;

    if (objc != 1) {
	Tcl_WrongNumArgs(interp, 1, objv, NULL);
	return TCL_ERROR;
    }
    Tcl_GetTime(&now);
    Tcl_SetObjResult(interp, Tcl_NewWideIntObj((Tcl_WideInt) now.sec));
    return TCL_OK;
}

/*
 *----------------------------------------------------------------------
 *
 * TzsetIfNecessary --
 *
 *	Calls the tzset() library function if the contents of the TZ
 *	environment variable has changed.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	Calls tzset.
 *
 *----------------------------------------------------------------------
 */

static void
TzsetIfNecessary(void)
{
    static char* tzWas = NULL;	/* Previous value of TZ, protected by
				 * clockMutex. */
    const char* tzIsNow;	/* Current value of TZ */

    Tcl_MutexLock(&clockMutex);
    tzIsNow = getenv("TZ");
    if (tzIsNow != NULL && (tzWas == NULL || strcmp(tzIsNow, tzWas) != 0)) {
	tzset();
	if (tzWas != NULL) {
	    ckfree(tzWas);
	}
	tzWas = ckalloc(strlen(tzIsNow) + 1);
	strcpy(tzWas, tzIsNow);
    } else if (tzIsNow == NULL && tzWas != NULL) {
	tzset();
	ckfree(tzWas);
	tzWas = NULL;
    }
    Tcl_MutexUnlock(&clockMutex);
}

/*
 *----------------------------------------------------------------------
 *
 * ClockDeleteCmdProc --
 *
 *	Remove a reference to the clock client data, and clean up memory
 *	when it's all gone.
 *
 * Results:
 *	None.
 *
 *----------------------------------------------------------------------
 */

static void
ClockDeleteCmdProc(
    ClientData clientData)	/* Opaque pointer to the client data */
{
    ClockClientData *data = (ClockClientData*) clientData;
    int i;

    --(data->refCount);
    if (data->refCount == 0) {
	for (i = 0; i < LIT__END; ++i) {
	    Tcl_DecrRefCount(data->literals[i]);
	}
	ckfree((char*) (data->literals));
	ckfree((char*) data);
    }
}

/*
 * Local Variables:
 * mode: c
 * c-basic-offset: 4
 * fill-column: 78
 * End:
 */

/*
 * tclCmdAH.c --
 *
 *	This file contains the top-level command routines for most of the Tcl
 *	built-in commands whose names begin with the letters A to H.
 *
 * Copyright (c) 1987-1993 The Regents of the University of California.
 * Copyright (c) 1994-1997 Sun Microsystems, Inc.
 *
 * See the file "license.terms" for information on usage and redistribution of
 * this file, and for a DISCLAIMER OF ALL WARRANTIES.
 *
 * RCS: @(#) $Id: tclCmdAH.c,v 1.33.2.39 2008/10/23 15:51:09 dgp Exp $
 */

#include "tclInt.h"
#include <locale.h>

/*
 * The state structure used by [foreach]. Note that the actual structure has

{
    int status;

    if (Tcl_FSConvertToPathType(interp, pathPtr) != TCL_OK) {
	return TCL_ERROR;
    }

    status = (*statProc)(pathPtr, statPtr);

    if (status < 0) {
	if (interp != NULL) {
	    Tcl_AppendResult(interp, "could not read \"",
		    TclGetString(pathPtr), "\": ",
		    Tcl_PosixError(interp), NULL);
	}

/*
 * tclCompExpr.c --
 *
 *	This file contains the code to parse and compile Tcl expressions
 *	and implementations of the Tcl commands corresponding to expression
 *	operators, such as the command ::tcl::mathop::+ .
 *
 * Contributions from Don Porter, NIST, 2006-2007. (not subject to US copyright)
 *
 * See the file "license.terms" for information on usage and redistribution of
 * this file, and for a DISCLAIMER OF ALL WARRANTIES.
 *
 * RCS: @(#) $Id: tclCompExpr.c,v 1.14.2.36 2008/03/03 04:35:04 dgp Exp $
 */

#include "tclInt.h"
#include "tclCompile.h"		/* CompileEnv */

/*
 * Expression parsing takes place in the routine ParseExpr().  It takes a

    Tcl_Obj *literal = NULL;
    unsigned char byte;

    if (numBytes == 0) {
	*lexemePtr = END;
	return 0;
    }
    byte = (unsigned char)(*start);
    if (byte < sizeof(Lexeme) && Lexeme[byte] != 0) {
	*lexemePtr = Lexeme[byte];
	return 1;
    }
    switch (byte) {
    case '*':
	if ((numBytes > 1) && (start[1] == '*')) {

/*
 * tclCompile.c --
 *
 *	This file contains procedures that compile Tcl commands or parts of
 *	commands (like quoted strings or nested sub-commands) into a sequence
 *	of instructions ("bytecodes").
 *
 * Copyright (c) 1996-1998 Sun Microsystems, Inc.
 * Copyright (c) 2001 by Kevin B. Kenny. All rights reserved.
 *
 * See the file "license.terms" for information on usage and redistribution of
 * this file, and for a DISCLAIMER OF ALL WARRANTIES.
 *
 * RCS: @(#) $Id: tclCompile.c,v 1.49.2.57 2008/10/17 20:52:23 dgp Exp $
 */

#include "tclInt.h"
#include "tclCompile.h"

/*
 * Table of all AuxData types.

		    TclEmitInstInt4(INST_START_CMD, 0, envPtr);
		    TclEmitInt4(1, envPtr);
		    update = 1;
		}

		parsePtr->numWords = numWords;
		parsePtr->tokenPtr = tokenPtr;
		code = (*(cmdPtr->compileProc))(interp, parsePtr,
			cmdPtr, envPtr);
		TclStackFree(interp, parsePtr);
	    }

	    if (code == TCL_OK) {
		if (update) {
		    /*
		     * Fix the bytecode length.

		envPtr->numCommands = savedNumCmds;
		envPtr->codeNext = envPtr->codeStart + savedCodeNext;
		if (numWords == 1) {
		    /*
		     * Single word script: unshare the command name to
		     * avoid shimmering between bytecode and cmdName
		     * representations [Bug 458361]
		     */

		    TclHideLiteral(interp, envPtr, objIndex);
		}
		TclEmitPush(objIndex, envPtr);
		wordIndex++;
		tokenPtr += (tokenPtr->numComponents + 1);

	 * to eclPtr->loc[eclPtr->nuloc-1] (inclusive).
	 */

	size_t currElems = eclPtr->nloc;
	size_t newElems = (currElems ? 2*currElems : 1);
	size_t newBytes = newElems * sizeof(ECL);

	eclPtr->loc = (ECL *) ckrealloc((char *)(eclPtr->loc), newBytes);
	eclPtr->nloc = newElems;
    }

    ePtr = &eclPtr->loc[eclPtr->nuloc];
    ePtr->srcOffset = srcOffset;
    ePtr->line = (int *) ckalloc(numWords * sizeof(int));
    ePtr->nline = numWords;

	size_t currBytes =
		envPtr->exceptArrayNext * sizeof(ExceptionRange);
	int newElems = 2*envPtr->exceptArrayEnd;
	size_t newBytes = newElems * sizeof(ExceptionRange);

	if (envPtr->mallocedExceptArray) {
	    envPtr->exceptArrayPtr = (ExceptionRange *)
		    ckrealloc((char *)(envPtr->exceptArrayPtr), newBytes);
	} else {
	    /*
	     * envPtr->exceptArrayPtr isn't a ckalloc'd pointer, so we must
	     * code a ckrealloc equivalent for ourselves.
	     */
	    ExceptionRange *newPtr = (ExceptionRange *)
		    ckalloc((unsigned) newBytes);

	size_t currBytes = envPtr->auxDataArrayNext * sizeof(AuxData);
	int newElems = 2*envPtr->auxDataArrayEnd;
	size_t newBytes = newElems * sizeof(AuxData);

	if (envPtr->mallocedAuxDataArray) {
	    envPtr->auxDataArrayPtr = (AuxData *)
		    ckrealloc((char *)(envPtr->auxDataArrayPtr), newBytes);
	} else {
	    /*
	     * envPtr->auxDataArrayPtr isn't a ckalloc'd pointer, so we must
	     * code a ckrealloc equivalent for ourselves.
	     */
	    AuxData *newPtr = (AuxData *) ckalloc((unsigned) newBytes);
	    memcpy(newPtr, envPtr->auxDataArrayPtr, currBytes);

    size_t currBytes = fixupArrayPtr->next * sizeof(JumpFixup);
    int newElems = 2*(fixupArrayPtr->end + 1);
    size_t newBytes = newElems * sizeof(JumpFixup);

    if (fixupArrayPtr->mallocedArray) {
	fixupArrayPtr->fixup = (JumpFixup *)
		ckrealloc((char *)(fixupArrayPtr->fixup), newBytes);
    } else {
	/*
	 * fixupArrayPtr->fixup isn't a ckalloc'd pointer, so we must
	 * code a ckrealloc equivalent for ourselves.
	 */
	JumpFixup *newPtr = (JumpFixup *) ckalloc((unsigned) newBytes);
	memcpy(newPtr, fixupArrayPtr->fixup, currBytes);

    statsPtr->numCompilations++;
    statsPtr->totalSrcBytes += (double) codePtr->numSrcBytes;
    statsPtr->totalByteCodeBytes += (double) codePtr->structureSize;
    statsPtr->currentSrcBytes += (double) codePtr->numSrcBytes;
    statsPtr->currentByteCodeBytes += (double) codePtr->structureSize;

    statsPtr->srcCount[TclLog2(codePtr->numSrcBytes)]++;
    statsPtr->byteCodeCount[TclLog2((int)(codePtr->structureSize))]++;

    statsPtr->currentInstBytes += (double) codePtr->numCodeBytes;
    statsPtr->currentLitBytes += (double)
	    codePtr->numLitObjects * sizeof(Tcl_Obj *);
    statsPtr->currentExceptBytes += (double)
	    codePtr->numExceptRanges * sizeof(ExceptionRange);
    statsPtr->currentAuxBytes += (double)

/*
 * tclCompile.h --
 *
 * Copyright (c) 1996-1998 Sun Microsystems, Inc.
 * Copyright (c) 1998-2000 by Scriptics Corporation.
 * Copyright (c) 2001 by Kevin B. Kenny. All rights reserved.
 * Copyright (c) 2007 Daniel A. Steffen <das@users.sourceforge.net>
 *
 * See the file "license.terms" for information on usage and redistribution of
 * this file, and for a DISCLAIMER OF ALL WARRANTIES.
 *
 * RCS: @(#) $Id: tclCompile.h,v 1.36.2.48 2008/10/23 15:51:09 dgp Exp $
 */

#ifndef _TCLCOMPILATION
#define _TCLCOMPILATION 1

#include "tclInt.h"

#define TCL_DTRACE_TCL_PROBE_ENABLED()	    unlikely(TCL_TCL_PROBE_ENABLED())
#define TCL_DTRACE_TCL_PROBE(a0, a1, a2, a3, a4, a5, a6, a7, a8, a9) \
	TCL_TCL_PROBE(a0, a1, a2, a3, a4, a5, a6, a7, a8, a9)

#define TCL_DTRACE_DEBUG_LOG()

MODULE_SCOPE void TclDTraceInfo(Tcl_Obj *info, char **args, int *argsi);

#else /* USE_DTRACE */

#define TCL_DTRACE_PROC_ENTRY_ENABLED()	    0
#define TCL_DTRACE_PROC_RETURN_ENABLED()    0
#define TCL_DTRACE_PROC_RESULT_ENABLED()    0
#define TCL_DTRACE_PROC_ARGS_ENABLED()	    0

#undef TCL_DTRACE_DEBUG_INST_PROBES
#define TCL_DTRACE_DEBUG_INST_PROBES 0
#endif

MODULE_SCOPE int tclDTraceDebugEnabled, tclDTraceDebugIndent;
MODULE_SCOPE FILE *tclDTraceDebugLog;
MODULE_SCOPE void TclDTraceOpenDebugLog(void);
MODULE_SCOPE void TclDTraceInfo(Tcl_Obj *info, char **args, int *argsi);

#define TCL_DTRACE_DEBUG_LOG() \
	int tclDTraceDebugEnabled = TCL_DTRACE_DEBUG_LOG_ENABLED;\
	int tclDTraceDebugIndent = 0; \
	FILE *tclDTraceDebugLog = NULL; \
	void TclDTraceOpenDebugLog(void) { char n[35]; \
	sprintf(n, "/tmp/tclDTraceDebug-%lu.log", (unsigned long) getpid()); \

/*
 * tclEncoding.c --
 *
 *	Contains the implementation of the encoding conversion package.
 *
 * Copyright (c) 1996-1998 Sun Microsystems, Inc.
 *
 * See the file "license.terms" for information on usage and redistribution of
 * this file, and for a DISCLAIMER OF ALL WARRANTIES.
 *
 * RCS: @(#) $Id: tclEncoding.c,v 1.16.4.27 2008/10/23 15:51:10 dgp Exp $
 */

#include "tclInt.h"

typedef size_t (LengthProc)(const char *src);

/*

 * An example is "iso-2022-jp", which uses escape sequences to switch between
 * ascii, jis0208, jis0212, gb2312, and ksc5601. Note that "escape-driven"
 * does not necessarily mean that the ESCAPE character is the character used
 * for switching character sets.
 */

typedef struct EscapeSubTable {
    unsigned int sequenceLen;	/* Length of following string. */
    char sequence[16];		/* Escape code that marks this encoding. */
    char name[32];		/* Name for encoding. */
    Encoding *encodingPtr;	/* Encoding loaded using above name, or NULL
				 * if this sub-encoding has not been needed
				 * yet. */
} EscapeSubTable;

typedef struct EscapeEncodingData {
    int fallback;		/* Character (in this encoding) to substitute
				 * when this encoding cannot represent a UTF-8
				 * character. */
    unsigned int initLen;	/* Length of following string. */
    char init[16];		/* String to emit or expect before first char
				 * in conversion. */
    unsigned int finalLen;	/* Length of following string. */
    char final[16];		/* String to emit or expect after last char in
				 * conversion. */
    char prefixBytes[256];	/* If a byte in the input stream is the first
				 * character of one of the escape sequences in
				 * the following array, the corresponding
				 * entry in this array is 1, otherwise it is
				 * 0. */

    type.encodingName	= "identity";
    type.toUtfProc	= BinaryProc;
    type.fromUtfProc	= BinaryProc;
    type.freeProc	= NULL;
    type.nullSize	= 1;
    type.clientData	= NULL;

    defaultEncoding	= Tcl_CreateEncoding(&type);
    systemEncoding	= Tcl_GetEncoding(NULL, type.encodingName);

    type.encodingName	= "utf-8";
    type.toUtfProc	= UtfExtToUtfIntProc;
    type.fromUtfProc	= UtfIntToUtfExtProc;
    type.freeProc	= NULL;
    type.nullSize	= 1;
    type.clientData	= NULL;

	type.encodingName	= "iso8859-1";
	type.toUtfProc		= Iso88591ToUtfProc;
	type.fromUtfProc	= Iso88591FromUtfProc;
	type.freeProc		= TableFreeProc;
	type.nullSize		= 1;
	type.clientData		= dataPtr;
	Tcl_CreateEncoding(&type);

    }

    encodingsInitialized = 1;
}

/*
 *----------------------------------------------------------------------

    encodingPtr = (Encoding *) encoding;
    if (encodingPtr == NULL) {
	return;
    }
    encodingPtr->refCount--;
    if (encodingPtr->refCount == 0) {
	if (encodingPtr->freeProc != NULL) {
	    (*encodingPtr->freeProc)(encodingPtr->clientData);
	}
	if (encodingPtr->hPtr != NULL) {
	    Tcl_DeleteHashEntry(encodingPtr->hPtr);
	}
	ckfree((char *) encodingPtr->name);
	ckfree((char *) encodingPtr);
    }

	encoding = systemEncoding;
    }
    encodingPtr = (Encoding *) encoding;

    if (src == NULL) {
	srcLen = 0;
    } else if (srcLen < 0) {
	srcLen = (*encodingPtr->lengthProc)(src);
    }

    flags = TCL_ENCODING_START | TCL_ENCODING_END;

    while (1) {
	result = (*encodingPtr->toUtfProc)(encodingPtr->clientData, src,
		srcLen, flags, &state, dst, dstLen, &srcRead, &dstWrote,
		&dstChars);
	soFar = dst + dstWrote - Tcl_DStringValue(dstPtr);

	if (result != TCL_CONVERT_NOSPACE) {
	    Tcl_DStringSetLength(dstPtr, soFar);
	    return Tcl_DStringValue(dstPtr);
	}

	encoding = systemEncoding;
    }
    encodingPtr = (Encoding *) encoding;

    if (src == NULL) {
	srcLen = 0;
    } else if (srcLen < 0) {
	srcLen = (*encodingPtr->lengthProc)(src);
    }
    if (statePtr == NULL) {
	flags |= TCL_ENCODING_START | TCL_ENCODING_END;
	statePtr = &state;
    }
    if (srcReadPtr == NULL) {
	srcReadPtr = &srcRead;

    /*
     * If there are any null characters in the middle of the buffer, they will
     * converted to the UTF-8 null character (\xC080). To get the actual \0 at
     * the end of the destination buffer, we need to append it manually.
     */

    dstLen--;
    result = (*encodingPtr->toUtfProc)(encodingPtr->clientData, src, srcLen,
	    flags, statePtr, dst, dstLen, srcReadPtr, dstWrotePtr,
	    dstCharsPtr);
    dst[*dstWrotePtr] = '\0';

    return result;
}


    if (src == NULL) {
	srcLen = 0;
    } else if (srcLen < 0) {
	srcLen = strlen(src);
    }
    flags = TCL_ENCODING_START | TCL_ENCODING_END;
    while (1) {
	result = (*encodingPtr->fromUtfProc)(encodingPtr->clientData, src,
		srcLen, flags, &state, dst, dstLen, &srcRead, &dstWrote,
		&dstChars);
	soFar = dst + dstWrote - Tcl_DStringValue(dstPtr);

	if (result != TCL_CONVERT_NOSPACE) {
	    if (encodingPtr->nullSize == 2) {
		Tcl_DStringSetLength(dstPtr, soFar + 1);

	dstWrotePtr = &dstWrote;
    }
    if (dstCharsPtr == NULL) {
	dstCharsPtr = &dstChars;
    }

    dstLen -= encodingPtr->nullSize;
    result = (*encodingPtr->fromUtfProc)(encodingPtr->clientData, src, srcLen,
	    flags, statePtr, dst, dstLen, srcReadPtr, dstWrotePtr,
	    dstCharsPtr);
    if (encodingPtr->nullSize == 2) {
	dst[*dstWrotePtr + 1] = '\0';
    }
    dst[*dstWrotePtr] = '\0';

    Tcl_Channel chan)		/* File containing new encoding. */
{
    Tcl_DString lineString;
    Tcl_Obj *objPtr;
    char *line;
    int i, hi, lo, numPages, symbol, fallback;
    unsigned char used[256];
    unsigned int size;
    TableEncodingData *dataPtr;
    unsigned short *pageMemPtr;
    Tcl_EncodingType encType;

    /*
     * Speed over memory. Use a full 256 character table to decode hex
     * sequences in the encoding files.

static Tcl_Encoding
LoadEscapeEncoding(
    const char *name,		/* Name for new encoding. */
    Tcl_Channel chan)		/* File containing new encoding. */
{
    int i;
    unsigned int size;
    Tcl_DString escapeData;
    char init[16], final[16];
    EscapeEncodingData *dataPtr;
    Tcl_EncodingType type;

    init[0] = '\0';
    final[0] = '\0';

    int *dstWrotePtr,		/* Filled with the number of bytes that were
				 * stored in the output buffer as a result of
				 * the conversion. */
    int *dstCharsPtr)		/* Filled with the number of characters that
				 * correspond to the bytes stored in the
				 * output buffer. */
{
    EscapeEncodingData *dataPtr;
    char *prefixBytes, *tablePrefixBytes;
    unsigned short **tableToUnicode;
    Encoding *encodingPtr;
    int state, result, numChars;
    const char *srcStart, *srcEnd;
    char *dstStart, *dstEnd;

    result = TCL_OK;

    tablePrefixBytes = NULL;	/* lint. */
    tableToUnicode = NULL;	/* lint. */

    dataPtr = (EscapeEncodingData *) clientData;
    prefixBytes = dataPtr->prefixBytes;
    encodingPtr = NULL;

    srcStart = src;
    srcEnd = src + srcLen;

    dstStart = dst;

	if (dst > dstEnd) {
	    result = TCL_CONVERT_NOSPACE;
	    break;
	}
	byte = *((unsigned char *) src);
	if (prefixBytes[byte]) {
	    unsigned int left, len, longest;
	    int checked, i;
	    EscapeSubTable *subTablePtr;

	    /*
	     * Saw the beginning of an escape sequence.
	     */

	    break;
	}

	if (encodingPtr == NULL) {
	    TableEncodingData *tableDataPtr;

	    encodingPtr = GetTableEncoding(dataPtr, state);
	    tableDataPtr = (TableEncodingData *) encodingPtr->clientData;
	    tablePrefixBytes = tableDataPtr->prefixBytes;
	    tableToUnicode = tableDataPtr->toUnicode;
	}

	if (tablePrefixBytes[byte]) {
	    src++;
	    if (src >= srcEnd) {

    int *dstWrotePtr,		/* Filled with the number of bytes that were
				 * stored in the output buffer as a result of
				 * the conversion. */
    int *dstCharsPtr)		/* Filled with the number of characters that
				 * correspond to the bytes stored in the
				 * output buffer. */
{
    EscapeEncodingData *dataPtr;
    Encoding *encodingPtr;
    const char *srcStart, *srcEnd, *srcClose;
    char *dstStart, *dstEnd;
    int state, result, numChars;
    TableEncodingData *tableDataPtr;
    char *tablePrefixBytes;
    unsigned short **tableFromUnicode;

    result = TCL_OK;

    dataPtr = (EscapeEncodingData *) clientData;

    srcStart = src;
    srcEnd = src + srcLen;
    srcClose = srcEnd;
    if ((flags & TCL_ENCODING_END) == 0) {
	srcClose -= TCL_UTF_MAX;
    }

    dstStart = dst;
    dstEnd = dst + dstLen - 1;

    /*
     * RFC1468 states that the text starts in ASCII, and switches to Japanese
     * characters, and that the text must end in ASCII. [Patch 474358]
     */

    if (flags & TCL_ENCODING_START) {
	state = 0;
	if ((dst + dataPtr->initLen) > dstEnd) {
	    *srcReadPtr = 0;
	    *dstWrotePtr = 0;
	    return TCL_CONVERT_NOSPACE;
	}
	memcpy(dst, dataPtr->init, (size_t)dataPtr->initLen);
	dst += dataPtr->initLen;
    } else {
	state = PTR2INT(*statePtr);
    }

    encodingPtr = GetTableEncoding(dataPtr, state);
    tableDataPtr = (TableEncodingData *) encodingPtr->clientData;
    tablePrefixBytes = tableDataPtr->prefixBytes;
    tableFromUnicode = tableDataPtr->fromUnicode;

    for (numChars = 0; src < srcEnd; numChars++) {
	unsigned int len;
	int word;
	Tcl_UniChar ch;

	if ((src > srcClose) && (!Tcl_UtfCharComplete(src, srcEnd - src))) {
	    /*
	     * If there is more string to follow, this will ensure that the
	     * last UTF-8 character in the source buffer hasn't been cut off.

	if ((word == 0) && (ch != 0)) {
	    int oldState;
	    EscapeSubTable *subTablePtr;

	    oldState = state;
	    for (state = 0; state < dataPtr->numSubTables; state++) {
		encodingPtr = GetTableEncoding(dataPtr, state);
		tableDataPtr = (TableEncodingData *) encodingPtr->clientData;
	    	word = tableDataPtr->fromUnicode[(ch >> 8)][ch & 0xff];
		if (word != 0) {
		    break;
		}
	    }

	    if (word == 0) {
		state = oldState;
		if (flags & TCL_ENCODING_STOPONERROR) {
		    result = TCL_CONVERT_UNKNOWN;
		    break;
		}
		encodingPtr = GetTableEncoding(dataPtr, state);
		tableDataPtr = (TableEncodingData *) encodingPtr->clientData;
		word = tableDataPtr->fallback;
	    }

	    tablePrefixBytes = tableDataPtr->prefixBytes;
	    tableFromUnicode = tableDataPtr->fromUnicode;

	    /*

	    dst[0] = (char) word;
	    dst++;
	}
	src += len;
    }

    if ((result == TCL_OK) && (flags & TCL_ENCODING_END)) {
	unsigned int len = dataPtr->subTables[0].sequenceLen;

	/*
	 * Certain encodings like iso2022-jp need to write
	 * an escape sequence after all characters have
	 * been converted. This logic checks that enough
	 * room is available in the buffer for the escape bytes.
	 * The TCL_ENCODING_END flag is cleared after a final
	 * escape sequence has been added to the buffer so
	 * that another call to this method does not attempt
	 * to append escape bytes a second time.
	 */

	if ((dst + dataPtr->finalLen + (state?len:0)) > dstEnd) {
	    result = TCL_CONVERT_NOSPACE;
	} else {
	    if (state) {
		memcpy(dst, dataPtr->subTables[0].sequence, (size_t) len);
		dst += len;
	    }
	    memcpy(dst, dataPtr->final, (size_t) dataPtr->finalLen);
	    dst += dataPtr->finalLen;
	    state &= ~TCL_ENCODING_END;
	}
    }

 */

static void
EscapeFreeProc(
    ClientData clientData)	/* EscapeEncodingData that specifies
				 * encoding. */
{
    EscapeEncodingData *dataPtr;
    EscapeSubTable *subTablePtr;
    int i;

    dataPtr = (EscapeEncodingData *) clientData;
    if (dataPtr == NULL) {
	return;
    }
    subTablePtr = dataPtr->subTables;
    for (i = 0; i < dataPtr->numSubTables; i++) {
	FreeEncoding((Tcl_Encoding) subTablePtr->encodingPtr);
	subTablePtr++;

 */

static Encoding *
GetTableEncoding(
    EscapeEncodingData *dataPtr,/* Contains names of encodings. */
    int state)			/* Index in dataPtr of desired Encoding. */
{
    EscapeSubTable *subTablePtr;
    Encoding *encodingPtr;

    subTablePtr = &dataPtr->subTables[state];
    encodingPtr = subTablePtr->encodingPtr;

    if (encodingPtr == NULL) {
	encodingPtr = (Encoding *) Tcl_GetEncoding(NULL, subTablePtr->name);
	if ((encodingPtr == NULL)
		|| (encodingPtr->toUtfProc != TableToUtfProc
		&& encodingPtr->toUtfProc != Iso88591ToUtfProc)) {
	    Tcl_Panic("EscapeToUtfProc: invalid sub table");

    *encodingPtr = libraryPath.encoding;
    if (*encodingPtr) {
	((Encoding *)(*encodingPtr))->refCount++;
    }
    bytes = Tcl_GetStringFromObj(searchPath, &numBytes);

    *lengthPtr = numBytes;
    *valuePtr = ckalloc((unsigned int) numBytes + 1);
    memcpy(*valuePtr, bytes, (size_t) numBytes + 1);
    Tcl_DecrRefCount(searchPath);
}

/*
 * Local Variables:
 * mode: c
 * c-basic-offset: 4
 * fill-column: 78
 * End:
 */

 *
 * Copyright (c) 1991-1994 The Regents of the University of California.
 * Copyright (c) 1994-1998 Sun Microsystems, Inc.
 *
 * See the file "license.terms" for information on usage and redistribution of
 * this file, and for a DISCLAIMER OF ALL WARRANTIES.
 *
 * RCS: @(#) $Id: tclEnv.c,v 1.21.2.11 2007/12/06 06:51:38 dgp Exp $
 */

#include "tclInt.h"

TCL_DECLARE_MUTEX(envMutex)	/* To serialize access to environ. */

static struct {

     */

    if (flags & TCL_TRACE_READS) {
	Tcl_DString valueString;
	const char *value = TclGetEnv(name2, &valueString);

	if (value == NULL) {
	    return "no such variable";
	}
	Tcl_SetVar2(interp, name1, name2, value, 0);
	Tcl_DStringFree(&valueString);
    }

    /*
     * For unset traces, let TclUnsetEnv do all the work.

 * Copyright (c) 1990-1994 The Regents of the University of California.
 * Copyright (c) 1994-1998 Sun Microsystems, Inc.
 * Copyright (c) 2004 by Zoran Vasiljevic.
 *
 * See the file "license.terms" for information on usage and redistribution of
 * this file, and for a DISCLAIMER OF ALL WARRANTIES.
 *
 * RCS: @(#) $Id: tclEvent.c,v 1.29.2.33 2008/10/17 20:52:23 dgp Exp $
 */

#include "tclInt.h"

/*
 * The data structure below is used to report background errors. One such
 * structure is allocated for each error; it holds information about the

	 * Be careful to remove the handler from the list before invoking its
	 * callback. This protects us against double-freeing if the callback
	 * should call Tcl_DeleteExitHandler on itself.
	 */

	firstExitPtr = exitPtr->nextPtr;
	Tcl_MutexUnlock(&exitMutex);
	(*exitPtr->proc)(exitPtr->clientData);
	ckfree((char *) exitPtr);
	Tcl_MutexLock(&exitMutex);
    }
    firstExitPtr = NULL;
    Tcl_MutexUnlock(&exitMutex);

    TclpInitLock();

	    /*
	     * Be careful to remove the handler from the list before invoking
	     * its callback. This protects us against double-freeing if the
	     * callback should call Tcl_DeleteThreadExitHandler on itself.
	     */

	    tsdPtr->firstExitPtr = exitPtr->nextPtr;
	    (*exitPtr->proc)(exitPtr->clientData);
	    ckfree((char *) exitPtr);
	}
	TclFinalizeIOSubsystem();
	TclFinalizeNotifier();
	TclFinalizeAsync();
    }

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

static Tcl_ThreadCreateType
NewThreadProc(
    ClientData clientData)
{
    ThreadClientData *cdPtr;
    ClientData threadClientData;
    Tcl_ThreadCreateProc *threadProc;

    cdPtr = (ThreadClientData *) clientData;
    threadProc = cdPtr->proc;
    threadClientData = cdPtr->clientData;
    ckfree((char *) clientData);	/* Allocated in Tcl_CreateThread() */

    (*threadProc)(threadClientData);

    TCL_THREAD_CREATE_RETURN;
}
#endif

/*
 *----------------------------------------------------------------------

 * Copyright (c) 2005-2007 by Donal K. Fellows.
 * Copyright (c) 2007 Daniel A. Steffen <das@users.sourceforge.net>
 * Copyright (c) 2006-2008 by Joe Mistachkin.  All rights reserved.
 *
 * See the file "license.terms" for information on usage and redistribution of
 * this file, and for a DISCLAIMER OF ALL WARRANTIES.
 *
 * RCS: @(#) $Id: tclExecute.c,v 1.101.2.99 2008/10/17 20:52:23 dgp Exp $
 */

#include "tclInt.h"
#include "tclCompile.h"
#include "tommath.h"

#include <math.h>

		    NEXT_INST_F(1, 1, 0);
		}
		if (l1 >= 3 &&
			((unsigned long) l1 < (sizeof(Exp32Index)
				/ sizeof(unsigned short)) - 1)) {
		    unsigned short base = Exp32Index[l1-3]
			    + (unsigned short) l2 - 9;

		    if (base < Exp32Index[l1-2]) {
			/*
			 * 32-bit number raised to intermediate power, done by
			 * table lookup.
			 */

			TRACE(("%s %s => ", O2S(valuePtr), O2S(value2Ptr)));
			if (Tcl_IsShared(valuePtr)) {
			    TclNewLongObj(objResultPtr, Exp32Value[base]);
			    TRACE(("%s\n", O2S(objResultPtr)));
			    NEXT_INST_F(1, 2, 1);
			}
			Tcl_SetLongObj(valuePtr, Exp32Value[base]);
			TRACE(("%s\n", O2S(valuePtr)));
			NEXT_INST_F(1, 1, 0);
		    }
		}
		if (-l1 >= 3
		    && (unsigned long)(-l1) < (sizeof(Exp32Index)
			     / sizeof(unsigned short)) - 1) {
		    unsigned short base
			= Exp32Index[-l1-3] + (unsigned short) l2 - 9;

		    if (base < Exp32Index[-l1-2]) {
			long lResult = (oddExponent) ?
			    -Exp32Value[base] : Exp32Value[base];

			/*
			 * 32-bit number raised to intermediate power, done by
			 * table lookup.
			 */

			TRACE(("%s %s => ", O2S(valuePtr), O2S(value2Ptr)));

 *
 * Copyright (c) 1990-1993 The Regents of the University of California.
 * Copyright (c) 1994-1997 Sun Microsystems, Inc.
 *
 * See the file "license.terms" for information on usage and redistribution of
 * this file, and for a DISCLAIMER OF ALL WARRANTIES.
 *
 * RCS: @(#) $Id: tclHistory.c,v 1.4.6.8 2008/07/29 20:13:35 dgp Exp $
 */

#include "tclInt.h"

/*
 *----------------------------------------------------------------------
 *

    /*
     * Do not call [history] if it has been replaced by an empty proc
     */

    result = Tcl_GetCommandInfo(interp, "history", &info);

    if (result && (info.deleteProc == TclProcDeleteProc)) {
	Proc *procPtr = (Proc *)(info.objClientData);
	call = (procPtr->cmdPtr->compileProc != TclCompileNoOp);
    }

    if (call) {

	/*
	 * Do recording by eval'ing a tcl history command: history add $cmd. 

/*
 * tclIO.c --
 *
 *	This file provides the generic portions (those that are the same on
 *	all platforms and for all channel types) of Tcl's IO facilities.
 *
 * Copyright (c) 1998-2000 Ajuba Solutions
 * Copyright (c) 1995-1997 Sun Microsystems, Inc.
 *
 * See the file "license.terms" for information on usage and redistribution of
 * this file, and for a DISCLAIMER OF ALL WARRANTIES.
 *
 * RCS: @(#) $Id: tclIO.c,v 1.68.2.40 2008/10/17 20:52:24 dgp Exp $
 */

#include "tclInt.h"
#include "tclIO.h"
#include <assert.h>

/*

		/*
		 * Call the device driver to actually close the underlying
		 * device for this channel.
		 */

		if (chanPtr->typePtr->closeProc != TCL_CLOSE2PROC) {
		    (chanPtr->typePtr->closeProc)(chanPtr->instanceData, NULL);
		} else {
		    (chanPtr->typePtr->close2Proc)(chanPtr->instanceData,
			    NULL, 0);
		}

		/*
		 * Finally, we clean up the fields in the channel data
		 * structure since all of them have been deleted already. We
		 * mark the channel with CHANNEL_DEAD to prevent any further
		 * IO operations on it.

	 * not we are doing a background flush.
	 */

	if ((statePtr->curOutPtr != NULL) &&
		IsBufferReady(statePtr->curOutPtr)) {
	    SetFlag(statePtr, BUFFER_READY);
	}
	Tcl_Preserve((ClientData)statePtr);
	if (!(statePtr->flags & BG_FLUSH_SCHEDULED)) {
	    /*
	     * We don't want to re-enter Tcl_Close().
	     */

	    if (!(statePtr->flags & CHANNEL_CLOSED)) {
		if (Tcl_Close(interp, chan) != TCL_OK) {
		    SetFlag(statePtr, CHANNEL_CLOSED);
		    Tcl_Release((ClientData)statePtr);
		    return TCL_ERROR;
		}
	    }
	}
	SetFlag(statePtr, CHANNEL_CLOSED);
	Tcl_Release((ClientData)statePtr);
    }
    return TCL_OK;
}

/*
 *----------------------------------------------------------------------
 *

     * individual channels. And SpliceChannel would not only call the thread
     * actions, but also add the shared ChannelState to this list a second
     * time, mangling it.
     */

    threadActionProc = Tcl_ChannelThreadActionProc(chanPtr->typePtr);
    if (threadActionProc != NULL) {
	(*threadActionProc)(chanPtr->instanceData, TCL_CHANNEL_THREAD_INSERT);
    }

    return (Tcl_Channel) chanPtr;
}

/*
 *----------------------------------------------------------------------

	 * only call the thread actions, but also remove the shared
	 * ChannelState from this list despite there being more channels for
	 * the state which are still active.
	 */

	threadActionProc = Tcl_ChannelThreadActionProc(chanPtr->typePtr);
	if (threadActionProc != NULL) {
	    (*threadActionProc)(chanPtr->instanceData,
		    TCL_CHANNEL_THREAD_REMOVE);
	}

	statePtr->topChanPtr = downChanPtr;
	downChanPtr->upChanPtr = NULL;

	/*
	 * Leave this link intact for closeproc
	 *  chanPtr->downChanPtr = NULL;
	 */

	/*
	 * Close and free the channel driver state.
	 */

	if (chanPtr->typePtr->closeProc != TCL_CLOSE2PROC) {
	    result = (chanPtr->typePtr->closeProc)(chanPtr->instanceData,
		    interp);
	} else {
	    result = (chanPtr->typePtr->close2Proc)(chanPtr->instanceData,
		    interp, 0);
	}

	chanPtr->typePtr = NULL;

	/*
	 * AK: Tcl_NotifyChannel may hold a reference to this block of memory

    ClientData *handlePtr)	/* Where to store handle */
{
    Channel *chanPtr;		/* The actual channel. */
    ClientData handle;
    int result;

    chanPtr = ((Channel *) chan)->state->bottomChanPtr;
    result = (chanPtr->typePtr->getHandleProc)(chanPtr->instanceData,
	    direction, &handle);
    if (handlePtr) {
	*handlePtr = handle;
    }
    return result;
}

/*

	}

	/*
	 * Produce the output on the channel.
	 */

	toWrite = BytesLeft(bufPtr);
	written = (chanPtr->typePtr->outputProc)(chanPtr->instanceData,
		RemovePoint(bufPtr), toWrite, &errorCode);

	/*
	 * If the write failed completely attempt to start the asynchronous
	 * flush mechanism and break out of this loop - do not attempt to
	 * write any more output at this time.
	 */

     */

    if (statePtr->flags & BG_FLUSH_SCHEDULED) {
	if (wroteSome) {
	    return errorCode;
	} else if (statePtr->outQueueHead == NULL) {
	    ResetFlag(statePtr, BG_FLUSH_SCHEDULED);
	    (chanPtr->typePtr->watchProc)(chanPtr->instanceData,
		    statePtr->interestMask);
	}
    }

    /*
     * If the channel is flagged as closed, delete it when the refCount drops
     * to zero, the output queue is empty and there is no output in the

     * device.
     */

    if ((statePtr->outEofChar != 0) && (statePtr->flags & TCL_WRITABLE)) {
	int dummy;
	char c = (char) statePtr->outEofChar;

	(chanPtr->typePtr->outputProc)(chanPtr->instanceData, &c, 1, &dummy);
    }

    /*
     * TIP #219, Tcl Channel Reflection API.
     * Move a leftover error message in the channel bypass into the
     * interpreter bypass. Just clear it if there is no interpreter.
     */

    /*
     * Close and free the channel driver state.
     * This may leave a TIP #219 error message in the interp.
     */

    if (chanPtr->typePtr->closeProc != TCL_CLOSE2PROC) {
	result = (chanPtr->typePtr->closeProc)(chanPtr->instanceData, interp);
    } else {
	result = (chanPtr->typePtr->close2Proc)(chanPtr->instanceData,
		interp, 0);
    }

    /*
     * Some resources can be cleared only if the bottom channel in a stack is
     * closed. All the other channels in the stack are not allowed to remove.
     */

    /*
     * TIP #218, Channel Thread Actions
     */

    threadActionProc = Tcl_ChannelThreadActionProc(Tcl_GetChannelType(chan));
    if (threadActionProc != NULL) {
	(*threadActionProc)(Tcl_GetChannelInstanceData(chan),
		TCL_CHANNEL_THREAD_REMOVE);
    }
}

void
Tcl_CutChannel(
    Tcl_Channel chan)		/* The channel being added. Must not be

     * TIP #218, Channel Thread Actions
     * For all transformations and the base channel.
     */

    while (chanPtr) {
	threadActionProc = Tcl_ChannelThreadActionProc(chanPtr->typePtr);
	if (threadActionProc != NULL) {
	    (*threadActionProc)(chanPtr->instanceData,
		    TCL_CHANNEL_THREAD_REMOVE);
	}
	chanPtr= chanPtr->upChanPtr;
    }
}

/*
 *----------------------------------------------------------------------

    /*
     * TIP #218, Channel Thread Actions
     */

    threadActionProc = Tcl_ChannelThreadActionProc(Tcl_GetChannelType(chan));
    if (threadActionProc != NULL) {
	(*threadActionProc) (Tcl_GetChannelInstanceData(chan),
		TCL_CHANNEL_THREAD_INSERT);
    }
}

void
Tcl_SpliceChannel(
    Tcl_Channel chan)		/* The channel being added. Must not be

     * TIP #218, Channel Thread Actions
     * For all transformations and the base channel.
     */

    while (chanPtr) {
	threadActionProc = Tcl_ChannelThreadActionProc(chanPtr->typePtr);
	if (threadActionProc != NULL) {
	    (*threadActionProc)(chanPtr->instanceData,
		    TCL_CHANNEL_THREAD_INSERT);
	}
	chanPtr= chanPtr->upChanPtr;
    }
}

/*
 *----------------------------------------------------------------------

    /*
     * Invoke the registered close callbacks and delete their records.
     */

    while (statePtr->closeCbPtr != NULL) {
	cbPtr = statePtr->closeCbPtr;
	statePtr->closeCbPtr = cbPtr->nextPtr;
	(cbPtr->proc)(cbPtr->clientData);
	ckfree((char *) cbPtr);
    }

    ResetFlag(statePtr, CHANNEL_INCLOSE);

    /*
     * Ensure that the last output buffer will be flushed.
     */

    if ((statePtr->curOutPtr != NULL) && IsBufferReady(statePtr->curOutPtr)) {
	SetFlag(statePtr, BUFFER_READY);
    }

    /*
     * If this channel supports it, close the read side, since we don't need
     * it anymore and this will help avoid deadlocks on some channel types.
     */

    if (chanPtr->typePtr->closeProc == TCL_CLOSE2PROC) {
	result = (chanPtr->typePtr->close2Proc)(chanPtr->instanceData, interp,
		TCL_CLOSE_READ);
    } else {
	result = 0;
    }

    /*
     * The call to FlushChannel will flush any queued output and invoke the

    }

    /*
     * Go immediately to the driver, do all the error handling by ourselves.
     * The code was stolen from 'FlushChannel'.
     */

    written = (chanPtr->typePtr->outputProc) (chanPtr->instanceData,
	    src, srcLen, &errorCode);

    if (written < 0) {
	Tcl_SetErrno(errorCode);
    }

    return written;
}

	} else {
	    if (nextPtr == NULL) {
		nextPtr = AllocChannelBuffer(statePtr->bufSize);
		bufPtr->nextPtr = nextPtr;
		statePtr->inQueueTail = nextPtr;
	    }
	    extra = rawLen - gsPtr->rawRead;
	    memcpy(nextPtr->buf + BUFFER_PADDING - extra,
		    raw + gsPtr->rawRead, (size_t) extra);
	    nextPtr->nextRemoved -= extra;
	    bufPtr->nextAdded -= extra;
	}
    }

    gsPtr->bufPtr = bufPtr;

	nextPtr = bufPtr->nextPtr;
	for ( ; nextPtr != NULL; nextPtr = bufPtr->nextPtr) {
	    int extra;

	    extra = SpaceLeft(bufPtr);
	    if (extra > 0) {
		memcpy(InsertPoint(bufPtr),
			nextPtr->buf + BUFFER_PADDING - extra,
			(size_t) extra);
		bufPtr->nextAdded += extra;
		nextPtr->nextRemoved = BUFFER_PADDING;
	    }
	    bufPtr = nextPtr;
	}
    }

		 * the remaining request. Do all the error handling by
		 * ourselves. The code was stolen from 'GetInput' and slightly
		 * adapted (different return value here).
		 *
		 * The case of 'bytesToRead == 0' at this point cannot happen.
		 */

		nread = (chanPtr->typePtr->inputProc)(chanPtr->instanceData,
			bufPtr + copied, bytesToRead - copied, &result);

#ifdef TCL_IO_TRACK_OS_FOR_DRIVER_WITH_BAD_BLOCKING
	    }
#endif /* TCL_IO_TRACK_OS_FOR_DRIVER_WITH_BAD_BLOCKING */

	    if (nread > 0) {

	 */

	nread = -1;
	result = EWOULDBLOCK;
    } else {
#endif /* TCL_IO_TRACK_OS_FOR_DRIVER_WITH_BAD_BLOCKING */

	nread = (chanPtr->typePtr->inputProc)(chanPtr->instanceData,
		InsertPoint(bufPtr), toRead, &result);

#ifdef TCL_IO_TRACK_OS_FOR_DRIVER_WITH_BAD_BLOCKING
    }
#endif /* TCL_IO_TRACK_OS_FOR_DRIVER_WITH_BAD_BLOCKING */

    if (nread > 0) {

	 * Now seek to the new position in the channel as requested by the
	 * caller. Note that we prefer the wideSeekProc if that is available
	 * and non-NULL...
	 */

	if (HaveVersion(chanPtr->typePtr, TCL_CHANNEL_VERSION_3) &&
		chanPtr->typePtr->wideSeekProc != NULL) {
	    curPos = (chanPtr->typePtr->wideSeekProc) (chanPtr->instanceData,
		    offset, mode, &result);
	} else if (offset < Tcl_LongAsWide(LONG_MIN) ||
		offset > Tcl_LongAsWide(LONG_MAX)) {
	    result = EOVERFLOW;
	    curPos = Tcl_LongAsWide(-1);
	} else {
	    curPos = Tcl_LongAsWide((chanPtr->typePtr->seekProc) (
		    chanPtr->instanceData, Tcl_WideAsLong(offset), mode,
		    &result));
	}
	if (curPos == Tcl_LongAsWide(-1)) {
	    Tcl_SetErrno(result);
	}
    }

     * Get the current position in the device and compute the position where
     * the next character will be read or written. Note that we prefer the
     * wideSeekProc if that is available and non-NULL...
     */

    if (HaveVersion(chanPtr->typePtr, TCL_CHANNEL_VERSION_3) &&
	    chanPtr->typePtr->wideSeekProc != NULL) {
	curPos = (chanPtr->typePtr->wideSeekProc) (chanPtr->instanceData,
		Tcl_LongAsWide(0), SEEK_CUR, &result);
    } else {
	curPos = Tcl_LongAsWide((chanPtr->typePtr->seekProc) (
		chanPtr->instanceData, 0, SEEK_CUR, &result));
    }
    if (curPos == Tcl_LongAsWide(-1)) {
	Tcl_SetErrno(result);
	return Tcl_LongAsWide(-1);
    }
    if (inputBuffered != 0) {

    if (chanPtr->typePtr->getOptionProc != NULL) {
	/*
	 * Let the driver specific handle additional options and result code
	 * and message.
	 */

	return (chanPtr->typePtr->getOptionProc) (chanPtr->instanceData,
		interp, optionName, dsPtr);
    } else {
	/*
	 * No driver specific options case.
	 */

	if (len == 0) {
	    return TCL_OK;

		ckfree((char *) argv);
		return TCL_ERROR;
	    }
	}
	ckfree((char *) argv);
	return TCL_OK;
    } else if (chanPtr->typePtr->setOptionProc != NULL) {
	return (*chanPtr->typePtr->setOptionProc)(chanPtr->instanceData,
		interp, optionName, newValue);
    } else {
	return Tcl_BadChannelOption(interp, optionName, NULL);
    }

    /*
     * If bufsize changes, need to get rid of old utility buffer.
     */

    while (mask && (chanPtr->upChanPtr != (NULL))) {
	Tcl_DriverHandlerProc *upHandlerProc;

	upChanPtr = chanPtr->upChanPtr;
	upTypePtr = upChanPtr->typePtr;
	upHandlerProc = Tcl_ChannelHandlerProc(upTypePtr);
	if (upHandlerProc != NULL) {
	    mask = (*upHandlerProc) (upChanPtr->instanceData, mask);
	}

	/*
	 * ELSE: Ignore transformations which are unable to handle the event
	 * coming from below. Assume that they don't change the mask and pass
	 * it on.
	 */

	/*
	 * If this channel handler is interested in any of the events that
	 * have occurred on the channel, invoke its procedure.
	 */

	if ((chPtr->mask & mask) != 0) {
	    nh.nextHandlerPtr = chPtr->nextPtr;
	    (*(chPtr->proc))(chPtr->clientData, mask);
	    chPtr = nh.nextHandlerPtr;
	} else {
	    chPtr = chPtr->nextPtr;
	}
    }

    /*

	    if (!statePtr->timer) {
		statePtr->timer = Tcl_CreateTimerHandler(0, ChannelTimerProc,
			chanPtr);
	    }
	}
    }
    (chanPtr->typePtr->watchProc)(chanPtr->instanceData, mask);
}

/*
 *----------------------------------------------------------------------
 *
 * ChannelTimerProc --
 *

     * Start at the top of the channel stack
     */

    chanPtr = chanPtr->state->topChanPtr;
    while (chanPtr != NULL) {
	blockModeProc = Tcl_ChannelBlockModeProc(chanPtr->typePtr);
	if (blockModeProc != NULL) {
	    result = (*blockModeProc) (chanPtr->instanceData, mode);
	    if (result != 0) {
		Tcl_SetErrno(result);
		return result;
	    }
	}
	chanPtr = chanPtr->downChanPtr;
    }

    if (HaveVersion(chanTypePtr, TCL_CHANNEL_VERSION_2)) {
	return chanTypePtr->blockModeProc;
    } else {
	/*
	 * The v1 structure had the blockModeProc in a different place.
	 */

	return (Tcl_DriverBlockModeProc *) (chanTypePtr->version);
    }
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_ChannelCloseProc --

DupChannelIntRep(
    register Tcl_Obj *srcPtr,	/* Object with internal rep to copy. Must have
				 * an internal rep of type "Channel". */
    register Tcl_Obj *copyPtr)	/* Object with internal rep to set. Must not
				 * currently have an internal rep.*/
{
    ChannelState *statePtr = GET_CHANNELSTATE(srcPtr);

    SET_CHANNELSTATE(copyPtr, statePtr);
    Tcl_Preserve((ClientData) statePtr);
    copyPtr->typePtr = &tclChannelType;
}

/*
 *----------------------------------------------------------------------
 *
 * SetChannelFromAny --

	/*
	 * The channel is valid until any call to DetachChannel occurs.
	 * Ensure consistency checks are done.
	 */
	statePtr = GET_CHANNELSTATE(objPtr);
	if (statePtr->flags & (CHANNEL_TAINTED|CHANNEL_CLOSED)) {
	    ResetFlag(statePtr, CHANNEL_TAINTED);
	    Tcl_Release((ClientData) statePtr);
	    UpdateStringOfChannel(objPtr);
	    objPtr->typePtr = NULL;
	}
    }
    if (objPtr->typePtr != &tclChannelType) {
	Tcl_Channel chan;

	chan = Tcl_GetChannel(interp, objPtr->bytes, NULL);
	if (chan == NULL) {
	    return TCL_ERROR;
	}

	TclFreeIntRep(objPtr);
	statePtr = ((Channel *)chan)->state;
	Tcl_Preserve((ClientData) statePtr);
	SET_CHANNELSTATE(objPtr, statePtr);
	objPtr->typePtr = &tclChannelType;
    }
    return TCL_OK;
}

/*

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

static void
FreeChannelIntRep(
    Tcl_Obj *objPtr)		/* Object with internal rep to free. */
{
    Tcl_Release((ClientData) GET_CHANNELSTATE(objPtr));
}

#if 0
/*
 * For future debugging work, a simple function to print the flags of a
 * channel in semi-readable form.
 */

 *	See TIP #230 for the specification of this functionality.
 *
 * Copyright (c) 2007-2008 ActiveState.
 *
 * See the file "license.terms" for information on usage and redistribution of
 * this file, and for a DISCLAIMER OF ALL WARRANTIES.
 *
 * RCS: @(#) $Id: tclIORTrans.c,v 1.3.2.3 2008/10/17 20:52:24 dgp Exp $
 */

#include <tclInt.h>
#include <tclIO.h>
#include <assert.h>

#ifndef EINVAL

static int		ReflectGetOption(ClientData clientData,
			    Tcl_Interp *interp, const char *optionName,
			    Tcl_DString *dsPtr);
static int		ReflectSetOption(ClientData clientData,
			    Tcl_Interp *interp, const char *optionName,
			    const char *newValue);
static int		ReflectHandle(ClientData clientData, int direction,
				      ClientData* handle);
static int		ReflectNotify(ClientData clientData, int mask);

/*
 * The C layer channel type/driver definition used by the reflection. This is
 * a version 3 structure.
 */

static Tcl_ChannelType tclRTransformType = {
    "tclrtransform",       /* Type name.                                  */
    TCL_CHANNEL_VERSION_5, /* v5 channel */
    ReflectClose,          /* Close channel, clean instance data          */
    ReflectInput,          /* Handle read request                         */
    ReflectOutput,         /* Handle write request                        */
    ReflectSeek,           /* Move location of access point.              */
    ReflectSetOption,      /* Set options.                                */
    ReflectGetOption,      /* Get options.                                */
    ReflectWatch,          /* Initialize notifier                         */
    ReflectHandle,         /* Get OS handle from the channel.             */
    NULL,                  /* No close2 support.               NULL'able  */
    ReflectBlock,          /* Set blocking/nonblocking.                   */
    NULL,                  /* Flush channel. Not used by core. NULL'able  */

    ReflectNotify,         /* Handle events.                              */
    ReflectSeekWide,       /* Move access point (64 bit).                 */
    NULL,                  /* thread action */
    NULL,                  /* truncate */
};

/*
 * Structure of the buffer to hold transform results to be consumed by higher
 * layers upon reading from the channel, plus the functions to manage such.
 */

typedef struct _ResultBuffer_ {
  unsigned char* buf;       /* Reference to the buffer area */
  int            allocated; /* Allocated size of the buffer area */
  int            used;      /* Number of bytes in the buffer, <= allocated */

} ResultBuffer;

#define ResultLength(r) ((r)->used)
/* static int ResultLength        (ResultBuffer* r); */

static void  ResultClear          (ResultBuffer* r);
static void  ResultInit           (ResultBuffer* r);

static void  ResultAdd            (ResultBuffer* r, unsigned char* buf, int toWrite);

static int   ResultCopy           (ResultBuffer* r, unsigned char* buf, int toRead);

#define RB_INCREMENT (512)

/*
 * Convenience macro to make some casts easier to use.
 */

#define UCHARP(x)	((unsigned char *) (x))

/*
 * Instance data for a reflected transformation. ===========================
 */

typedef struct {
    Tcl_Channel chan;		/* Back reference to the channel of the
				 * transformation itself. */
    Tcl_Channel parent;         /* Reference to the channel the transformation
				 * was pushed on. */
    Tcl_Interp *interp;		/* Reference to the interpreter containing the
				 * Tcl level part of the channel. */
    Tcl_Obj    *handle;         /* Reference to transform handle. Also stored
				 * in the argv, see below. The separate field
				 * gives us direct access, needed when working
				 * with the reflection maps.
				 */
#ifdef TCL_THREADS
    Tcl_ThreadId thread;	/* Thread the 'interp' belongs to. */
#endif

    Tcl_TimerToken timer;

    /* See [==] as well.
     * Storage for the command prefix and the additional words required for
     * the invocation of methods in the command handler.
     *
     * argv [0] ... [.] | [argc-2] [argc-1] | [argc]  [argc+2]
     *      cmd ... pfx | method   chan     | detail1 detail2
     *      ~~~~ CT ~~~            ~~ CT ~~
     *
     * CT = Belongs to the 'Command handler Thread'.
     */

    int argc;			/* Number of preallocated words - 2 */
    Tcl_Obj **argv;		/* Preallocated array for calling the handler.
				 * args[0] is placeholder for cmd word.
				 * Followed by the arguments in the prefix,
				 * plus 4 placeholders for method, channel,
				 * and at most two varying (method specific)
				 * words. */
    int methods;		/* Bitmask of supported methods */

    /*
     * NOTE (9): Should we have predefined shared literals for the method
     * names?
     */

    int mode;			/* Mask of R/W mode */
    int nonblocking;            /* Flag: Channel is blocking or not */
    int readIsDrained;          /* Flag: Read buffers are flushed*/

    ResultBuffer result;

} ReflectedTransform;

/*
 * Structure of the table mapping from transform handles to reflected
 * transform (channels). Each interpreter which has the handler command for
 * one or more reflected transforms records them in such a table, so that we
 * are able to find them during interpreter/thread cleanup even if the actual

    ForwardedInput,
    ForwardedLimit,
    ForwardedOutput
} ForwardedOperation;

/*
 * Event used to forward driver invocations to the thread actually managing
 * the channel. We cannot construct the command to execute and forward
 * that. Because then it will contain a mixture of Tcl_Obj's belonging to both
 * the command handler thread (CT), and the thread managing the channel (MT),
 * executed in CT. Tcl_Obj's are not allowed to cross thread boundaries. So we
 * forward an operation code, the argument details, and reference to results.
 * The command is assembled in the CT and belongs fully to that thread. No
 * sharing problems.
 */

typedef struct ForwardParamBase {

/*
 * Now join all these together in a single union for convenience.
 */

typedef union ForwardParam {
    ForwardParamBase base;
    struct ForwardParamTransform transform;
    struct ForwardParamLimit     limit;
} ForwardParam;

/*
 * Forward declaration.
 */

typedef struct ForwardingResult ForwardingResult;

};

typedef struct ThreadSpecificData {
    /*
     * Table of all reflected transformations owned by this thread.
     */

    ReflectedTransformMap* rtmPtr;
} ThreadSpecificData;

static Tcl_ThreadDataKey dataKey;

/*
 * List of forwarded operations which have not completed yet, plus the mutex
 * to protect the access to this process global list.

 *
 * The two ExitProcs are handlers so that things do not deadlock when either
 * thread involved in the forwarding exits. They also clean things up so that
 * we don't leak resources when threads go away.
 */

static void		ForwardOpToOwnerThread(ReflectedTransform *rtPtr,
			    ForwardedOperation op, const VOID *param);
static int		ForwardProc(Tcl_Event *evPtr, int mask);
static void		SrcExitProc(ClientData clientData);

#define FreeReceivedError(p) \
	if ((p)->base.mustFree) { \
	    ckfree((p)->base.msgStr); \
	}

/*
 * Global constant strings (messages). ==================
 * These string are used directly as bypass errors, thus they have to be valid
 * Tcl lists where the last element is the message itself. Hence the
 * list-quoting to keep the words of the message together. See also [x].
 */

static const char *msg_read_badlimit = "{Tcl driver returned bad read limit '0'}";

static const char *msg_read_unsup = "{read not supported by Tcl driver}";
static const char *msg_write_unsup = "{write not supported by Tcl driver}";
#ifdef TCL_THREADS
static const char *msg_send_originlost = "{Channel thread lost}";
static const char *msg_send_dstlost = "{Owner lost}";
#endif /* TCL_THREADS */

static const char *msg_dstlost    = "-code 1 -level 0 -errorcode NONE -errorinfo {} -errorline 1 {Owner lost}";

/*
 * Timer management (flushing out buffered data via artificial events).
 */

/*
 * Number of milliseconds to wait before firing an event to try to
 * flush out information waiting in buffers (fileevent support).
 */

#define FLUSH_DELAY (5)

static void TimerKill  (ReflectedTransform* rtPtr);
static void TimerSetup (ReflectedTransform* rtPtr);
static void TimerRun   (ClientData clientData);

/*
 * Helper functions encapsulating some of the thread forwarding to make the
 * control flow in callers easier.
 */


static int  TransformRead  (ReflectedTransform* rtPtr, int* errorCodePtr, unsigned char* buf, int toRead);


static int  TransformWrite (ReflectedTransform* rtPtr, int* errorCodePtr, unsigned char* buf, int toWrite);

static int  TransformDrain (ReflectedTransform* rtPtr, int* errorCodePtr);


static int  TransformFlush (ReflectedTransform* rtPtr, int* errorCodePtr, int op);

static void TransformClear (ReflectedTransform* rtPtr);
static int  TransformLimit (ReflectedTransform* rtPtr, int* errorCodePtr, int* maxPtr);

/* op'codes for TransformFlush */
#define FLUSH_WRITE   1
#define FLUSH_DISCARD 0

/*
 * Main methods to plug into the 'chan' ensemble'. ==================
 */

/*
 *----------------------------------------------------------------------
 *
 * TclChanPushObjCmd --
 *
 *	This function is invoked to process the "chan push" Tcl command.
 *	See the user documentation for details on what it does.
 *
 * Results:
 *	A standard Tcl result. The handle of the new channel is placed in the
 *	interp result.
 *
 * Side effects:
 *	Creates a new channel.
 *
 *----------------------------------------------------------------------
 */

int
TclChanPushObjCmd(
    ClientData clientData,
    Tcl_Interp *interp,
    int objc,
    Tcl_Obj *const *objv)
{
    ReflectedTransform *rtPtr;	/* Instance data of the new (transform) channel */

    Tcl_Obj*    chanObj;        /* Handle of parent channel */
    Tcl_Channel parentChan;     /* Token of parent channel */
    int mode;			/* R/W mode of parent, later the new
				 * channel. Has to match the abilities of the
				 * handler commands */
    Tcl_Obj *cmdObj;		/* Command prefix, list of words */
    Tcl_Obj *cmdNameObj;	/* Command name */
    Tcl_Obj *rtId;		/* Handle of the new transform (channel) */
    Tcl_Obj *modeObj;		/* mode in obj form for method call */

    int listc;			/* Result of 'initialize', and of */
    Tcl_Obj **listv;		/* its sublist in the 2nd element */
    int methIndex;		/* Encoded method name */
    int result;			/* Result code for 'initialize' */
    Tcl_Obj *resObj;		/* Result data for 'initialize' */
    int methods;		/* Bitmask for supported methods. */
    Tcl_Obj *err;		/* Error message */
    ReflectedTransformMap *rtmPtr;
				/* Map of reflected transforms with handlers in
				 * this interp. */
    Tcl_HashEntry *hPtr;	/* Entry in the above map */
    int isNew;			/* Placeholder. */

    /*
     * Syntax:   chan push CHANNEL CMDPREFIX
     *           [0]  [1]  [2]     [3]
     *

	return TCL_ERROR;
    }

    /*
     * First argument is a channel handle.
     */

    chanObj    = objv[CHAN];
    parentChan = Tcl_GetChannel (interp, Tcl_GetString (chanObj), &mode);
    if (parentChan == NULL) {
	return TCL_ERROR;
    }
    parentChan = Tcl_GetTopChannel (parentChan);

    /*
     * Second argument is command prefix, i.e. list of words, first word is
     * name of handler command, other words are fixed arguments. Run
     * 'initialize' method to get the list of supported methods. Validate
     * this.
     */

    cmdObj = objv[CMD];

    /*

	UnmarshallErrorResult(interp, resObj);
	Tcl_DecrRefCount(resObj);	/* Remove reference held from invoke */
	goto error;
    }

    /*
     * Verify the result.
     * - List, of method names. Convert to mask.
     *   Check for non-optionals through the mask.
     *   Compare open mode against optional r/w.
     */

    if (Tcl_ListObjGetElements(NULL, resObj, &listc, &listv) != TCL_OK) {
	TclNewLiteralStringObj(err, "chan handler \"");
	Tcl_AppendObjToObj(err, cmdObj);
	Tcl_AppendToObj(err, " initialize\" returned non-list: ", -1);
	Tcl_AppendObjToObj(err, resObj);

     * Mode tell us what the parent channel supports. The methods tell us what
     * the handler supports. We remove the non-supported bits from the mode
     * and check that the channel is not completely inacessible. Afterward the
     * mode tells us which methods are still required, and these methods will
     * also be supported by the handler, by design of the check.
     */

    if (!HAS(methods, METH_READ))  { mode &= ~TCL_READABLE; }


    if (!HAS(methods, METH_WRITE)) { mode &= ~TCL_WRITABLE; }



    if (!mode) {
	TclNewLiteralStringObj(err, "chan handler \"");
	Tcl_AppendObjToObj(err, cmdObj);
	Tcl_AppendToObj(err, "\" makes the channel inacessible", -1);
	Tcl_SetObjResult(interp, err);
	goto error;

    Tcl_ResetResult(interp);

    /*
     * Everything is fine now.
     */

    rtPtr->methods = methods;
    rtPtr->mode    = mode;
    rtPtr->chan    = Tcl_StackChannel (interp, &tclRTransformType,
				       (ClientData) rtPtr, mode,
				       rtPtr->parent);

    /*
     * Register the transform in our our map for proper handling of deleted
     * interpreters and/or threads.
     */

    rtmPtr = GetReflectedTransformMap (interp);
    hPtr = Tcl_CreateHashEntry(&rtmPtr->map, Tcl_GetString(rtId),
	    &isNew);
    if (!isNew && rtPtr != Tcl_GetHashValue(hPtr)) {
	Tcl_Panic("TclChanPushObjCmd: duplicate transformation handle");
    }
    Tcl_SetHashValue(hPtr, rtPtr);
#ifdef TCL_THREADS
    rtmPtr = GetThreadReflectedTransformMap();
    hPtr = Tcl_CreateHashEntry(&rtmPtr->map, Tcl_GetString(rtId),
	    &isNew);
    Tcl_SetHashValue(hPtr, rtPtr);
#endif

    /*
     * Return the channel as the result of the command.
     */

    Tcl_AppendResult (interp, Tcl_GetChannelName (rtPtr->chan),
		    (char*) NULL);
    return TCL_OK;

 error:
    /*
     * We are not going through ReflectClose as we never had a channel
     * structure.
     */

    FreeReflectedTransform(rtPtr);
    return TCL_ERROR;

#undef CHAN
#undef CMD
}

/*
 *----------------------------------------------------------------------
 *
 * TclChanPopObjCmd --
 *
 *	This function is invoked to process the "chan pop" Tcl command.
 *	See the user documentation for details on what it does.
 *
 * Results:
 *	A standard Tcl result.
 *
 * Side effects:
 *	Posts events to a reflected channel, invokes event handlers. The
 *	latter implies that arbitrary side effects are possible.

     *           [0]  [1]
     */

#define CHAN	(1)

    const char *chanId;		/* Tcl level channel handle */
    Tcl_Channel chan;		/* Channel associated to the handle */
    int         mode;           /* Channel r/w mode */

    /*
     * Number of arguments...
     */

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

    /*
     * First argument is a channel, which may have a (reflected)
     * transformation.
     */

    chanId = TclGetString(objv[CHAN]);
    chan   = Tcl_GetChannel(interp, chanId, &mode);

    if (chan == NULL) {
	return TCL_ERROR;
    }


    /* Removing transformations is generic, and not restricted to reflected
     * transformations.
     */

    Tcl_UnstackChannel(interp, chan);
    return TCL_OK;

#undef CHAN
}

/*
 * Channel error message marshalling utilities.
 */

static Tcl_Obj*
MarshallError(
    Tcl_Interp *interp)
{
    /*
     * Capture the result status of the interpreter into a string. => List of
     * options and values, followed by the error message. The result has
     * refCount 0.

    explicitResult = lc & 1;		/* Odd number of values? */
    numOptions = lc - explicitResult;

    if (explicitResult) {
	Tcl_SetObjResult(interp, lv[lc-1]);
    }

    (void) Tcl_SetReturnOptions(interp, Tcl_NewListObj(numOptions, lv));
    ((Interp *)interp)->flags &= ~ERR_ALREADY_LOGGED;
}

/*
 * Driver functions. ================================================
 */

/*

 */

static int
ReflectClose(
    ClientData clientData,
    Tcl_Interp *interp)
{
    ReflectedTransform *rtPtr = (ReflectedTransform *) clientData;
    int result;			/* Result code for 'close' */
    Tcl_Obj *resObj;		/* Result data for 'close' */
    ReflectedTransformMap *rtmPtr;/* Map of reflected transforms with handlers in

				 * this interp */
    Tcl_HashEntry *hPtr;	/* Entry in the above map */

    if (interp == NULL) {
	/*
	 * This call comes from TclFinalizeIOSystem. There are no
	 * interpreters, and therefore we cannot call upon the handler command
	 * anymore. Threading is irrelevant as well. We simply clean up all

     * In the reflected channel implementation a cleaned method mask here
     * implies that the channel creation was aborted, and "finalize" must not
     * be called. for transformations however we are not going through here on
     * such an abort, but directly through FreeReflectedTransform. So for us
     * that check is not necessary. We always go through 'finalize'.
     */

    if (HAS(rtPtr->methods, METH_DRAIN) && (!rtPtr->readIsDrained)) {
	int errorCode;

	if (!TransformDrain (rtPtr, &errorCode)) {
	    return errorCode;
	}
    }

    if (HAS(rtPtr->methods, METH_FLUSH)) {
	int errorCode;

	if (!TransformFlush (rtPtr, &errorCode, FLUSH_WRITE)) {
	    return errorCode;
	}
    }

    /*
     * Are we in the correct thread?
     */

	/*
	 * FreeReflectedTransform is done in the forwarded operation!, in the
	 * other thread. rtPtr here is gone!
	 */

	if (result != TCL_OK) {
	    PassReceivedErrorInterp(interp, &p);

	}
    } else {

#endif





	result = InvokeTclMethod(rtPtr, "finalize", NULL, NULL, &resObj);
	if ((result != TCL_OK) && (interp != NULL)) {
	    Tcl_SetChannelErrorInterp(interp, resObj);
	}

	Tcl_DecrRefCount(resObj);	/* Remove reference we held from the
					 * invoke */

	/*
	 * Remove the transform from the map before releasing the memory, to
	 * prevent future accesses from finding and dereferencing a dangling
	 * pointer.
	 *
	 * NOTE: The transform may not be in the map. This is ok, that happens
	 * when the transform was created in a different interpreter and/or
	 * thread and then was moved here.
	 */

	rtmPtr = GetReflectedTransformMap(interp);
 	hPtr = Tcl_FindHashEntry (&rtmPtr->map,
 				  Tcl_GetString(rtPtr->handle));
	if (hPtr) {
	    Tcl_DeleteHashEntry (hPtr);
	}
#ifdef TCL_THREADS
	/*
	 * In a threaded interpreter we manage a per-thread map as well, to
	 * allow us to survive if the script level pulls the rug out under a
	 * channel by deleting the owning thread.
	 */


        rtmPtr = GetThreadReflectedTransformMap();
	hPtr = Tcl_FindHashEntry (&rtmPtr->map,
				  Tcl_GetString(rtPtr->handle));
	if (hPtr) {
	    Tcl_DeleteHashEntry (hPtr);
	}
#endif

	FreeReflectedTransform(rtPtr);
#ifdef TCL_THREADS
    }
#endif
    return (result == TCL_OK) ? EOK : EINVAL;
}

/*
 *----------------------------------------------------------------------
 *
 * ReflectInput --

 *	Allocates memory. Arbitrary, as it calls upon a script.
 *
 *----------------------------------------------------------------------
 */

static int
ReflectInput(
	     ClientData clientData,
	     char *buf,
	     int toRead,
	     int *errorCodePtr)
{
    ReflectedTransform *rtPtr = (ReflectedTransform *) clientData;
    int gotBytes, copied, read;

    /*
     * The following check can be done before thread redirection, because we
     * are reading from an item which is readonly, i.e. will never change
     * during the lifetime of the channel.
     */

    if (!(rtPtr->methods & FLAG(METH_READ))) {
	SetChannelErrorStr(rtPtr->chan, msg_read_unsup);
	*errorCodePtr = EINVAL;
	return -1;
    }

    gotBytes = 0;

    while (toRead > 0) {

	/* Loop until the request is satisfied (or no data available from
	 * below, possibly EOF).
	 */

	copied    = ResultCopy (&rtPtr->result, UCHARP(buf), toRead);
	toRead   -= copied;
	buf      += copied;
	gotBytes += copied;

	if (toRead == 0) {
	    return gotBytes;
	}

	/*
	 * The buffer is exhausted, but the caller wants even more. We now
	 * have to go to the underlying channel, get more bytes and then
	 * transform them for delivery. We may not get what we want (full EOF
	 * or temporarily out of data).
	 */

	/*
	 * Length (rtPtr->result) == 0, toRead > 0 here. Use 'buf'! as target
	 * to store the intermediary information read from the parent channel.
	 *
	 * Ask the transform how much data it allows us to read from the
	 * underlying channel. This feature allows the transform to signal EOF
	 * upstream although there is none downstream. Useful to control an
	 * unbounded 'fcopy' for example, either through counting bytes, or by
	 * pattern matching.
	 */

	if ((rtPtr->methods & FLAG(METH_LIMIT))) {
	    int maxRead = -1;

	    if (!TransformLimit (rtPtr, errorCodePtr, &maxRead)) {
		return -1;
	    }
	    if (maxRead == 0) {
		SetChannelErrorStr(rtPtr->chan, msg_read_badlimit);
		return -1;
	    } else if (maxRead > 0) {
		if (maxRead < toRead) {
		    toRead = maxRead;
		}
	    } /* else: 'maxRead < 0' == Accept the current value of toRead */
	}

	if (toRead <= 0) {
	    return gotBytes;
	}

	read = Tcl_ReadRaw (rtPtr->parent, buf, toRead);
	if (read < 0) {

	    /* Report errors to caller.
	     * The state of the seek system is unchanged!
	     */

	    if ((Tcl_GetErrno () == EAGAIN) && (gotBytes > 0)) {

		/* EAGAIN is a special situation.  If we had some data
		 * before we report that instead of the request to re-try.
		 */

		return gotBytes;
	    }

	    *errorCodePtr = Tcl_GetErrno ();
	    return -1;
	}

	if (read == 0) {
	    /*
	     * Check wether we hit on EOF in 'parent' or not. If not
	     * differentiate between blocking and non-blocking modes. In
	     * non-blocking mode we ran temporarily out of data. Signal this
	     * to the caller via EWOULDBLOCK and error return (-1). In the
	     * other cases we simply return what we got and let the caller
	     * wait for more. On the other hand, if we got an EOF we have to
	     * convert and flush all waiting partial data.
	     */

	    if (!Tcl_Eof (rtPtr->parent)) {

		/* The state of the seek system is unchanged! */


		if ((gotBytes == 0) && rtPtr->nonblocking) {
		    *errorCodePtr = EWOULDBLOCK;
		    return -1;
		} else {
		    return gotBytes;
		}

	    } else {

		/* Eof in parent */


		if (rtPtr->readIsDrained) {
		    return gotBytes;
		}

		/*
		 * Now this is a bit different. The partial data waiting is
		 * converted and returned.
		 */

		if (HAS(rtPtr->methods, METH_DRAIN)) {
		    if(!TransformDrain (rtPtr, errorCodePtr)) {
			return -1;
		    }
		}

		if (ResultLength (&rtPtr->result) == 0) {

		    /* The drain delivered nothing */


		    return gotBytes;
		}


		/* Reset eof, force caller to drain result buffer */


                ((Channel*) rtPtr->parent)->state->flags &= ~CHANNEL_EOF;
		continue; /* at: while (toRead > 0) */
	    }
	} /* read == 0 */

	/*
	 * Transform the read chunk, which was not empty. Anything we got back
	 * is a transformation result is put into our buffers, and the next
	 * iteration will put it into the result.
	 */

	if (!TransformRead (rtPtr, errorCodePtr, UCHARP(buf), read)) {
	    return -1;
	}
    } /* while toRead > 0 */

    return gotBytes;

}

/*
 *----------------------------------------------------------------------
 *
 * ReflectOutput --
 *

static int
ReflectOutput(
    ClientData clientData,
    const char *buf,
    int toWrite,
    int *errorCodePtr)
{
    ReflectedTransform *rtPtr = (ReflectedTransform *) clientData;

    /*
     * The following check can be done before thread redirection, because we
     * are reading from an item which is readonly, i.e. will never change
     * during the lifetime of the channel.
     */

    if (!(rtPtr->methods & FLAG(METH_WRITE))) {
	SetChannelErrorStr(rtPtr->chan, msg_write_unsup);
	*errorCodePtr = EINVAL;
	return -1;
    }

    if (toWrite == 0) {

	/* Nothing came in to write, ignore the call
	 */

	return 0;
    }

    /*
     * Discard partial data in the input buffers, i.e. on the read side. Like
     * we do when explicitly seeking as well.
     */

    if ((rtPtr->methods & FLAG(METH_CLEAR))) {
	TransformClear (rtPtr);
    }

    /*
     * Hand the data to the transformation itself. Anything it deigned to
     * return to us is a (partial) transformation result and written to the
     * parent channel for further processing.
     */

    if (!TransformWrite (rtPtr, errorCodePtr, UCHARP(buf), toWrite)) {
	return -1;
    }

    *errorCodePtr = EOK;
    return toWrite;
}

/*
 *----------------------------------------------------------------------
 *
 * ReflectSeekWide / ReflectSeek --
 *
 *	This function is invoked when the user wishes to seek on the channel.
 *
 * Results:
 *	The new location of the access point.
 *
 * Side effects:
 *	Allocates memory. Arbitrary, per the parent channel, and the called scripts.

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

static Tcl_WideInt
ReflectSeekWide(
    ClientData clientData,
    Tcl_WideInt offset,
    int seekMode,
    int *errorCodePtr)
{
    ReflectedTransform *rtPtr = (ReflectedTransform *) clientData;
    Channel* parent = (Channel*) rtPtr->parent;
    Tcl_WideInt curPos;		/* Position on the device. */

    Tcl_DriverSeekProc *seekProc      =
	Tcl_ChannelSeekProc(Tcl_GetChannelType (rtPtr->parent));

    /*
     * Fail if the parent channel is not seekable.
     */

    if (seekProc == NULL) {
	Tcl_SetErrno(EINVAL);
	return Tcl_LongAsWide(-1);
    }

    /*
     * Check if we can leave out involving the Tcl level, i.e. transformation
     * handler. This is true for tell requests, and transformations which
     * support neither flush, nor drain. For these cases we can pass the
     * request down and the result back up unchanged.
     */

    if (
	((seekMode != SEEK_CUR) || (offset != 0)) &&
	(HAS(rtPtr->methods, METH_CLEAR) ||
	 HAS(rtPtr->methods, METH_FLUSH))
	) {
	/*
	 * Neither a tell request, nor clear/flush both not supported.  We
	 * have to go through the Tcl level to clear and/or flush the
	 * transformation.
	 */

	if ((rtPtr->methods & FLAG(METH_CLEAR))) {
	    TransformClear (rtPtr);
	}

	/*
	 * When flushing the transform for seeking the generated results are
	 * irrelevant. We cannot put them into the channel, this would move
	 * the location, throwing it off with regard to where we are and are
	 * seeking to.
	 */

	if (HAS(rtPtr->methods, METH_FLUSH)) {
	    if (!TransformFlush (rtPtr, errorCodePtr, FLUSH_DISCARD)) {
		return -1;
	    }
	}
    }

    /*
     * Now seek to the new position in the channel as requested by the
     * caller. Note that we prefer the wideSeekProc if that is available and
     * non-NULL...
     */

    if (HaveVersion(parent->typePtr, TCL_CHANNEL_VERSION_3) &&
	parent->typePtr->wideSeekProc != NULL) {
	curPos = (parent->typePtr->wideSeekProc) (parent->instanceData,
						  offset, seekMode, errorCodePtr);
    } else if (offset < Tcl_LongAsWide(LONG_MIN) ||
	       offset > Tcl_LongAsWide(LONG_MAX)) {
	*errorCodePtr = EOVERFLOW;
	curPos = Tcl_LongAsWide(-1);
    } else {
	curPos = Tcl_LongAsWide((parent->typePtr->seekProc) (
		parent->instanceData, Tcl_WideAsLong(offset), seekMode,
		errorCodePtr));
    }
    if (curPos == Tcl_LongAsWide(-1)) {
	Tcl_SetErrno(*errorCodePtr);
    }

 */

static void
ReflectWatch(
    ClientData clientData,
    int mask)
{
    ReflectedTransform *rtPtr = (ReflectedTransform *) clientData;
    Tcl_DriverWatchProc* watchProc;

    watchProc = Tcl_ChannelWatchProc (Tcl_GetChannelType (rtPtr->parent));
    (*watchProc) (Tcl_GetChannelInstanceData(rtPtr->parent),
		  mask);

    /*
     * Management of the internal timer.
     */

    if (!(mask & TCL_READABLE) || (ResultLength(&rtPtr->result) == 0)) {
	/*
	 * A pending timer may exist, but either is there no (more) interest
	 * in the events it generates or nothing is available for
	 * reading. Remove it, if existing.
	 */

	TimerKill (rtPtr);
    } else {
	/*
	 * There might be no pending timer, but there is interest in readable
	 * events and we actually have data waiting, so generate a timer to
	 * flush that if it does not exist.
	 */

	TimerSetup (rtPtr);
    }
}

/*
 *----------------------------------------------------------------------
 *
 * ReflectBlock --

 */

static int
ReflectBlock(
    ClientData clientData,
    int nonblocking)
{
    ReflectedTransform *rtPtr = (ReflectedTransform *) clientData;

    /*
     * Transformations simply record the blocking mode in their C level
     * structure for use by --> ReflectInput. The Tcl level doesn't see this
     * information or change. As such thread forwarding is not required.
     */

static int
ReflectSetOption(
    ClientData clientData,	/* Channel to query */
    Tcl_Interp *interp,		/* Interpreter to leave error messages in */
    const char *optionName,	/* Name of requested option */
    const char *newValue)	/* The new value */
{
    ReflectedTransform *rtPtr = (ReflectedTransform *) clientData;

    /*
     * Transformations have no options. Thus the call is passed down unchanged
     * to the parent channel for processing. Its results are passed back
     * unchanged as well. This all happens in the thread we are in. As the Tcl
     * level is not involved there is no need for thread forwarding.
     */

    Tcl_DriverSetOptionProc *setOptionProc =
      Tcl_ChannelSetOptionProc (Tcl_GetChannelType (rtPtr->parent));

    if (setOptionProc != NULL) {
      return (*setOptionProc) (Tcl_GetChannelInstanceData (rtPtr->parent),
			       interp, optionName, newValue);
    } else {
      return TCL_ERROR;
    }


}

/*
 *----------------------------------------------------------------------
 *
 * ReflectGetOption --
 *

static int
ReflectGetOption(
    ClientData clientData,	/* Channel to query */
    Tcl_Interp *interp,		/* Interpreter to leave error messages in */
    const char *optionName,	/* Name of reuqested option */
    Tcl_DString *dsPtr)		/* String to place the result into */
{
    ReflectedTransform *rtPtr = (ReflectedTransform *) clientData;

    /*
     * Transformations have no options. Thus the call is passed down unchanged
     * to the parent channel for processing. Its results are passed back
     * unchanged as well. This all happens in the thread we are in. As the Tcl
     * level is not involved there is no need for thread forwarding.
     *
     * Note that the parent not having a driver for option retrieval is not an
     * immediate error. A query for all options is ok. Only a request for a
     * specific option has to fail.
     */

    Tcl_DriverGetOptionProc *getOptionProc =
      Tcl_ChannelGetOptionProc (Tcl_GetChannelType (rtPtr->parent));

    if (getOptionProc != NULL) {
      return (*getOptionProc) (Tcl_GetChannelInstanceData (rtPtr->parent),
			       interp, optionName, dsPtr);
    } else if (optionName == (char*) NULL) {
      return TCL_OK;
    } else {
      return TCL_ERROR;
    }
}

/*
 *----------------------------------------------------------------------
 *
 * ReflectHandle --

 *	Arbitrary, per the parent channel.
 *
 *----------------------------------------------------------------------
 */

static int
ReflectHandle(
	      ClientData  clientData,
	      int         direction,
	      ClientData* handlePtr)
{
    ReflectedTransform *rtPtr = (ReflectedTransform *) clientData;

    /*
     * Transformations have no handle of their own. As such we simply query
     * the parent channel for it. This way the qery will ripple down through
     * all transformations until reaches the base channel. Which then returns
     * its handle, or fails. The former will then ripple up the stack.
     *
     * This all happens in the thread we are in. As the Tcl level is not
     * involved no forwarding is required.
     */

    return Tcl_GetChannelHandle (rtPtr->parent, direction, handlePtr);
}
/*
 *----------------------------------------------------------------------
 *
 * ReflectNotify --
 *
 *	This function is invoked to reported incoming events.
 *
 * Results:
 *	A standard Tcl result code.
 *
 * Side effects:
 *	Arbitrary, per the parent channel.
 *
 *----------------------------------------------------------------------
 */

static int
ReflectNotify(
	      ClientData clientData,
	      int mask)
{
    ReflectedTransform *rtPtr = (ReflectedTransform *) clientData;

    /*
     * An event occured in the underlying channel.
     *
     * We delete our timer. It was not fired, yet we are here, so the channel
     * below generated such an event and we don't have to. The renewal of the
     * interest after the execution of channel handlers will eventually cause
     * us to recreate the timer (in ReflectWatch).
     */

    TimerKill (rtPtr);

    /*
     * Pass to higher layers.
     */

    return mask;
}

#ifdef TCL_THREADS
    rtPtr->thread = Tcl_GetCurrentThread();
#endif
    rtPtr->parent = parentChan;
    rtPtr->interp = interp;
    rtPtr->handle = handleObj;
    Tcl_IncrRefCount(handleObj);
    rtPtr->timer  = (Tcl_TimerToken) NULL;
    rtPtr->mode = 0;
    rtPtr->readIsDrained = 0;
    rtPtr->nonblocking =
	(((Channel*) parentChan)->state->flags & CHANNEL_NONBLOCKING);


    /* Query parent for current blocking mode. */


    ResultInit (&rtPtr->result);

    /*
     * Method placeholder.
     */

    /* ASSERT: cmdpfxObj is a Tcl List */

    Tcl_ListObjGetElements(interp, cmdpfxObj, &listc, &listv);

    /*
     * See [==] as well.
     * Storage for the command prefix and the additional words required for
     * the invocation of methods in the command handler.
     *
     * listv [0] [listc-1] | [listc]  [listc+1] |
     * argv  [0]   ... [.] | [argc-2] [argc-1]  | [argc]  [argc+2]
     *       cmd   ... pfx | method   chan      | detail1 detail2
     */

    rtPtr->argc = listc + 2;
    rtPtr->argv = (Tcl_Obj**) ckalloc(sizeof(Tcl_Obj*) * (listc+4));

    /*
     * Duplicate object references.
     */

    for (i=0; i<listc ; i++) {
	Tcl_Obj *word = rtPtr->argv[i] = listv[i];

	Tcl_IncrRefCount(word);
    }

    i++;				/* Skip placeholder for method */

    /*
     * See [x] in FreeReflectedTransform for release


static void
FreeReflectedTransform(
    ReflectedTransform *rtPtr)
{
    int i, n;

    TimerKill   (rtPtr);
    ResultClear (&rtPtr->result);

    Tcl_DecrRefCount(rtPtr->handle);
    rtPtr->handle = NULL;

    n = rtPtr->argc - 2;
    for (i=0; i<n; i++) {
	Tcl_DecrRefCount(rtPtr->argv[i]);

static ReflectedTransformMap *
GetReflectedTransformMap(
    Tcl_Interp *interp)
{
    ReflectedTransformMap *rtmPtr = Tcl_GetAssocData(interp, RTMKEY, NULL);

    if (rtmPtr == NULL) {
	rtmPtr = (ReflectedTransformMap *) ckalloc(sizeof(ReflectedTransformMap));

	Tcl_InitHashTable(&rtmPtr->map, TCL_STRING_KEYS);
	Tcl_SetAssocData(interp, RTMKEY,
		(Tcl_InterpDeleteProc *) DeleteReflectedTransformMap, rtmPtr);
    }
    return rtmPtr;
}


    ClientData clientData,	/* The per-interpreter data structure. */
    Tcl_Interp *interp)		/* The interpreter being deleted. */
{
    ReflectedTransformMap *rtmPtr; /* The map */
    Tcl_HashSearch hSearch;	 /* Search variable. */
    Tcl_HashEntry *hPtr;	 /* Search variable. */
    ReflectedTransform *rtPtr;

#ifdef TCL_THREADS
    ForwardingResult *resultPtr;
    ForwardingEvent *evPtr;
    ForwardParam *paramPtr;
#endif

    /*

     * this interp.
     */

    rtmPtr = clientData;
    for (hPtr = Tcl_FirstHashEntry(&rtmPtr->map, &hSearch);
	    hPtr != NULL;
	    hPtr = Tcl_FirstHashEntry(&rtmPtr->map, &hSearch)) {
	rtPtr = (ReflectedTransform *) Tcl_GetHashValue (hPtr);
	rtPtr->interp = NULL;
	Tcl_DeleteHashEntry(hPtr);
    }
    Tcl_DeleteHashTable(&rtmPtr->map);
    ckfree((char *) &rtmPtr->map);

#ifdef TCL_THREADS
    /*
     * The origin interpreter for one or more reflected channels is gone.
     */

    /*
     * Go through the list of pending results and cancel all whose events were
     * destined for this interpreter. While this is in progress we block any
     * other access to the list of pending results.
     */

    Tcl_MutexLock(&rtForwardMutex);

    for (resultPtr = forwardList;
	    resultPtr != NULL;
	    resultPtr = resultPtr->nextPtr) {
	if (resultPtr->dsti != interp) {
	    /*
	     * Ignore results/events for other interpreters.
	     */

	    continue;

     * interpreter. They have already been marked as dead.
     */

    rtmPtr = GetThreadReflectedTransformMap();
    for (hPtr = Tcl_FirstHashEntry(&rtmPtr->map, &hSearch);
	    hPtr != NULL;
	    hPtr = Tcl_NextHashEntry(&hSearch)) {
	rtPtr = (ReflectedTransform *) Tcl_GetHashValue (hPtr);

	if (rtPtr->interp != interp) {
	    /*
	     * Ignore entries for other interpreters.
	     */

	    continue;

     * Go through the list of pending results and cancel all whose events were
     * destined for this thread. While this is in progress we block any
     * other access to the list of pending results.
     */

    Tcl_MutexLock(&rtForwardMutex);

    for (resultPtr = forwardList;
	    resultPtr != NULL;
	    resultPtr = resultPtr->nextPtr) {
	ForwardingEvent *evPtr;
	ForwardParam *paramPtr;

	if (resultPtr->dst != self) {
	    /*
	     * Ignore results/events for other threads.

     * through the channels, remove all, mark them as dead.
     */

    rtmPtr = GetThreadReflectedTransformMap();
    for (hPtr = Tcl_FirstHashEntry(&rtmPtr->map, &hSearch);
	    hPtr != NULL;
	    hPtr = Tcl_FirstHashEntry(&rtmPtr->map, &hSearch)) {
	ReflectedTransform *rtPtr = (ReflectedTransform *) Tcl_GetHashValue(hPtr);

	rtPtr->interp = NULL;
	Tcl_DeleteHashEntry(hPtr);
    }

    Tcl_MutexUnlock(&rtForwardMutex);
}

static void
ForwardOpToOwnerThread(
    ReflectedTransform *rtPtr,	/* Channel instance */
    ForwardedOperation op,	/* Forwarded driver operation */
    const VOID *param)		/* Arguments */
{
    Tcl_ThreadId dst = rtPtr->thread;
    ForwardingEvent *evPtr;
    ForwardingResult *resultPtr;
    int result;

    /*

     * Ensure cleanup of the event if the origin thread exits while this event
     * is pending or in progress. Exit of the destination thread is handled by
     * DeleteThreadReflectionChannelMap(), this is set up by
     * GetThreadReflectedTransformMap(). This is what we use the 'forwardList'
     * (see above) for.
     */

    Tcl_CreateThreadExitHandler(SrcExitProc, (ClientData) evPtr);

    /*
     * Queue the event and poke the other thread's notifier.
     */

    Tcl_ThreadQueueEvent(dst, (Tcl_Event *)evPtr, TCL_QUEUE_TAIL);
    Tcl_ThreadAlert(dst);

    /*
     * (*) Block until the other thread has either processed the transfer or
     * rejected it.
     */

     * Kill the cleanup handler now, and the result structure as well, before
     * returning the success code.
     *
     * Note: The event structure has already been deleted by the destination
     * notifier, after it serviced the event.
     */

    Tcl_DeleteThreadExitHandler(SrcExitProc, (ClientData) evPtr);

    result = resultPtr->result;
    ckfree((char*) resultPtr);
}

static int
ForwardProc(

    ForwardingEvent *evPtr = (ForwardingEvent *) evGPtr;
    ForwardingResult *resultPtr = evPtr->resultPtr;
    ReflectedTransform *rtPtr = evPtr->rtPtr;
    Tcl_Interp *interp = rtPtr->interp;
    ForwardParam *paramPtr = evPtr->param;
    Tcl_Obj *resObj = NULL;	/* Interp result of InvokeTclMethod */

    ReflectedTransformMap* rtmPtr; /* Map of reflected channels with handlers in this interp */

    Tcl_HashEntry* hPtr;         /* Entry in the above map */

    /*
     * Ignore the event if no one is waiting for its result anymore.
     */

    if (!resultPtr) {
	return 1;

	 */

    case ForwardedClose:
	/*
	 * No parameters/results.
	 */

	if (InvokeTclMethod(rtPtr, "finalize", NULL, NULL, &resObj) != TCL_OK) {

	    ForwardSetObjError(paramPtr, resObj);
	}

	/*
	 * Freeing is done here, in the origin thread, because the argv[]
	 * objects belong to this thread. Deallocating them in a different
	 * thread is not allowed
	 */

	/*
	 * Remove the channel from the map before releasing the memory, to
	 * prevent future accesses (like by 'postevent') from finding and
	 * dereferencing a dangling pointer.
	 */

	rtmPtr = GetReflectedTransformMap (interp);
	hPtr = Tcl_FindHashEntry (&rtmPtr->map,
				  Tcl_GetString(rtPtr->handle));
	Tcl_DeleteHashEntry (hPtr);

	/*
	 * In a threaded interpreter we manage a per-thread map as well, to
	 * allow us to survive if the script level pulls the rug out under a
	 * channel by deleting the owning thread.
	 */

        rtmPtr = GetThreadReflectedTransformMap();
	hPtr = Tcl_FindHashEntry (&rtmPtr->map,
				  Tcl_GetString(rtPtr->handle));
	Tcl_DeleteHashEntry (hPtr);
	FreeReflectedTransform(rtPtr);
	break;

    case ForwardedInput: {
	Tcl_Obj *bufObj = Tcl_NewByteArrayObj((unsigned char *) paramPtr->transform.buf,
					      paramPtr->transform.size);

	if (InvokeTclMethod(rtPtr, "read", bufObj, NULL, &resObj) != TCL_OK) {
	    ForwardSetObjError(paramPtr, resObj);
	    paramPtr->transform.size = -1;
	} else {
	    /*
	     * Process a regular return. Contains the transformation result.
	     * Sent it back to the request originator.
	     */

	    int bytec;		/* Number of returned bytes */
	    unsigned char *bytev; /* Array of returned bytes */


	    bytev = Tcl_GetByteArrayFromObj(resObj, &bytec);

	    paramPtr->transform.size = bytec;

	    if (bytec > 0) {
		paramPtr->transform.buf = ckalloc (bytec);
		memcpy(paramPtr->transform.buf, bytev, (size_t)bytec);
	    } else {
		paramPtr->transform.buf = NULL;
	    }
	}
	break;
    }

    case ForwardedOutput: {
	Tcl_Obj *bufObj = Tcl_NewByteArrayObj((unsigned char *) paramPtr->transform.buf,
					      paramPtr->transform.size);

	if (InvokeTclMethod(rtPtr, "write", bufObj, NULL, &resObj) != TCL_OK) {
	    ForwardSetObjError(paramPtr, resObj);
	    paramPtr->transform.size = -1;
	} else {
	    /*
	     * Process a regular return. Contains the transformation result.
	     * Sent it back to the request originator.
	     */

	    int bytec;		/* Number of returned bytes */
	    unsigned char *bytev; /* Array of returned bytes */


	    bytev = Tcl_GetByteArrayFromObj(resObj, &bytec);

	    paramPtr->transform.size = bytec;

	    if (bytec > 0) {
		paramPtr->transform.buf = ckalloc (bytec);
		memcpy(paramPtr->transform.buf, bytev, (size_t)bytec);
	    } else {
		paramPtr->transform.buf = NULL;
	    }
	}
	break;
    }

	    unsigned char *bytev; /* Array of returned bytes */

	    bytev = Tcl_GetByteArrayFromObj(resObj, &bytec);

	    paramPtr->transform.size = bytec;

	    if (bytec > 0) {
		paramPtr->transform.buf = ckalloc (bytec);
		memcpy(paramPtr->transform.buf, bytev, (size_t)bytec);
	    } else {
		paramPtr->transform.buf = NULL;
	    }
	}
	break;
    }

    case ForwardedFlush: {
	if (InvokeTclMethod(rtPtr, "flush", NULL, NULL, &resObj) != TCL_OK) {
	    ForwardSetObjError(paramPtr, resObj);
	    paramPtr->transform.size = -1;
	} else {
	    /*
	     * Process a regular return. Contains the transformation result.
	     * Sent it back to the request originator.
	     */

	    int bytec;		/* Number of returned bytes */
	    unsigned char *bytev; /* Array of returned bytes */


	    bytev = Tcl_GetByteArrayFromObj(resObj, &bytec);

	    paramPtr->transform.size = bytec;

	    if (bytec > 0) {
		paramPtr->transform.buf = ckalloc (bytec);
		memcpy(paramPtr->transform.buf, bytev, (size_t)bytec);
	    } else {
		paramPtr->transform.buf = NULL;
	    }
	}
	break;
    }

    case ForwardedClear: {
	(void) InvokeTclMethod(rtPtr, "clear", NULL, NULL, NULL);
	break;
    }

    case ForwardedLimit: {
	Tcl_Obj* resObj;

	if (InvokeTclMethod(rtPtr, "limit?", NULL, NULL, &resObj) != TCL_OK) {
	    ForwardSetObjError(paramPtr, resObj);
	    paramPtr->limit.max = -1;
	} else if (Tcl_GetIntFromObj(interp, resObj, &paramPtr->limit.max) != TCL_OK) {

	    ForwardSetObjError(paramPtr, MarshallError(interp));
	    paramPtr->limit.max = -1;
	}

	Tcl_DecrRefCount(resObj);
	break;
    }

    return 1;
}

static void
SrcExitProc(
    ClientData clientData)
{
    ForwardingEvent *evPtr = (ForwardingEvent *) clientData;
    ForwardingResult *resultPtr;
    ForwardParam *paramPtr;

    /*
     * NOTE (2): Can this handler be called with the originator blocked?
     */

    memcpy(paramPtr->base.msgStr, msgStr, (unsigned) len);
}
#endif

/*
 *----------------------------------------------------------------------
 *
 *	TimerKill --
 *
 *	Timer management. Removes the internal timer
 *	if it exists.
 *
 *	Sideeffects:
 *		See above.
 *
 *	Result:
 *		None.
 *
 *----------------------------------------------------------------------
 */

static void

TimerKill (ReflectedTransform* rtPtr)
{
    if (rtPtr->timer == (Tcl_TimerToken) NULL) return;




    /* Delete an existing flush-out timer, prevent it from firing on a
     * removed/dead channel.
     */

    Tcl_DeleteTimerHandler (rtPtr->timer);
    rtPtr->timer = (Tcl_TimerToken) NULL;
}

/*
 *----------------------------------------------------------------------
 *
 *	TimerSetup --
 *
 *	Timer management. Creates the internal timer
 *	if it does not exist.
 *
 *	Sideeffects:
 *		See above.
 *
 *	Result:
 *		None.
 *
 *----------------------------------------------------------------------
 */

static void
TimerSetup (ReflectedTransform* rtPtr)

{
    if (rtPtr->timer != (Tcl_TimerToken) NULL) return;



    rtPtr->timer = Tcl_CreateTimerHandler (FLUSH_DELAY, TimerRun,
					   (ClientData) rtPtr);
}

/*
 *----------------------------------------------------------------------
 *
 *	TimerRun --
 *
 *	Called by the notifier (-> timer) to flush out
 *	information waiting in channel buffers.
 *
 *	Sideeffects:
 *		As of 'Tcl_NotifyChannel'.
 *
 *	Result:
 *		None.
 *
 *----------------------------------------------------------------------
 */

static void

TimerRun (ClientData clientData)
{
    ReflectedTransform* rtPtr = (ReflectedTransform*) clientData;

    rtPtr->timer = (Tcl_TimerToken) NULL;
    Tcl_NotifyChannel (rtPtr->chan, TCL_READABLE);
}


/*
 *----------------------------------------------------------------------
 *
 *	ResultInit --
 *
 *	Initializes the specified buffer structure. The
 *	structure will contain valid information for an
 *	emtpy buffer.
 *
 *	Sideeffects:
 *		See above.
 *
 *	Result:
 *		None.
 *
 *----------------------------------------------------------------------
 */

static void

ResultInit (ResultBuffer* r) /* Reference to the structure to initialize */

{
    r->used      = 0;
    r->allocated = 0;
    r->buf       = NULL;
}
/*
 *----------------------------------------------------------------------
 *
 *	ResultClear --
 *
 *	Deallocates any memory allocated by 'ResultAdd'.
 *
 *	Sideeffects:
 *		See above.
 *
 *	Result:
 *		None.
 *
 *----------------------------------------------------------------------
 */

static void

ResultClear (ResultBuffer* r) /* Reference to the buffer to clear out */
{
    r->used = 0;

    if (!r->allocated) return;


    Tcl_Free ((char*) r->buf);

    r->buf       = NULL;
    r->allocated = 0;
}

/*
 *----------------------------------------------------------------------
 *
 *	ResultAdd --
 *
 *	Adds the bytes in the specified array to the
 *	buffer, by appending it.
 *
 *	Sideeffects:
 *		See above.
 *
 *	Result:
 *		None.
 *
 *----------------------------------------------------------------------
 */

static void
ResultAdd (r, buf, toWrite)
     ResultBuffer*  r;       /* The buffer to extend */
     unsigned char* buf;     /* The buffer to read from */
     int            toWrite; /* The number of bytes in 'buf' */
{
    if ((r->used + toWrite + 1) > r->allocated) {

	/* Extension of the internal buffer is required.
	 * NOTE: Currently linear. Should be doubling to amortize.
	 */

	if (r->allocated == 0) {
	    r->allocated = toWrite + RB_INCREMENT;
	    r->buf       = UCHARP(Tcl_Alloc (r->allocated));
	} else {
	    r->allocated += toWrite + RB_INCREMENT;
	    r->buf        = UCHARP(Tcl_Realloc((char*) r->buf, r->allocated));

	}
    }


    /* now copy data */


    memcpy (r->buf + r->used, buf, toWrite);
    r->used += toWrite;
}

/*
 *----------------------------------------------------------------------
 *
 *	ResultCopy --
 *
 *	Copies the requested number of bytes from the
 *	buffer into the specified array and removes them
 *	from the buffer afterward. Copies less if there
 *	is not enough data in the buffer.
 *
 *	Sideeffects:
 *		See above.
 *
 *	Result:
 *		The number of actually copied bytes,
 *		possibly less than 'toRead'.
 *
 *----------------------------------------------------------------------
 */

static int

ResultCopy (ResultBuffer*  r,      /* The buffer to read from */
	    unsigned char* buf,    /* The buffer to copy into */
	    int            toRead) /* Number of requested bytes */
{
    int copied;

    if (r->used == 0) {

	/* Nothing to copy in the case of an empty buffer.
	 */

	copied = 0;
	goto done;
    }

    if (r->used == toRead) {

	/* We have just enough. Copy everything to the caller.
	 */

	memcpy ((VOID*) buf, (VOID*) r->buf, toRead);
	r->used = 0;
	copied  = toRead;
	goto done;
    }

    if (r->used > toRead) {

	/* The internal buffer contains more than requested.
	 * Copy the requested subset to the caller, and shift
	 * the remaining bytes down.
	 */

	memcpy  ((VOID*) buf,    (VOID*) r->buf,            toRead);
	memmove ((VOID*) r->buf, (VOID*) (r->buf + toRead), r->used - toRead);

	r->used -= toRead;
	copied   = toRead;
	goto done;
    }

    /* There is not enough in the buffer to satisfy the caller, so
     * take everything.
     */

    memcpy ((VOID*) buf, (VOID*) r->buf, r->used);
    toRead  = r->used;
    r->used = 0;
    copied  = toRead;


    /* -- common postwork code ------- */

 done:
    return copied;
}


static int
TransformRead (
       ReflectedTransform* rtPtr,
       int* errorCodePtr,
       unsigned char* buf,
       int toRead)
{
    Tcl_Obj* bufObj;
    Tcl_Obj* resObj;
    int bytec;			/* Number of returned bytes */
    unsigned char *bytev;	/* Array of returned bytes */

    /*
     * Are we in the correct thread?
     */

#ifdef TCL_THREADS
    if (rtPtr->thread != Tcl_GetCurrentThread()) {
	ForwardParam p;

	p.transform.buf  = (char*) buf;
	p.transform.size = toRead;

	ForwardOpToOwnerThread(rtPtr, ForwardedInput, &p);

	if (p.base.code != TCL_OK) {
	    PassReceivedError(rtPtr->chan, &p);
	    *errorCodePtr = EINVAL;
	    return 0;
	} else {
	    *errorCodePtr = EOK;
	}


	ResultAdd (&rtPtr->result, UCHARP(p.transform.buf), p.transform.size);
	ckfree (p.transform.buf);
    } else {

#endif

	/* ASSERT: rtPtr->method & FLAG(METH_READ) */
	/* ASSERT: rtPtr->mode & TCL_READABLE */

	bufObj = Tcl_NewByteArrayObj((unsigned char *) buf, toRead);
	if (InvokeTclMethod(rtPtr, "read", bufObj, NULL, &resObj) != TCL_OK) {
	    Tcl_SetChannelError(rtPtr->chan, resObj);
	    Tcl_DecrRefCount(resObj);	/* Remove reference held from invoke */
	    *errorCodePtr = EINVAL;
	    return 0;
	}

	bytev = Tcl_GetByteArrayFromObj(resObj, &bytec);
	ResultAdd (&rtPtr->result, bytev, bytec);
	Tcl_DecrRefCount(resObj);	/* Remove reference held from invoke */
#ifdef TCL_THREADS
    }
#endif

    return 1;
}

static int
TransformWrite (
	ReflectedTransform* rtPtr,
	int* errorCodePtr,
	unsigned char* buf,
	int toWrite)
{
    Tcl_Obj *bufObj;
    Tcl_Obj *resObj;
    int bytec;			/* Number of returned bytes */
    unsigned char *bytev;	/* Array of returned bytes */
    int res;

    /*
     * Are we in the correct thread?
     */

#ifdef TCL_THREADS
    if (rtPtr->thread != Tcl_GetCurrentThread()) {
	ForwardParam p;

	p.transform.buf  = (char*) buf;
	p.transform.size = toWrite;

	ForwardOpToOwnerThread(rtPtr, ForwardedOutput, &p);

	if (p.base.code != TCL_OK) {
	    PassReceivedError(rtPtr->chan, &p);
	    *errorCodePtr = EINVAL;
	    return 0;
	} else {
	    *errorCodePtr = EOK;
	}


	res = Tcl_WriteRaw (rtPtr->parent,
			    (char*) p.transform.buf, p.transform.size);
	ckfree (p.transform.buf);
    } else {
#endif

	/* ASSERT: rtPtr->method & FLAG(METH_WRITE) */
	/* ASSERT: rtPtr->mode & TCL_WRITABLE */

	bufObj = Tcl_NewByteArrayObj((unsigned char *) buf, toWrite);
	if (InvokeTclMethod(rtPtr, "write", bufObj, NULL, &resObj) != TCL_OK) {
	    *errorCodePtr = EINVAL;
	    Tcl_SetChannelError(rtPtr->chan, resObj);
	    Tcl_DecrRefCount(resObj);	/* Remove reference held from invoke */
	    return 0;
	}

	*errorCodePtr = EOK;

	bytev = Tcl_GetByteArrayFromObj(resObj, &bytec);
	res   = Tcl_WriteRaw (rtPtr->parent,  (char*) bytev, bytec);
	Tcl_DecrRefCount(resObj);		/* Remove reference held from invoke */
#ifdef TCL_THREADS
    }
#endif

    if (res < 0) {
	*errorCodePtr = EINVAL;
	return 0;
    }

    return 1;
}



static int
TransformDrain(
      ReflectedTransform* rtPtr,
      int* errorCodePtr)
{
    Tcl_Obj* resObj;
    int bytec;			/* Number of returned bytes */
    unsigned char *bytev;	/* Array of returned bytes */

    /*
     * Are we in the correct thread?
     */

#ifdef TCL_THREADS
    if (rtPtr->thread != Tcl_GetCurrentThread()) {
	ForwardParam p;

	ForwardOpToOwnerThread(rtPtr, ForwardedDrain, &p);

	if (p.base.code != TCL_OK) {
	    PassReceivedError(rtPtr->chan, &p);
	    *errorCodePtr = EINVAL;
	    return 0;
	} else {
	    *errorCodePtr = EOK;
	}


	ResultAdd (&rtPtr->result, UCHARP(p.transform.buf), p.transform.size);
	ckfree (p.transform.buf);
    } else {
#endif

	if (InvokeTclMethod(rtPtr, "drain", NULL, NULL, &resObj)!=TCL_OK) {
	    Tcl_SetChannelError(rtPtr->chan, resObj);
	    Tcl_DecrRefCount(resObj);	/* Remove reference held from invoke */
	    *errorCodePtr = EINVAL;
	    return 0;
	}

	bytev = Tcl_GetByteArrayFromObj(resObj, &bytec);
	ResultAdd (&rtPtr->result, bytev, bytec);

	Tcl_DecrRefCount(resObj);	/* Remove reference held from invoke */

#ifdef TCL_THREADS
    }
#endif

    rtPtr->readIsDrained = 1;
    return 1;
}


static int
TransformFlush(
      ReflectedTransform* rtPtr,
      int* errorCodePtr,
      int  op)
{
    Tcl_Obj* resObj;
    int bytec;			/* Number of returned bytes */
    unsigned char *bytev;	/* Array of returned bytes */
    int res;

    /*
     * Are we in the correct thread?
     */

#ifdef TCL_THREADS
    if (rtPtr->thread != Tcl_GetCurrentThread()) {
	ForwardParam p;

	ForwardOpToOwnerThread(rtPtr, ForwardedFlush, &p);

	if (p.base.code != TCL_OK) {
	    PassReceivedError(rtPtr->chan, &p);
	    *errorCodePtr = EINVAL;
	    return 0;
	} else {
	    *errorCodePtr = EOK;
	}


	if (op == FLUSH_WRITE) {
	    res = Tcl_WriteRaw (rtPtr->parent,
				(char*) p.transform.buf, p.transform.size);
	} else {
	    res = 0;
	}
	ckfree(p.transform.buf);
    } else {
#endif

	if (InvokeTclMethod(rtPtr, "flush", NULL, NULL, &resObj)!=TCL_OK) {
	    Tcl_SetChannelError(rtPtr->chan, resObj);
	    Tcl_DecrRefCount(resObj);	/* Remove reference held from invoke */
	    *errorCodePtr = EINVAL;
	    return 0;
	}

	if (op == FLUSH_WRITE) {
	    bytev = Tcl_GetByteArrayFromObj(resObj, &bytec);
	    res   = Tcl_WriteRaw (rtPtr->parent,  (char*) bytev, bytec);
	} else {
	    res = 0;
	}
	Tcl_DecrRefCount(resObj);	/* Remove reference held from invoke */

#ifdef TCL_THREADS
    }
#endif
    if (res < 0) {
	*errorCodePtr = EINVAL;
	return 0;
    }

    return 1;
}

static void
TransformClear (
	ReflectedTransform* rtPtr)
{
    /*
     * Are we in the correct thread?
     */

#ifdef TCL_THREADS
    if (rtPtr->thread != Tcl_GetCurrentThread()) {
	ForwardParam p;

	ForwardOpToOwnerThread(rtPtr, ForwardedClear, &p);
	return;
    } else {
#endif
	/* ASSERT: rtPtr->method & FLAG(METH_READ) */
	/* ASSERT: rtPtr->mode & TCL_READABLE */

	(void) InvokeTclMethod(rtPtr, "clear", NULL, NULL, NULL);

#ifdef TCL_THREADS
    }
#endif






    rtPtr->readIsDrained = 0;
    ResultClear (&rtPtr->result);
}

static int
TransformLimit (
	ReflectedTransform* rtPtr,
	int* errorCodePtr,
	int* maxPtr)
{
    Tcl_Obj* resObj;
    Tcl_InterpState sr;		/* State of handler interp */

    /*
     * Are we in the correct thread?
     */

#ifdef TCL_THREADS
    if (rtPtr->thread != Tcl_GetCurrentThread()) {
	ForwardParam p;

	ForwardOpToOwnerThread(rtPtr, ForwardedLimit, &p);

	if (p.base.code != TCL_OK) {
	    PassReceivedError(rtPtr->chan, &p);
	    *errorCodePtr = EINVAL;
	    return 0;

	} else {
	    *errorCodePtr = EOK;
	    *maxPtr = p.limit.max;
	    return 1;
	}
    }
#endif

    /* ASSERT: rtPtr->method & FLAG(METH_WRITE) */
    /* ASSERT: rtPtr->mode & TCL_WRITABLE */

    if (InvokeTclMethod(rtPtr, "limit?", NULL, NULL, &resObj) != TCL_OK) {

static int
HaveVersion(
    const Tcl_ChannelType *chanTypePtr,
    Tcl_ChannelTypeVersion minimumVersion)
{
    Tcl_ChannelTypeVersion actualVersion = Tcl_ChannelVersion(chanTypePtr);

    return (PTR2INT(actualVersion)) >= (PTR2INT(minimumVersion));
}

/*
 * Local Variables:
 * mode: c
 * c-basic-offset: 4
 * fill-column: 78
 * End:
 */

 * Copyright (c) 2007 Daniel A. Steffen <das@users.sourceforge.net>
 * Copyright (c) 2006-2008 by Joe Mistachkin.  All rights reserved.
 * Copyright (c) 2008 by Miguel Sofer. All rights reserved.
 *
 * See the file "license.terms" for information on usage and redistribution of
 * this file, and for a DISCLAIMER OF ALL WARRANTIES.
 *
 * RCS: @(#) $Id: tclInt.h,v 1.127.2.94 2008/10/17 20:52:24 dgp Exp $
 */

#ifndef _TCLINT
#define _TCLINT

/*
 * Some numerics configuration options

/*
 * Structure used in implementation of those core ensembles which are
 * partially compiled.
 */

typedef struct {
    const char *name;		/* The name of the subcommand. */
    Tcl_ObjCmdProc *proc;	/* The implementation of the subcommand. */
    CompileProc *compileProc;	/* The compiler for the subcommand. */
    Tcl_ObjCmdProc *nreProc;	/* NRE implementation of this command */

} EnsembleImplMap;

/*
 *----------------------------------------------------------------
 * Data structures related to commands.
 *----------------------------------------------------------------
 */

 *
 * Copyright (c) 1993 The Regents of the University of California.
 * Copyright (c) 1994-1997 Sun Microsystems, Inc.
 *
 * See the file "license.terms" for information on usage and redistribution of
 * this file, and for a DISCLAIMER OF ALL WARRANTIES.
 *
 * RCS: @(#) $Id: tclLink.c,v 1.8.4.11 2008/05/11 04:22:47 dgp Exp $
 */

#include "tclInt.h"

/*
 * For each linked variable there is a data structure of the following type,
 * which describes the link and is the clientData for the trace set on the Tcl

	case TCL_LINK_FLOAT:
	    changed = (LinkedVar(float) != linkPtr->lastValue.f);
	    break;
	case TCL_LINK_STRING:
	    changed = 1;
	    break;
	default:
	    return "internal error: bad linked variable type";
	}
	if (changed) {
	    Tcl_ObjSetVar2(interp, linkPtr->varName, NULL, ObjValue(linkPtr),
		    TCL_GLOBAL_ONLY);
	}
	return NULL;
    }

    /*
     * For writes, first make sure that the variable is writable. Then convert
     * the Tcl value to C if possible. If the variable isn't writable or can't
     * be converted, then restore the varaible's old value and return an
     * error. Another tricky thing: we have to save and restore the interp's
     * result, since the variable access could occur when the result has been
     * partially set.
     */

    if (linkPtr->flags & LINK_READ_ONLY) {
	Tcl_ObjSetVar2(interp, linkPtr->varName, NULL, ObjValue(linkPtr),
		TCL_GLOBAL_ONLY);
	return "linked variable is read-only";
    }
    valueObj = Tcl_ObjGetVar2(interp, linkPtr->varName,NULL, TCL_GLOBAL_ONLY);
    if (valueObj == NULL) {
	/*
	 * This shouldn't ever happen.
	 */

	return "internal error: linked variable couldn't be read";
    }

    switch (linkPtr->type) {
    case TCL_LINK_INT:
	if (Tcl_GetIntFromObj(NULL, valueObj, &linkPtr->lastValue.i)
		!= TCL_OK) {
	    Tcl_ObjSetVar2(interp, linkPtr->varName, NULL, ObjValue(linkPtr),
		    TCL_GLOBAL_ONLY);
	    return "variable must have integer value";
	}
	LinkedVar(int) = linkPtr->lastValue.i;
	break;

    case TCL_LINK_WIDE_INT:
	if (Tcl_GetWideIntFromObj(NULL, valueObj, &linkPtr->lastValue.w)
		!= TCL_OK) {
	    Tcl_ObjSetVar2(interp, linkPtr->varName, NULL, ObjValue(linkPtr),
		    TCL_GLOBAL_ONLY);
	    return "variable must have integer value";
	}
	LinkedVar(Tcl_WideInt) = linkPtr->lastValue.w;
	break;

    case TCL_LINK_DOUBLE:
	if (Tcl_GetDoubleFromObj(NULL, valueObj, &linkPtr->lastValue.d)
		!= TCL_OK) {
#ifdef ACCEPT_NAN
	    if (valueObj->typePtr != &tclDoubleType) {
#endif
		Tcl_ObjSetVar2(interp, linkPtr->varName, NULL,
			ObjValue(linkPtr), TCL_GLOBAL_ONLY);
		return "variable must have real value";
#ifdef ACCEPT_NAN
	    }
	    linkPtr->lastValue.d = valueObj->internalRep.doubleValue;
#endif
	}
	LinkedVar(double) = linkPtr->lastValue.d;
	break;

    case TCL_LINK_BOOLEAN:
	if (Tcl_GetBooleanFromObj(NULL, valueObj, &linkPtr->lastValue.i)
		!= TCL_OK) {
	    Tcl_ObjSetVar2(interp, linkPtr->varName, NULL, ObjValue(linkPtr),
		    TCL_GLOBAL_ONLY);
	    return "variable must have boolean value";
	}
	LinkedVar(int) = linkPtr->lastValue.i;
	break;

    case TCL_LINK_CHAR:
	if (Tcl_GetIntFromObj(interp, valueObj, &valueInt) != TCL_OK
		|| valueInt < SCHAR_MIN || valueInt > SCHAR_MAX) {
	    Tcl_ObjSetVar2(interp, linkPtr->varName, NULL, ObjValue(linkPtr),
		    TCL_GLOBAL_ONLY);
	    return "variable must have char value";
	}
	linkPtr->lastValue.c = (char)valueInt;
	LinkedVar(char) = linkPtr->lastValue.c;
	break;

    case TCL_LINK_UCHAR:
	if (Tcl_GetIntFromObj(interp, valueObj, &valueInt) != TCL_OK
		|| valueInt < 0 || valueInt > UCHAR_MAX) {
	    Tcl_ObjSetVar2(interp, linkPtr->varName, NULL, ObjValue(linkPtr),
		    TCL_GLOBAL_ONLY);
	    return "variable must have unsigned char value";
	}
	linkPtr->lastValue.uc = (unsigned char) valueInt;
	LinkedVar(unsigned char) = linkPtr->lastValue.uc;
	break;

    case TCL_LINK_SHORT:
	if (Tcl_GetIntFromObj(interp, valueObj, &valueInt) != TCL_OK
		|| valueInt < SHRT_MIN || valueInt > SHRT_MAX) {
	    Tcl_ObjSetVar2(interp, linkPtr->varName, NULL, ObjValue(linkPtr),
		    TCL_GLOBAL_ONLY);
	    return "variable must have short value";
	}
	linkPtr->lastValue.s = (short)valueInt;
	LinkedVar(short) = linkPtr->lastValue.s;
	break;

    case TCL_LINK_USHORT:
	if (Tcl_GetIntFromObj(interp, valueObj, &valueInt) != TCL_OK
		|| valueInt < 0 || valueInt > USHRT_MAX) {
	    Tcl_ObjSetVar2(interp, linkPtr->varName, NULL, ObjValue(linkPtr),
		    TCL_GLOBAL_ONLY);
	    return "variable must have unsigned short value";
	}
	linkPtr->lastValue.us = (unsigned short)valueInt;
	LinkedVar(unsigned short) = linkPtr->lastValue.us;
	break;

    case TCL_LINK_UINT:
	if (Tcl_GetWideIntFromObj(interp, valueObj, &valueWide) != TCL_OK
		|| valueWide < 0 || valueWide > UINT_MAX) {
	    Tcl_ObjSetVar2(interp, linkPtr->varName, NULL, ObjValue(linkPtr),
		    TCL_GLOBAL_ONLY);
	    return "variable must have unsigned int value";
	}
	linkPtr->lastValue.ui = (unsigned int)valueWide;
	LinkedVar(unsigned int) = linkPtr->lastValue.ui;
	break;

    case TCL_LINK_LONG:
	if (Tcl_GetWideIntFromObj(interp, valueObj, &valueWide) != TCL_OK
		|| valueWide < LONG_MIN || valueWide > LONG_MAX) {
	    Tcl_ObjSetVar2(interp, linkPtr->varName, NULL, ObjValue(linkPtr),
		    TCL_GLOBAL_ONLY);
	    return "variable must have long value";
	}
	linkPtr->lastValue.l = (long)valueWide;
	LinkedVar(long) = linkPtr->lastValue.l;
	break;

    case TCL_LINK_ULONG:
	if (Tcl_GetWideIntFromObj(interp, valueObj, &valueWide) != TCL_OK
		|| valueWide < 0 || (Tcl_WideUInt) valueWide > ULONG_MAX) {
	    Tcl_ObjSetVar2(interp, linkPtr->varName, NULL, ObjValue(linkPtr),
		    TCL_GLOBAL_ONLY);
	    return "variable must have unsigned long value";
	}
	linkPtr->lastValue.ul = (unsigned long)valueWide;
	LinkedVar(unsigned long) = linkPtr->lastValue.ul;
	break;

    case TCL_LINK_WIDE_UINT:
	/*
	 * FIXME: represent as a bignum.
	 */
	if (Tcl_GetWideIntFromObj(interp, valueObj, &valueWide) != TCL_OK) {
	    Tcl_ObjSetVar2(interp, linkPtr->varName, NULL, ObjValue(linkPtr),
		    TCL_GLOBAL_ONLY);
	    return "variable must have unsigned wide int value";
	}
	linkPtr->lastValue.uw = (Tcl_WideUInt)valueWide;
	LinkedVar(Tcl_WideUInt) = linkPtr->lastValue.uw;
	break;

    case TCL_LINK_FLOAT:
	if (Tcl_GetDoubleFromObj(interp, valueObj, &valueDouble) != TCL_OK
		|| valueDouble < -FLT_MAX || valueDouble > FLT_MAX) {
	    Tcl_ObjSetVar2(interp, linkPtr->varName, NULL, ObjValue(linkPtr),
		    TCL_GLOBAL_ONLY);
	    return "variable must have float value";
	}
	linkPtr->lastValue.f = (float)valueDouble;
	LinkedVar(float) = linkPtr->lastValue.f;
	break;

    case TCL_LINK_STRING:
	value = Tcl_GetStringFromObj(valueObj, &valueLength);
	valueLength++;
	pp = (char **) linkPtr->addr;

	*pp = ckrealloc(*pp, valueLength);
	memcpy(*pp, value, (unsigned) valueLength);
	break;

    default:
	return "internal error: bad linked variable type";
    }
    return NULL;
}

/*
 *----------------------------------------------------------------------
 *

 *   Michael J. McLennan
 *   Bell Labs Innovations for Lucent Technologies
 *   mmclennan@lucent.com
 *
 * See the file "license.terms" for information on usage and redistribution of
 * this file, and for a DISCLAIMER OF ALL WARRANTIES.
 *
 * RCS: @(#) $Id: tclNamesp.c,v 1.31.4.55 2008/10/17 20:52:24 dgp Exp $
 */

#include "tclInt.h"

/*
 * Thread-local storage used to avoid having a global lock on data that is not
 * limited to a single interpreter.

    }

    /*
     * Free any client data associated with the namespace.
     */

    if (nsPtr->deleteProc != NULL) {
	(*nsPtr->deleteProc)(nsPtr->clientData);
    }
    nsPtr->deleteProc = NULL;
    nsPtr->clientData = NULL;

    /*
     * Reset the namespace's id field to ensure that this namespace won't be
     * interpreted as valid by, e.g., the cache validation code for cached

    }

    if (cxtNsPtr->cmdResProc != NULL || iPtr->resolverPtr != NULL) {
	ResolverScheme *resPtr = iPtr->resolverPtr;
	Tcl_Command cmd;

	if (cxtNsPtr->cmdResProc) {
	    result = (*cxtNsPtr->cmdResProc)(interp, name,
		    (Tcl_Namespace *) cxtNsPtr, flags, &cmd);
	} else {
	    result = TCL_CONTINUE;
	}

	while (result == TCL_CONTINUE && resPtr) {
	    if (resPtr->cmdResProc) {
		result = (*resPtr->cmdResProc)(interp, name,
			(Tcl_Namespace *) cxtNsPtr, flags, &cmd);
	    }
	    resPtr = resPtr->nextPtr;
	}

	if (result == TCL_OK) {
	    return cmd;

 *
 * TclMakeEnsemble --
 *
 *	Create an ensemble from a table of implementation commands. The
 *	ensemble will be subject to (limited) compilation if any of the
 *	implementation commands are compilable.
 *






 * Results:
 *	Handle for the ensemble, or NULL if creation of it fails.
 *
 * Side effects:
 *	May advance bytecode compilation epoch.
 *
 *----------------------------------------------------------------------
 */

Tcl_Command
TclMakeEnsemble(
    Tcl_Interp *interp,
    const char *name,
    const EnsembleImplMap map[])
{
    Tcl_Command ensemble;	/* The overall ensemble. */
    Tcl_Namespace *tclNsPtr;	/* Reference to the "::tcl" namespace. */
    Tcl_DString buf;







    tclNsPtr = Tcl_FindNamespace(interp, "::tcl", NULL,


	    TCL_CREATE_NS_IF_UNKNOWN);
    if (tclNsPtr == NULL) {

	Tcl_Panic("unable to find or create ::tcl namespace!");
    }
    Tcl_DStringInit(&buf);

    Tcl_DStringAppend(&buf, "::tcl::", -1);
    Tcl_DStringAppend(&buf, name, -1);


    tclNsPtr = Tcl_FindNamespace(interp, Tcl_DStringValue(&buf), NULL,
	    TCL_CREATE_NS_IF_UNKNOWN);
    if (tclNsPtr == NULL) {
	Tcl_Panic("unable to find or create %s namespace!",
		Tcl_DStringValue(&buf));
    }












    ensemble = Tcl_CreateEnsemble(interp, Tcl_DStringValue(&buf)+5, tclNsPtr,
	    TCL_ENSEMBLE_PREFIX);



    Tcl_DStringAppend(&buf, "::", -1);
    if (ensemble != NULL) {
	Tcl_Obj *mapDict;
	int i, compile = 0;


	TclNewObj(mapDict);
	for (i=0 ; map[i].name != NULL ; i++) {
	    Tcl_Obj *fromObj, *toObj;
	    register Command *cmdPtr;

	    fromObj = Tcl_NewStringObj(map[i].name, -1);
	    TclNewStringObj(toObj, Tcl_DStringValue(&buf),
		    Tcl_DStringLength(&buf));
	    Tcl_AppendToObj(toObj, map[i].name, -1);
	    Tcl_DictObjPut(NULL, mapDict, fromObj, toObj);

	    cmdPtr = (Command *) Tcl_CreateObjCommand(interp,
		    TclGetString(toObj), map[i].proc, NULL, NULL);

	    cmdPtr->compileProc = map[i].compileProc;
	    cmdPtr->nreProc = map[i].nreProc;
	    compile |= (map[i].compileProc != NULL);

	}

	Tcl_SetEnsembleMappingDict(interp, ensemble, mapDict);
	if (compile) {
	    Tcl_SetEnsembleFlags(interp, ensemble,
		    TCL_ENSEMBLE_PREFIX | ENSEMBLE_COMPILE);
	}
    }

    Tcl_DStringFree(&buf);

    return ensemble;
}

/*
 *----------------------------------------------------------------------
 *
 * NsEnsembleImplementationCmd --