2005-08-25  Donal K. Fellows  <donal.k.fellows@man.ac.uk>

	* generic/tclExecute.c (TEBC:INST_DICT_LAPPEND): Stop dropping a
	duplicated object on the floor, which was a memory leak (and a wrong
	result too). Thanks to Andreas Kupries for reporting this.

2005-08-25  Don Porter  <dgp@users.sourceforge.net>

	[kennykb-numerics-branch] Merge updates from HEAD

	* generic/tclExecute.c:	Bug fix.  INST_*SHIFT* opcodes stack
	management. [expr 0<<6] should be 0, not 6.

	* generic/tclBasic.c:	Extended the domain of round(.) to all
	non-Inf, non-NaN doubles, using bignums for the result as needed.

2005-08-24  Andreas Kupries <andreask@activestate.com>

	TIP#219 IMPLEMENTATION

	* doc/SetChanErr.3: ** New File **. Documentation of the new
	  channel API functions.
	* generic/tcl.decls:  Stub declarations of the new channel API.
	* generic/tclDecls.h: Regenerated
	* generic/tclStubInit.c:

	* tclIORChan.c: ** New File **. Implementation of the reflected
	  channel.
	* generic/tclInt.h: Integration of reflected channel and new error
	* generic/tclIO.c:  propagation into the generic I/O core.
	* generic/tclIOCmd.c:
	* generic/tclIO.h:
	* library/init.tcl:

	* tests/io.test:    Extended testsuite.
	* tests/ioCmd.test:
	* tests/chan.test:
	* generic/tclTest.c:
	* generic/tclThreadTest.c:

	* unix/Makefile.in: Integration into the build machinery.
	* win/Makefile.in:
	* win/Makefile.vc:

2005-08-24  Kevin Kenny  <kennykb@acm.org>

	* generic/tclStrToD.c (Tcl_DoubleDigits): Fixed the corner cases of
	* tests/binary.test (binary-65.*)         formatting floating
	point numbers with the largest and smallest possible significands,
	and added test cases for them.

2005-08-24  Kevin Kenny  <kennykb@users.sourceforge.net>

	[kennykb-numerics-branch]

	* generic/tclExecute.c: Corrected some TRACE bugs that prevented
	compilation with --enable-symbols=all.

	* generic/tclExecute.c:	Bug fix: TclBignumToDouble return -Inf when
	appropriate.  Removed declarations of removed routines.

	* generic/tclExecute.c:	Revised the type promotion rules of the
	comparison operators so that they form proper equivalence classes
	over the set of numeric strings.

2005-08-23  Mo DeJong  <mdejong@users.sourceforge.net>

	* unix/configure.in:
	* win/configure: Regen.
	* win/configure.in: Update minimum autoconf version
	to 2.59.

2005-08-23  Kevin Kenny  <kennykb@users.sourceforge.net>

	[kennykb-numerics-branch]
	
	* generic/tclCmdMZ.c (Tcl_StringObjCmd):
	* generic/tclInt.h:

	* generic/tclInt.h:	New internal macros TclIsNaN and TclIsInfinite
	* generic/tclBasic.c:	replace the IS_NAN and IS_INF macros scattered
	* generic/tclExecute.c:	here and there.
	* generic/tclObj.c:
	* generic/tclStrToD.c:
	* generic/tclUtil.c:

2005-08-22  Daniel Steffen  <das@users.sourceforge.net>

	* unix/tclConfig.h.in: autoheader-2.59.

2005-08-22  Don Porter  <dgp@users.sourceforge.net>

	[kennykb-numerics-branch]

	* generic/tclInt.h:	New ACCEPT_NAN macro to mark code that supports
	* generic/tclCmdAH.c:	or disables accepting of the NaN value at 

	* generic/tclExecute.c:		Fixed string rep invalidation bug in
	* tests/dict.test (dict-11.17):	INST_DICT_INCR_IMM rewrite.

	* generic/tclDictObj.c:	DictIncrCmd rewrite to use TclIncrObj.

	* generic/tclInt.h:	TclIncrObj static -> internal
	* generic/tclExecute.c:

2005-08-17  George Peter Staplin <GeorgePS@XMission.com>

	* generic/tclBasic.c: eliminate a namespace clash caused by
	BuiltinFuncTable not being static.

	* generic/tclObj.c: fix a namespace clash caused by a missing
	static for pendingObjData.

2005-08-17  Kevin Kenny  <kennykb@acm.org>

	* generic/tclEvent.c (Tcl_Finalize): Removed a copy-and-paste
	accident that caused a (mostly harmless) double finalize of the
	load and filesystem subsystems.
	* tests/clock.test: Eliminated the bad test clock-43.1, and split
	clock-50.1 into two tests, with a more permissive check on the
	error message for an out-of-range value.

2005-08-17  Kevin Kenny  <kennykb@users.sourceforge.net>

	[kennykb-numerics-branch]

	* generic/tclBasic.c (Tcl_Expr{Long,Double}{,Obj}): Updated to
	* generic/tclTest.c:                                deal with

	(Note that we'll still see aborts if an unloaded DLL has TSD -
	that still needs to be fixed.

	* tests/compExpr-old.test (compExpr-3.8): Made tests conditional on
	* tests/expr.test (expr-3.8):             'unix' because they get
	                                          stack overflows on Win32
	                                          threaded builds,

2005-08-09  Vince Darley  <vincentdarley@users.sourceforge.net>

	* generic/tclPathObj.c: fix to [file rootname] bug in optimized
	code path reported on comp.lang.tcl.

2005-08-08  Don Porter  <dgp@users.sourceforge.net>

'\"
'\" Copyright (c) 2005 Andreas Kupries <andreas_kupries@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: SetChanErr.3,v 1.1.2.2 2005/08/25 15:46:30 dgp Exp $
.so man.macros
.TH Tcl_SetChannelError 3 8.5 Tcl "Tcl Library Procedures"
.BS
'\" Note:  do not modify the .SH NAME line immediately below!
.SH NAME
Tcl_SetChannelError, Tcl_SetChannelErrorInterp, Tcl_GetChannelError, Tcl_GetChannelErrorInterp \- functions to create/intercept Tcl errors by channel drivers.
.SH SYNOPSIS
.nf
\fB#include <tcl.h>\fR
.sp
void
\fBTcl_SetChannelError\fR(\fIchan, msg\fR)
.sp
void
\fBTcl_SetChannelErrorInterp\fR(\fIinterp, msg\fR)
.sp
void
\fBTcl_GetChannelError\fR(\fIchan, msgPtr\fR)
.sp
void
\fBTcl_GetChannelErrorInterp\fR(\fIinterp, msgPtr\fR)
.sp
.SH ARGUMENTS
.AS Tcl_Channel chan
.AP Tcl_Channel chan in
Refers to the Tcl channel whose bypass area is accessed.
.AP Tcl_Interp* interp in
Refers to the Tcl interpreter whose bypass area is accessed.
.AP Tcl_Obj* msg in
Error message put into a bypass area.  A list of return options and
values, followed by a string message.  Both message and the
option/value information are optional.
.AP Tcl_Obj** msgPtr out
Reference to a place where the message stored in the accessed bypass
area can be stored in.
.BE
.SH DESCRIPTION
.PP
The current definition of a Tcl channel driver does not permit the
direct return of arbitrary error messages, except for the setting and
retrieval of channel options. All other functions are restricted to
POSIX error codes.
.PP
The functions described here overcome this limitation. Channel drivers
are allowed to use \fBTcl_SetChannelError\fR and
\fBTcl_SetChannelErrorInterp\fR to place arbitrary error messages in
\fBbypass areas\fI defined for channels and interpreters. And the
generic I/O layer uses \fBTcl_GetChannelError\fR and
\fBTcl_GetChannelErrorInterp\fR to look for messages in the bypass
areas and arrange for their return as errors. The posix error codes
set by a driver are used now if and only if no messages are present.
.PP
\fBTcl_SetChannelError\fR stores error information in the bypass area
of the specified channel. The number of references to the \fBmsg\fI
object goes up by one. Previously stored information will be
discarded, by releasing the reference held by the channel. The channel
reference must not be NULL.
.PP
\fBTcl_SetChannelErrorInterp\fR stores error information in the bypass
area of the specified interpreter. The number of references to the
\fBmsg\fI object goes up by one. Previously stored information will be
discarded, by releasing the reference held by the interpreter. The
interpreter reference must not be NULL.
.PP
\fBTcl_GetChannelError\fR places either the error message held in the
bypass area of the specified channel into \fImsgPtr\fR, or NULL; and
resets the bypass. I.e. after an invokation all following invokations
will return NULL, until an intervening invokation of
\fBTcl_SetChannelError\fR with a non-NULL message. The \fImsgPtr\fR
must not be NULL. The reference count of the message is not touched.
The reference previously held by the channel is now held by the caller
of the function and it is its responsibility to release that reference
when it is done with the object.
.PP
\fBTcl_GetChannelErrorInterp\fR places either the error message held
in the bypass area of the specified interpreter into \fImsgPtr\fR, or
NULL; and resets the bypass. I.e. after an invokation all following
invokations will return NULL, until an intervening invokation of
\fBTcl_SetChannelErrorInterp\fR with a non-NULL message. The
\fImsgPtr\fR must not be NULL. The reference count of the message is
not touched.  The reference previously held by the interpreter is now
held by the caller of the function and it is its responsibility to
release that reference when it is done with the object.
.PP
Which functions of a channel driver are allowed to use which bypass
function is listed below, as is which functions of the public channel
API may leave a messages in the bypass areas.
.PP
.IP \fBTcl_DriverCloseProc\fR
May use \fBTcl_SetChannelErrorInterp\fR, and only this function.
.IP \fBTcl_DriverInputProc\fR
May use \fBTcl_SetChannelError\fR, and only this function.
.IP \fBTcl_DriverOutputProc\fR
May use \fBTcl_SetChannelError\fR, and only this function.
.IP \fBTcl_DriverSeekProc\fR
May use \fBTcl_SetChannelError\fR, and only this function.
.IP \fBTcl_DriverWideSeekProc
May use \fBTcl_SetChannelError\fR, and only this function.
.IP \fBTcl_DriverSetOptionProc\fR
Has already the ability to pass arbitrary error messages. Must
\fBnot\fR use any of the new functions.
.IP \fBTcl_DriverGetOptionProc\fR
Has already the ability to pass arbitrary error messages. Must
\fBnot\fR use any of the new functions.
.IP \fBTcl_DriverWatchProc\fR
Must \fBnot\fR use any of the new functions. Is internally called and
has no ability to return any type of error whatsoever.
.IP \fBTcl_DriverBlockModeProc\fR
May use \fBTcl_SetChannelError\fR, and only this function.
.IP \fBTcl_DriverGetHandleProc\fR
Must \fBnot\fR use any of the new functions. It is only a low-level
function, and not used by Tcl commands.
.IP \fBTcl_DriverHandlerProc\fR
Must \fBnot\fR use any of the new functions. Is internally called and
has no ability to return any type of error whatsoever.
.PP
Given the information above the following public functions of the Tcl
C API are affected by these changes. I.e. when these functions are
called the channel may now contain a stored arbitrary error message
requiring processing by the caller.
.PP
.IP \fBTcl_StackChannel\fR
.IP \fBTcl_Seek\fR
.IP \fBTcl_Tell\fR
.IP \fBTcl_ReadRaw\fR
.IP \fBTcl_Read\fR
.IP \fBTcl_ReadChars\fR
.IP \fBTcl_Gets\fR
.IP \fBTcl_GetsObj\fR
.IP \fBTcl_Flush\fR
.IP \fBTcl_WriteRaw\fR
.IP \fBTcl_WriteObj\fR
.IP \fBTcl_Write\fR
.IP \fBTcl_WriteChars\fR
.PP
All other API functions are unchanged. Especially the functions below
leave all their error information in the interpreter result.
.PP
.IP \fBTcl_Close\fR
.IP \fBTcl_UnregisterChannel\fR
.IP \fBTcl_UnstackChannel\fR
.PP

.SH "SEE ALSO"
Tcl_Close(3), Tcl_OpenFileChannel(3), Tcl_SetErrno(3)

.SH KEYWORDS
channel driver, error messages, channel type

# tcl.decls --
#
#	This file contains the declarations for all supported public
#	functions that are exported by the Tcl library via the stubs table.
#	This file is used to generate the tclDecls.h, tclPlatDecls.h,
#	tclStub.c, and tclPlatStub.c files.
#	
#
# Copyright (c) 1998-1999 by Scriptics Corporation.
# Copyright (c) 2001, 2002 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: tcl.decls,v 1.105.2.8 2005/08/25 15:46:30 dgp Exp $

library tcl

# Define the tcl interface with several sub interfaces:
#     tclPlat	 - platform specific public
#     tclInt	 - generic private
#     tclPlatInt - platform specific private

declare 559 generic {
    int Tcl_TruncateChannel(Tcl_Channel chan, Tcl_WideInt length)
}
declare 560 generic {
    Tcl_DriverTruncateProc *Tcl_ChannelTruncateProc(
	    Tcl_ChannelType *chanTypePtr)
}

# TIP#219 (Tcl Channel Reflection API) akupries

declare 561 generic {
    void Tcl_SetChannelErrorInterp (Tcl_Interp* interp, Tcl_Obj* msg)
}
declare 562 generic {
    void Tcl_GetChannelErrorInterp (Tcl_Interp* interp, Tcl_Obj** msg)
}
declare 563 generic {
    void Tcl_SetChannelError (Tcl_Channel chan, Tcl_Obj* msg)
}
declare 564 generic {
    void Tcl_GetChannelError (Tcl_Channel chan, Tcl_Obj** msg)
}

##############################################################################

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

interface tclPlat

 * Copyright (c) 1994-1997 Sun Microsystems, Inc.
 * Copyright (c) 1998-1999 by Scriptics Corporation.
 * Copyright (c) 2001, 2002 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: tclBasic.c,v 1.136.2.29 2005/08/25 15:46:30 dgp Exp $
 */

#include "tclInt.h"
#include "tclCompile.h"
#include <float.h>
#include <math.h>
#include "tommath.h"

 */

typedef struct {
    CONST char* name;		/* Name of the function */
    Tcl_ObjCmdProc* objCmdProc;	/* Procedure that evaluates the function */
    ClientData clientData;	/* Client data for the procedure */
} BuiltinFuncDef;
static BuiltinFuncDef BuiltinFuncTable[] = {
    { "::tcl::mathfunc::abs",	ExprAbsFunc,	NULL 			},
    { "::tcl::mathfunc::acos",	ExprUnaryFunc,	(ClientData) acos 	},
    { "::tcl::mathfunc::asin",	ExprUnaryFunc,	(ClientData) asin 	},
    { "::tcl::mathfunc::atan",	ExprUnaryFunc,	(ClientData) atan 	},
    { "::tcl::mathfunc::atan2",	ExprBinaryFunc,	(ClientData) atan2 	},
    { "::tcl::mathfunc::bool",	ExprBoolFunc,	NULL			},
    { "::tcl::mathfunc::ceil",	ExprCeilFunc,	NULL		 	},

     * TclCreateExecEnv after initializing namespaces since it tries to
     * reference a Tcl variable (it links to the Tcl "tcl_traceExec"
     * variable).
     */

    iPtr->execEnvPtr = TclCreateExecEnv(interp);

    /* TIP #219, Tcl Channel Reflection API */
    iPtr->chanMsg  = NULL;

    /*
     * Initialize the compilation and execution statistics kept for this
     * interpreter.
     */

#ifdef TCL_COMPILE_STATS
    statsPtr = &(iPtr->stats);

	    (Tcl_CmdDeleteProc*) NULL);
    Tcl_CreateObjCommand(interp,	"::tcl::clock::Mktime",
	    TclClockMktimeObjCmd,	(ClientData) NULL,
	    (Tcl_CmdDeleteProc*) NULL);
    Tcl_CreateObjCommand(interp,	"::tcl::clock::Oldscan",
	    TclClockOldscanObjCmd,	(ClientData) NULL,
	    (Tcl_CmdDeleteProc*) NULL);
    /* TIP #208 */
    Tcl_CreateObjCommand(interp, "::tcl::chan::Truncate",
	    TclChanTruncateObjCmd, (ClientData) NULL,
	    (Tcl_CmdDeleteProc*) NULL);
    /* TIP #219 */
    Tcl_CreateObjCommand(interp, "::tcl::chan::rCreate",
	    TclChanCreateObjCmd, (ClientData) NULL,
	    (Tcl_CmdDeleteProc*) NULL);

    Tcl_CreateObjCommand(interp, "::tcl::chan::rPostevent",
	    TclChanPostEventObjCmd, (ClientData) NULL,
	    (Tcl_CmdDeleteProc*) NULL);

    /*
     * Register the built-in functions
     */


    /* Register the default [interp bgerror] handler. */

    /*
     * Mark the interpreter as deleted. No further evals will be allowed.
     * Increase the compileEpoch as a signal to compiled bytecodes.
     */

    iPtr->flags |= DELETED;
    iPtr->compileEpoch++;

    /* TIP #219, Tcl Channel Reflection API.
     * Discard a leftover state.
     */

    if (iPtr->chanMsg != NULL) {
        Tcl_DecrRefCount (iPtr->chanMsg);
	iPtr->chanMsg = NULL;
    }

    /*
     * Ensure that the interpreter is eventually deleted.
     */

    Tcl_EventuallyFree((ClientData) interp, (Tcl_FreeProc *) DeleteInterpProc);
}

/*
 * tclDecls.h --
 *
 *	Declarations of functions in the platform independent public Tcl API.
 *
 * 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: tclDecls.h,v 1.107.2.7 2005/08/25 15:46:30 dgp Exp $
 */

#ifndef _TCLDECLS
#define _TCLDECLS

#undef TCL_STORAGE_CLASS
#ifdef BUILD_tcl

#endif
#ifndef Tcl_ChannelTruncateProc_TCL_DECLARED
#define Tcl_ChannelTruncateProc_TCL_DECLARED
/* 560 */
EXTERN Tcl_DriverTruncateProc * Tcl_ChannelTruncateProc _ANSI_ARGS_((
				Tcl_ChannelType * chanTypePtr));
#endif
#ifndef Tcl_SetChannelErrorInterp_TCL_DECLARED
#define Tcl_SetChannelErrorInterp_TCL_DECLARED
/* 561 */
EXTERN void		Tcl_SetChannelErrorInterp _ANSI_ARGS_((
				Tcl_Interp* interp, Tcl_Obj* msg));
#endif
#ifndef Tcl_GetChannelErrorInterp_TCL_DECLARED
#define Tcl_GetChannelErrorInterp_TCL_DECLARED
/* 562 */
EXTERN void		Tcl_GetChannelErrorInterp _ANSI_ARGS_((
				Tcl_Interp* interp, Tcl_Obj** msg));
#endif
#ifndef Tcl_SetChannelError_TCL_DECLARED
#define Tcl_SetChannelError_TCL_DECLARED
/* 563 */
EXTERN void		Tcl_SetChannelError _ANSI_ARGS_((Tcl_Channel chan, 
				Tcl_Obj* msg));
#endif
#ifndef Tcl_GetChannelError_TCL_DECLARED
#define Tcl_GetChannelError_TCL_DECLARED
/* 564 */
EXTERN void		Tcl_GetChannelError _ANSI_ARGS_((Tcl_Channel chan, 
				Tcl_Obj** msg));
#endif

typedef struct TclStubHooks {
    struct TclPlatStubs *tclPlatStubs;
    struct TclIntStubs *tclIntStubs;
    struct TclIntPlatStubs *tclIntPlatStubs;
} TclStubHooks;

    Tcl_DriverThreadActionProc * (*tcl_ChannelThreadActionProc) _ANSI_ARGS_((Tcl_ChannelType * chanTypePtr)); /* 554 */
    Tcl_Obj* (*tcl_NewBignumObj) _ANSI_ARGS_((mp_int* value)); /* 555 */
    Tcl_Obj* (*tcl_DbNewBignumObj) _ANSI_ARGS_((mp_int* value, CONST char* file, int line)); /* 556 */
    void (*tcl_SetBignumObj) _ANSI_ARGS_((Tcl_Obj* obj, mp_int* value)); /* 557 */
    int (*tcl_GetBignumFromObj) _ANSI_ARGS_((Tcl_Interp* interp, Tcl_Obj* obj, mp_int* value)); /* 558 */
    int (*tcl_TruncateChannel) _ANSI_ARGS_((Tcl_Channel chan, Tcl_WideInt length)); /* 559 */
    Tcl_DriverTruncateProc * (*tcl_ChannelTruncateProc) _ANSI_ARGS_((Tcl_ChannelType * chanTypePtr)); /* 560 */
    void (*tcl_SetChannelErrorInterp) _ANSI_ARGS_((Tcl_Interp* interp, Tcl_Obj* msg)); /* 561 */
    void (*tcl_GetChannelErrorInterp) _ANSI_ARGS_((Tcl_Interp* interp, Tcl_Obj** msg)); /* 562 */
    void (*tcl_SetChannelError) _ANSI_ARGS_((Tcl_Channel chan, Tcl_Obj* msg)); /* 563 */
    void (*tcl_GetChannelError) _ANSI_ARGS_((Tcl_Channel chan, Tcl_Obj** msg)); /* 564 */
} TclStubs;

#ifdef __cplusplus
extern "C" {
#endif
extern TclStubs *tclStubsPtr;
#ifdef __cplusplus

#define Tcl_TruncateChannel \
	(tclStubsPtr->tcl_TruncateChannel) /* 559 */
#endif
#ifndef Tcl_ChannelTruncateProc
#define Tcl_ChannelTruncateProc \
	(tclStubsPtr->tcl_ChannelTruncateProc) /* 560 */
#endif
#ifndef Tcl_SetChannelErrorInterp
#define Tcl_SetChannelErrorInterp \
	(tclStubsPtr->tcl_SetChannelErrorInterp) /* 561 */
#endif
#ifndef Tcl_GetChannelErrorInterp
#define Tcl_GetChannelErrorInterp \
	(tclStubsPtr->tcl_GetChannelErrorInterp) /* 562 */
#endif
#ifndef Tcl_SetChannelError
#define Tcl_SetChannelError \
	(tclStubsPtr->tcl_SetChannelError) /* 563 */
#endif
#ifndef Tcl_GetChannelError
#define Tcl_GetChannelError \
	(tclStubsPtr->tcl_GetChannelError) /* 564 */
#endif

#endif /* defined(USE_TCL_STUBS) && !defined(USE_TCL_STUB_PROCS) */

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

#undef TCL_STORAGE_CLASS
#define TCL_STORAGE_CLASS DLLIMPORT

#endif /* _TCLDECLS */

 * 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.54.2.8 2005/08/25 15:46:30 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

	 */

	TclFinalizeSynchronization();

#if defined(TCL_THREADS) && defined(USE_THREAD_ALLOC)
	TclFinalizeThreadAlloc();
#endif


















	/*
	 * We defer unloading of packages until very late to avoid memory
	 * access issues.  Both exit callbacks and synchronization variables
	 * may be stored in packages.
	 * 
	 * Note that TclFinalizeLoad unloads packages in the reverse of the
	 * order they were loaded in (i.e. last to be loaded is the first to

 * Copyright (c) 2001 by Kevin B. Kenny.  All rights reserved.
 * Copyright (c) 2002-2005 by Miguel Sofer.
 * Copyright (c) 2005 by Donal K. Fellows.
 *
 * See the file "license.terms" for information on usage and redistribution of
 * this file, and for a DISCLAIMER OF ALL WARRANTIES.
 *
 * RCS: @(#) $Id: tclExecute.c,v 1.167.2.37 2005/08/25 15:46:30 dgp Exp $
 */

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

#include <math.h>

	    goto checkForCatch;
	}
	mp_clear(&big2);
	if (mp_iszero(&big1)) {
	    /* Zero shifted any integral number of bits either way is zero */
	    mp_clear(&big1);
	    TRACE(("0 %s => 0\n", O2S(value2Ptr)));
	    NEXT_INST_F(1, 1, 0);
	}
	result = Tcl_GetIntFromObj(NULL, value2Ptr, &shift);
	if (result != TCL_OK) {
	    Tcl_SetObjResult(interp, Tcl_NewStringObj(
		    "integer value too large to represent", -1));
	    goto checkForCatch;
	}

	case INST_DICT_LAPPEND:
	    /*
	     * More complex because list-append can fail.
	     */
	    if (valPtr == NULL) {
		valPtr = Tcl_NewListObj(1, tosPtr);
	    } else if (Tcl_IsShared(valPtr)) {
		valPtr = Tcl_DuplicateObj(valPtr);

		result = Tcl_ListObjAppendElement(interp, valPtr, *tosPtr);
		if (result != TCL_OK) {
		    Tcl_DecrRefCount(valPtr);
		    if (allocateDict) {
			Tcl_DecrRefCount(dictPtr);
		    }
		    goto checkForCatch;
		}
	    } else {
		result = Tcl_ListObjAppendElement(interp, valPtr, *tosPtr);

/*
 * 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.81.2.8 2005/08/25 15:46:31 dgp Exp $
 */

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

/*

			    char *dst, CONST char *src,
			    int *dstLenPtr, int *srcLenPtr));
static void		UpdateInterest _ANSI_ARGS_((Channel *chanPtr));
static int		WriteBytes _ANSI_ARGS_((Channel *chanPtr,
			    CONST char *src, int srcLen));
static int		WriteChars _ANSI_ARGS_((Channel *chanPtr,
			    CONST char *src, int srcLen));
static Tcl_Obj*         FixLevelCode _ANSI_ARGS_ ((Tcl_Obj* msg));

/*
 *---------------------------------------------------------------------------
 *
 * TclInitIOSubsystem --
 *
 *	Initialize all resources used by this subsystem on a per-process

	Tcl_Panic("Tcl_RegisterChannel: channel without name");
    }
    if (interp != (Tcl_Interp *) NULL) {
	hTblPtr = GetChannelTable(interp);
	hPtr = Tcl_CreateHashEntry(hTblPtr, statePtr->channelName, &new);
	if (new == 0) {
	    if (chan == (Tcl_Channel) Tcl_GetHashValue(hPtr)) {
	        return;
	    }

	    Tcl_Panic("Tcl_RegisterChannel: duplicate channel names");
	}
	Tcl_SetHashValue(hPtr, (ClientData) chanPtr);
    }
    statePtr->refCount++;

    statePtr->topChanPtr	= chanPtr;
    statePtr->bottomChanPtr	= chanPtr;
    chanPtr->downChanPtr	= (Channel *) NULL;
    chanPtr->upChanPtr		= (Channel *) NULL;
    chanPtr->inQueueHead	= (ChannelBuffer *) NULL;
    chanPtr->inQueueTail	= (ChannelBuffer *) NULL;

    /* TIP #219, Tcl Channel Reflection API */
    statePtr->chanMsg           = NULL;
    statePtr->unreportedMsg     = NULL;

    /*
     * Link the channel into the list of all channels; create an on-exit
     * handler if there is not one already, to close off all the channels in
     * the list on exit.
     *
     * JH: Could call Tcl_SpliceChannel, but need to avoid NULL check.
     *

 *	the reverse to 'Tcl_StackChannel'.
 *
 * Results:
 *	A standard Tcl result.
 *
 * Side effects:
 *	If TCL_ERROR is returned, the posix error code will be set with
 *	Tcl_SetErrno. May leave a message in interp result as well.
 *
 *----------------------------------------------------------------------
 */

int
Tcl_UnstackChannel(interp, chan)
    Tcl_Interp *interp; /* The interpreter we are working in */

	    CopyState *csPtr;

	    csPtr = statePtr->csPtr;
	    statePtr->csPtr = (CopyState *) NULL;

	    if (Tcl_Flush((Tcl_Channel) chanPtr) != TCL_OK) {
		statePtr->csPtr = csPtr;
		/* TIP #219, Tcl Channel Reflection API.
		 * Move error messages put by the driver into the chan/ip
		 * bypass area into the regular interpreter result. Fall back
		 * to the regular message if nothing was found in the
		 * bypasses.
		 */
		if (!TclChanCaughtErrorBypass (interp, chan)) {
		    Tcl_AppendResult(interp, "could not flush channel \"",
				     Tcl_GetChannelName((Tcl_Channel) chanPtr), "\"",
				     (char *) NULL);
		}
		return TCL_ERROR;
	    }

	    statePtr->csPtr = csPtr;
	}

	/*

	 */

	Tcl_EventuallyFree((ClientData) chanPtr, TCL_DYNAMIC);
	UpdateInterest(downChanPtr);

	if (result != 0) {
	    Tcl_SetErrno(result);
	    /* TIP #219, Tcl Channel Reflection API.
	     * Move error messages put by the driver into the chan/ip bypass
	     * area into the regular interpreter result.
	     */
	    TclChanCaughtErrorBypass (interp, chan);
	    return TCL_ERROR;
	}
    } else {
	/*
	 * This channel does not cover another one.  Simply do a close, if
	 * necessary.
	 */

	if (statePtr->refCount <= 0) {
	    if (Tcl_Close(interp, chan) != TCL_OK) {
		/* TIP #219, Tcl Channel Reflection API.
		 * "TclChanCaughtErrorBypass" is not required here, it was
		 * done already by "Tcl_Close".
		 */
		return TCL_ERROR;
	    }
	}
    }

    return TCL_OK;
}

 *
 *	This function flushes as much of the queued output as is possible
 *	now. If calledFromAsyncFlush is nonzero, it is being called in an
 *	event handler to flush channel output asynchronously.
 *
 * Results:
 *	0 if successful, else the error code that was returned by the channel
 *	type operation. May leave a message in the interp result.
 *
 * Side effects:
 *	May produce output on a channel. May block indefinitely if the channel
 *	is synchronous. May schedule an async flush on the channel.  May
 *	recycle memory for buffers in the output queue.
 *
 *----------------------------------------------------------------------

	    }

	    /*
	     * Decide whether to report the error upwards or defer it.
	     */

	    if (calledFromAsyncFlush) {
		/* TIP #219, Tcl Channel Reflection API.
		 * When defering the error copy a message from the bypass into
		 * the unreported area. Or discard it if the new error is to be
		 * ignored in favor of an earlier defered error.
		 */

	        Tcl_Obj* msg = statePtr->chanMsg;

		if (statePtr->unreportedError == 0) {
		    statePtr->unreportedError = errorCode;
		    statePtr->unreportedMsg   = msg;
		    if (msg != NULL) {
		        Tcl_IncrRefCount (msg);
		    }
		} else {
		    /* An old unreported error is kept, and this error
		     * thrown away.
		     */
		    statePtr->chanMsg = NULL;
		    if (msg != NULL) {
		        Tcl_DecrRefCount (msg);
		    }
		}
	    } else {
		/* TIP #219, Tcl Channel Reflection API.
		 * Move error messages put by the driver into the chan bypass
		 * area into the regular interpreter result. Fall back to the
		 * regular message if nothing was found in the bypasses.
		 */

		Tcl_SetErrno(errorCode);
		if (interp != NULL) {
		    if (!TclChanCaughtErrorBypass (interp, (Tcl_Channel) chanPtr)) {
		        /*
			 * Casting away CONST here is safe because the
			 * TCL_VOLATILE flag guarantees CONST treatment
			 * of the Posix error string.
			 */

		        Tcl_SetResult(interp,
				(char *) Tcl_PosixError(interp),
				TCL_VOLATILE);
		    }
		}
		/* An unreportable bypassed message is kept, for the
		 * caller of Tcl_Seek, Tcl_Write, etc.
		 */
	    }

	    /*
	     * When we get an error we throw away all the output currently
	     * queued.
	     */

 *	elements of the NEXT channel into the TOP channel, in essence
 *	unstacking the channel.  The NEXT channel will then be freed.
 *
 *	If the channel was not stacked, then we will free all the bits for the
 *	TOP channel, including the data structure itself.
 *
 * Results:
 *	Error code from an unreported error or the driver close operation.
 *
 * Side effects:
 *	May close the actual channel, may free memory, may change the value of
 *	errno.
 *
 *----------------------------------------------------------------------
 */

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

    if (statePtr->chanMsg != NULL) {
	if (interp != NULL) {
	    Tcl_SetChannelErrorInterp (interp,statePtr->chanMsg);
	}
        Tcl_DecrRefCount (statePtr->chanMsg);
	statePtr->chanMsg = NULL;
    }

    /*
     * Remove this channel from of the list of all channels.
     */

    Tcl_CutChannel((Tcl_Channel) chanPtr);

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

    /*
     * If we are being called synchronously, report either any latent error on
     * the channel or the current error.
     */

    if (statePtr->unreportedError != 0) {
	errorCode = statePtr->unreportedError;

	/* TIP #219, Tcl Channel Reflection API.
	 * Move an error message found in the unreported area into the regular
	 * bypass (interp). This kills any message in the channel bypass area.
	 */

	if (statePtr->chanMsg != NULL) {
	    Tcl_DecrRefCount (statePtr->chanMsg);
	    statePtr->chanMsg = NULL;
	}
        Tcl_SetChannelErrorInterp (interp,statePtr->unreportedMsg);
    }
    if (errorCode == 0) {
	errorCode = result;
	if (errorCode != 0) {
	    Tcl_SetErrno(errorCode);
	}
    }

					 * interpreter. */
{
    CloseCallback *cbPtr;		/* Iterate over close callbacks for
					 * this channel. */
    Channel *chanPtr;			/* The real IO channel. */
    ChannelState *statePtr;		/* State of real IO channel. */
    int result;				/* Of calling FlushChannel. */
    int flushcode;

    if (chan == (Tcl_Channel) NULL) {
	return TCL_OK;
    }

    /*
     * Perform special handling for standard channels being closed. If the

     * iso2022, the terminated escape sequence must write to the buffer.
     */

    if ((statePtr->encoding != NULL) && (statePtr->curOutPtr != NULL)
	    && (CheckChannelErrors(statePtr, TCL_WRITABLE) == 0)) {
	statePtr->outputEncodingFlags |= TCL_ENCODING_END;
	WriteChars(chanPtr, "", 0);

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

	if (statePtr->chanMsg != NULL) {
	    if (interp != NULL) {
		Tcl_SetChannelErrorInterp (interp,statePtr->chanMsg);
	    }
	    Tcl_DecrRefCount (statePtr->chanMsg);
	    statePtr->chanMsg = NULL;
	}
    }

    Tcl_ClearChannelHandlers(chan);

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

    /*
     * The call to FlushChannel will flush any queued output and invoke the
     * close function of the channel driver, or it will set up the channel to
     * be flushed and closed asynchronously.
     */

    statePtr->flags |= CHANNEL_CLOSED;

    flushcode = FlushChannel(interp, chanPtr, 0);

    /* TIP #219.
     * Capture error messages put by the driver into the bypass area and put
     * them into the regular interpreter result.
     *
     * Notes: Due to the assertion of CHANNEL_CLOSED in the flags
     * "FlushChannel" has called "CloseChannel" and thus freed all the channel
     * structures. We must not try to access "chan" anymore, hence the NULL
     * argument in the call below. The only place which may still contain a
     * message is the interpreter itself, and "CloseChannel" made sure to lift
     * any channel message it generated into it.
     */
    if (TclChanCaughtErrorBypass (interp, NULL)) {
	result = EINVAL;
    }

    if ((flushcode != 0) || (result != 0)) {
	return TCL_ERROR;
    }
    return TCL_OK;
}

/*
 *----------------------------------------------------------------------

    /*
     * Check for unreported error.
     */

    if (statePtr->unreportedError != 0) {
	Tcl_SetErrno(statePtr->unreportedError);
	statePtr->unreportedError = 0;

	/* TIP #219, Tcl Channel Reflection API.
	 * Move a defered error message back into the channel bypass.
	 */

	if (statePtr->chanMsg != NULL) {
	    Tcl_DecrRefCount (statePtr->chanMsg);
	}
	statePtr->chanMsg       = statePtr->unreportedMsg;
	statePtr->unreportedMsg = NULL;
	return -1;
    }

    /*
     * Only the raw read and write operations are allowed during close in
     * order to drain data from stacked channels.
     */

static int
CopyData(csPtr, mask)
    CopyState *csPtr;		/* State of copy operation. */
    int mask;			/* Current channel event flags. */
{
    Tcl_Interp *interp;
    Tcl_Obj *cmdPtr, *errObj = NULL, *bufObj = NULL;
    Tcl_Obj* msg = NULL;
    Tcl_Channel inChan, outChan;
    ChannelState *inStatePtr, *outStatePtr;
    int result = TCL_OK, size, total, sizeb;
    char *buffer;

    int inBinary, outBinary, sameEncoding; /* Encoding control */
    int underflow;		/* input underflow */

    }

    while (csPtr->toRead != 0) {
	/*
	 * Check for unreported background errors.
	 */

        Tcl_GetChannelError (inChan, &msg);
	if ((inStatePtr->unreportedError != 0) || (msg != NULL)) {
	    Tcl_SetErrno(inStatePtr->unreportedError);
	    inStatePtr->unreportedError = 0;
	    goto readError;
	}
        Tcl_GetChannelError (outChan, &msg);
	if ((outStatePtr->unreportedError != 0) || (msg != NULL)) {
	    Tcl_SetErrno(outStatePtr->unreportedError);
	    outStatePtr->unreportedError = 0;
	    goto writeError;
	}

	/*
	 * Read up to bufSize bytes.

	}
	underflow = (size >= 0) && (size < sizeb);	/* input underflow */

	if (size < 0) {
	readError:
	    TclNewObj(errObj);
	    Tcl_AppendStringsToObj(errObj, "error reading \"",
				   Tcl_GetChannelName(inChan), "\": ",
				   (char *) NULL);
	    if (msg != NULL) {
	        Tcl_AppendObjToObj(errObj,msg);
	    } else {
	        Tcl_AppendStringsToObj(errObj,
		       Tcl_PosixError(interp),
		       (char *) NULL);
	    }
	    break;
	} else if (underflow) {
	    /*
	     * We had an underflow on the read side.  If we are at EOF, then
	     * the copying is done, otherwise set up a channel handler to
	     * detect when the channel becomes readable again.
	     */

	    size = sizeb;
	} /* else : Read counted characters, write counted bytes, i.e. size != sizeb */

	if (sizeb < 0) {
	writeError:
	    TclNewObj(errObj);
	    Tcl_AppendStringsToObj(errObj, "error writing \"",
				   Tcl_GetChannelName(outChan), "\": ",
				   (char *) NULL);
	    if (msg != NULL) {
	        Tcl_AppendObjToObj(errObj,msg);
	    } else {
	        Tcl_AppendStringsToObj(errObj,
		       Tcl_PosixError(interp),
		       (char *) NULL);
	    }
	    break;
	}

	/*
	 * Update the current byte count. Do it now so the count is valid
	 * before a return or break takes us out of the loop. The invariant at
	 * the top of the loop should be that csPtr->toRead holds the number

{
    ChannelState *statePtr = chanPtr->state;	/* state info for channel */
    int result = 0;

    result = StackSetBlockMode(chanPtr, mode);
    if (result != 0) {
	if (interp != (Tcl_Interp *) NULL) {
	    /* TIP #219.
	     * Move error messages put by the driver into the bypass area and
	     * put them into the regular interpreter result. Fall back to the
	     * regular message if nothing was found in the bypass.
	     *
	     * Note that we cannot have a message in the interpreter bypass
	     * area, StackSetBlockMode is restricted to the channel bypass.
	     * We still need the interp as the destination of the move.
	     */
	    if (!TclChanCaughtErrorBypass (interp, (Tcl_Channel) chanPtr)) {
		Tcl_AppendResult(interp, "error setting blocking mode: ",
				 Tcl_PosixError(interp), (char *) NULL);
	    }
	} else {
	    /* TIP #219.
	     * If we have no interpreter to put a bypass message into we have
	     * to clear it, to prevent its propagation and use in other places
	     * unrelated to the actual occurence of the problem.
	     */
	    Tcl_SetChannelError ((Tcl_Channel) chanPtr, NULL);
	}
	return TCL_ERROR;
    }
    if (mode == TCL_MODE_BLOCKING) {
	statePtr->flags &= (~(CHANNEL_NONBLOCKING | BG_FLUSH_SCHEDULED));
    } else {
	statePtr->flags |= CHANNEL_NONBLOCKING;

{
    if (HaveVersion(chanTypePtr, TCL_CHANNEL_VERSION_4)) {
	return chanTypePtr->threadActionProc;
    } else {
	return NULL;
    }
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_SetChannelErrorInterp --
 *
 *      TIP #219, Tcl Channel Reflection API.
 *	Store an error message for the I/O system.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	Discards a previously stored message.
 *
 *----------------------------------------------------------------------
 */

void
Tcl_SetChannelErrorInterp (interp, msg)
     Tcl_Interp* interp; /* Interp to store the data into. */
     Tcl_Obj*    msg;    /* Error message to store. */
{
    Interp* iPtr = (Interp*) interp;

    if (iPtr->chanMsg != NULL) {
        Tcl_DecrRefCount (iPtr->chanMsg);
	iPtr->chanMsg  = NULL;
    }

    if (msg != NULL) {
        iPtr->chanMsg  = FixLevelCode (msg);
	Tcl_IncrRefCount (iPtr->chanMsg);
    }
    return;
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_SetChannelError --
 *
 *      TIP #219, Tcl Channel Reflection API.
 *	Store an error message for the I/O system.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	Discards a previously stored message.
 *
 *----------------------------------------------------------------------
 */

void
Tcl_SetChannelError (chan, msg)
     Tcl_Channel chan; /* Channel to store the data into. */
     Tcl_Obj*    msg;  /* Error message to store. */
{
    ChannelState* statePtr = ((Channel*) chan)->state;

    if (statePtr->chanMsg != NULL) {
        Tcl_DecrRefCount (statePtr->chanMsg);
	statePtr->chanMsg  = NULL;
    }

    if (msg != NULL) {
        statePtr->chanMsg  = FixLevelCode (msg);
	Tcl_IncrRefCount (statePtr->chanMsg);
    }
    return;
}

/*
 *----------------------------------------------------------------------
 *
 * FixLevelCode --
 *
 *      TIP #219, Tcl Channel Reflection API.
 *	Scans an error message for bad -code / -level
 *	directives. Returns a modified copy with such
 *	directives corrected, and the input if it had
 *	no problems.
 *
 * Results:
 *	A Tcl_Obj*
 *
 * Side effects:
 *	None.
 *
 *----------------------------------------------------------------------
 */

static Tcl_Obj*
FixLevelCode (msg)
Tcl_Obj* msg;
{
    int       lc;
    Tcl_Obj** lv;
    int       explicitResult;
    int       numOptions;
    int       lcn;
    Tcl_Obj** lvn;
    int       res, i, j, val, lignore, cignore;
    Tcl_Obj*  newlevel = NULL;
    Tcl_Obj*  newcode  = NULL;

    /* ASSERT msg != NULL */

    /* Process the caught message.
     *
     * Syntax = (option value)... ?message?
     *
     * Bad syntax causes a panic. Because the other side uses
     * Tcl_GetReturnOptions and list construction functions to marshall the
     * information.
     */

    res = Tcl_ListObjGetElements (NULL, msg, &lc, &lv);
    if (res != TCL_OK) {
	Tcl_Panic ("Tcl_SetChannelError(Interp): Bad syntax of message");
    }

    explicitResult = (1 == (lc % 2));
    numOptions     = lc - explicitResult;

    /* No options, nothing to do.
     */

    if (numOptions == 0) {
	return msg;
    }

    /* Check for -code x, x != 1|error, and -level x, x != 0 */

    for (i = 0; i < numOptions; i += 2) {
	if (0 == strcmp (Tcl_GetString (lv [i]), "-code")) {
	    /* !"error", !integer, integer != 1 (numeric code for error) */

	    res = Tcl_GetIntFromObj (NULL, lv [i+1], &val);
	    if (((res == TCL_OK) && (val != 1)) ||
		((res != TCL_OK) && (0 != strcmp (Tcl_GetString (lv [i+1]), "error")))) {
		newcode = Tcl_NewIntObj (1);
	    }
	} else if (0 == strcmp (Tcl_GetString (lv [i]), "-level")) {
	    /* !integer, integer != 0 */
	    res = Tcl_GetIntFromObj (NULL, lv [i+1], &val);
	    if ((res != TCL_OK) || (val != 0)) {
		newlevel = Tcl_NewIntObj (0);
	    }
	}
    }

    /* -code, -level are either not present or ok. Nothing to do.
     */

    if (!newlevel && !newcode) {
	return msg;
    }

    lcn = numOptions;
    if (explicitResult) lcn ++;
    if (newlevel)       lcn += 2;
    if (newcode)        lcn += 2;

    lvn = (Tcl_Obj**) ckalloc (lcn * sizeof (Tcl_Obj*));

    /* New level/code information is spliced into the first occurence of
     * -level, -code, further occurences are ignored. The options cannot be
     * not present, we would not come here. Options which are ok are simply
     * copied over.
     */

    lignore = cignore = 0;
    for (i = 0, j = 0; i < numOptions; i += 2) {
	if (0 == strcmp (Tcl_GetString (lv [i]), "-level")) {
	    if (newlevel) {
		lvn [j] = lv [i];   j++;
		lvn [j] = newlevel; j++;
		newlevel = NULL;
		lignore = 1;
		continue;
	    } else if (lignore) {
		continue;
	    }
	} else if (0 == strcmp (Tcl_GetString (lv [i]), "-code")) {
	    if (newcode) {
		lvn [j] = lv [i];  j++;
		lvn [j] = newcode; j++;
		newcode = NULL;
		cignore = 1;
		continue;
	    } else if (cignore) {
		continue;
	    }
	}
	/* Keep everything else, possibly copied down */
	lvn [j] = lv [i];   j++;
	lvn [j] = lv [i+1]; j++;
    }

    if (explicitResult) {
	lvn [j] = lv [i]; j++;
    }

    msg = Tcl_NewListObj (j, lvn);

    ckfree ((char*) lvn);
    return msg;
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_GetChannelErrorInterp --
 *
 *      TIP #219, Tcl Channel Reflection API.
 *	Return the message stored by the channel driver.
 *
 * Results:
 *	Tcl error message object.
 *
 * Side effects:
 *	Resets the stored data to NULL.
 *
 *----------------------------------------------------------------------
 */

void Tcl_GetChannelErrorInterp (interp, msg)
     Tcl_Interp* interp; /* Interp to query. */
     Tcl_Obj**   msg;    /* Place for error message. */
{
    Interp* iPtr = (Interp*) interp;

    *msg = iPtr->chanMsg;
    iPtr->chanMsg  = NULL;
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_GetChannelError --
 *
 *      TIP #219, Tcl Channel Reflection API.
 *	Return the message stored by the channel driver.
 *
 * Results:
 *	Tcl error message object.
 *
 * Side effects:
 *	Resets the stored data to NULL.
 *
 *----------------------------------------------------------------------
 */

void Tcl_GetChannelError (chan, msg)
     Tcl_Channel chan; /* Channel to query. */
     Tcl_Obj**   msg;  /* Place for error message. */
{
    ChannelState* statePtr = ((Channel*) chan)->state;

    *msg = statePtr->chanMsg;
    statePtr->chanMsg  = NULL;
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_ChannelTruncateProc --
 *
 *	TIP #208 (subsection relating to truncation, based on TIP #206).

/* 
 * tclIO.h --
 *
 *	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.h,v 1.7.2.1 2005/08/25 15:46:31 dgp Exp $
 */

/*
 * Make sure that both EAGAIN and EWOULDBLOCK are defined. This does not
 * compile on systems where neither is defined. We want both defined so
 * that we can test safely for both. In the code we still have to test for
 * both because there may be systems on which both are defined and have

    Channel *bottomChanPtr;	/* Refers to bottommost channel in a stack.
				 * This channel can be relied on to live as
				 * long as the channel state. Never NULL. */
    struct ChannelState *nextCSPtr;
				/* Next in list of channels currently open. */
    Tcl_ThreadId managingThread; /* TIP #10: Id of the thread managing
				  * this stack of channels. */

    /* TIP #219 ... Info for the I/O system ...
     * Error message set by channel drivers, for the propagation of
     * arbitrary Tcl errors. This information, if present (chanMsg not
     * NULL), takes precedence over a posix error code returned by a
     * channel operation.
     */

    Tcl_Obj* chanMsg;
    Tcl_Obj* unreportedMsg;     /* Non-NULL if an error report was
                                 * deferred because it happened in the
                                 * background. The value is the
                                 * chanMg, if any. #219's companion to
                                 * 'unreportedError'. */
} ChannelState;
    
/*
 * Values for the flags field in Channel. Any ORed combination of the
 * following flags can be stored in the field. These flags record various
 * options and state bits about the channel. In addition to the flags below,
 * the channel can also have TCL_READABLE (1<<1) and TCL_WRITABLE (1<<2) set.

/*
 * tclIOCmd.c --
 *
 *	Contains the definitions of most of the Tcl commands relating to IO.
 *
 * 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: tclIOCmd.c,v 1.22.2.4 2005/08/25 15:46:31 dgp Exp $
 */

#include "tclInt.h"

/*
 * Callback structure for accept callback in a TCP server.
 */

	if (result < 0) {
	    goto error;
	}
    }
    return TCL_OK;

  error:
    /* TIP #219.
     * Capture error messages put by the driver into the bypass area and put
     * them into the regular interpreter result. Fall back to the regular
     * message if nothing was found in the bypass.
     */
    if (!TclChanCaughtErrorBypass (interp, chan)) {
	Tcl_AppendResult(interp, "error writing \"", channelId, "\": ",
			 Tcl_PosixError(interp), (char *) NULL);
    }
    return TCL_ERROR;
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_FlushObjCmd --

    if ((mode & TCL_WRITABLE) == 0) {
	Tcl_AppendResult(interp, "channel \"", channelId,
		"\" wasn't opened for writing", (char *) NULL);
	return TCL_ERROR;
    }

    if (Tcl_Flush(chan) != TCL_OK) {
	/* TIP #219.
	 * Capture error messages put by the driver into the bypass area and
	 * put them into the regular interpreter result. Fall back to the
	 * regular message if nothing was found in the bypass.
	 */
	if (!TclChanCaughtErrorBypass (interp, chan)) {
	    Tcl_AppendResult(interp, "error flushing \"", channelId, "\": ",
			     Tcl_PosixError(interp), (char *) NULL);
	}
	return TCL_ERROR;
    }
    return TCL_OK;
}

/*
 *----------------------------------------------------------------------

    linePtr = Tcl_NewObj();

    lineLen = Tcl_GetsObj(chan, linePtr);
    if (lineLen < 0) {
	if (!Tcl_Eof(chan) && !Tcl_InputBlocked(chan)) {
	    Tcl_DecrRefCount(linePtr);

	    /* TIP #219.
	     * Capture error messages put by the driver into the bypass area
	     * and put them into the regular interpreter result. Fall back to
	     * the regular message if nothing was found in the bypass.
	     */
	    if (!TclChanCaughtErrorBypass (interp, chan)) {
		Tcl_ResetResult(interp);
		Tcl_AppendResult(interp, "error reading \"", name, "\": ",
				 Tcl_PosixError(interp), (char *) NULL);
	    }
	    return TCL_ERROR;
	}
	lineLen = -1;
    }
    if (objc == 3) {
	if (Tcl_ObjSetVar2(interp, objv[2], NULL, linePtr,
		TCL_LEAVE_ERR_MSG) == NULL) {

	}
    }

    resultPtr = Tcl_NewObj();
    Tcl_IncrRefCount(resultPtr);
    charactersRead = Tcl_ReadChars(chan, resultPtr, toRead, 0);
    if (charactersRead < 0) {
	/* TIP #219.
	 * Capture error messages put by the driver into the bypass area and
	 * put them into the regular interpreter result. Fall back to the
	 * regular message if nothing was found in the bypass.
	 */
	if (!TclChanCaughtErrorBypass (interp, chan)) {
	    Tcl_ResetResult(interp);
	    Tcl_AppendResult(interp, "error reading \"", name, "\": ",
			     Tcl_PosixError(interp), (char *) NULL);
	    Tcl_DecrRefCount(resultPtr);
	}
	return TCL_ERROR;
    }

    /*
     * If requested, remove the last newline in the channel if at EOF.
     */

	    return TCL_ERROR;
	}
	mode = modeArray[optionIndex];
    }

    result = Tcl_Seek(chan, offset, mode);
    if (result == Tcl_LongAsWide(-1)) {
	/* TIP #219.
	 * Capture error messages put by the driver into the bypass area and
	 * put them into the regular interpreter result. Fall back to the
	 * regular message if nothing was found in the bypass.
	 */
	if (!TclChanCaughtErrorBypass (interp, chan)) {
	    Tcl_AppendResult(interp, "error during seek on \"",
			     chanName, "\": ", Tcl_PosixError(interp),
			     (char *) NULL);
	}
	return TCL_ERROR;
    }
    return TCL_OK;
}

/*
 *----------------------------------------------------------------------

    ClientData clientData;		/* Not used. */
    Tcl_Interp *interp;			/* Current interpreter. */
    int objc;				/* Number of arguments. */
    Tcl_Obj *CONST objv[];		/* Argument objects. */
{
    Tcl_Channel chan;			/* The channel to tell on. */
    char *chanName;
    Tcl_WideInt newLoc;

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

    /*
     * Try to find a channel with the right name and permissions in the IO
     * channel table of this interpreter.
     */

    chanName = Tcl_GetString(objv[1]);
    chan = Tcl_GetChannel(interp, chanName, NULL);
    if (chan == (Tcl_Channel) NULL) {
	return TCL_ERROR;
    }

    newLoc = Tcl_Tell(chan);

    /* TIP #219.
     * Capture error messages put by the driver into the bypass area and put
     * them into the regular interpreter result.
     */
    if (TclChanCaughtErrorBypass (interp, chan)) {
	return TCL_ERROR;
    }

    Tcl_SetObjResult(interp, Tcl_NewWideIntObj(newLoc));
    return TCL_OK;
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_CloseObjCmd --

	}
	return TCL_OK;
    }

    resultPtr = Tcl_NewObj();
    if (Tcl_GetChannelHandle(chan, TCL_READABLE, NULL) == TCL_OK) {
	if (Tcl_ReadChars(chan, resultPtr, -1, 0) < 0) {
	    /* TIP #219.
	     * Capture error messages put by the driver into the bypass area
	     * and put them into the regular interpreter result. Fall back to
	     * the regular message if nothing was found in the bypass.
	     */
	    if (!TclChanCaughtErrorBypass (interp, chan)) {
		Tcl_ResetResult(interp);
		Tcl_AppendResult(interp, "error reading output from command: ",
				 Tcl_PosixError(interp), (char *) NULL);
		Tcl_DecrRefCount(resultPtr);
	    }
	    return TCL_ERROR;
	}
    }

    /*
     * If the process produced anything on stderr, it will have been returned
     * in the interpreter result.  It needs to be appended to the result

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

/* 
 * tclIORChan.c --
 *
 *	This file contains the implementation of Tcl's generic
 *	channel reflection code, which allows the implementation
 *	of Tcl channels in Tcl code.
 *
 *	Parts of this file are based on code contributed by 
 *	Jean-Claude Wippler.
 *
 *      See TIP #219 for the specification of this functionality.
 *
 * Copyright (c) 2004-2005 ActiveState, a divison of Sophos
 *
 * See the file "license.terms" for information on usage and redistribution
 * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
 *
 * RCS: @(#) $Id: tclIORChan.c,v 1.1.2.2 2005/08/25 15:46:31 dgp Exp $
 */

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

#ifndef EINVAL
#define EINVAL 9
#endif
#ifndef EOK
#define EOK    0
#endif

/*
 * Signatures of all functions used in the C layer of the reflection.
 */

/* Required */
static int	RcClose _ANSI_ARGS_((ClientData clientData,
		   Tcl_Interp *interp));

/* Required, "read" is optional despite this. */
static int	RcInput _ANSI_ARGS_((ClientData clientData,
		    char *buf, int toRead, int *errorCodePtr));

/* Required, "write" is optional despite this. */
static int	RcOutput _ANSI_ARGS_((ClientData clientData,
	            CONST char *buf, int toWrite, int *errorCodePtr));

/* Required */
static void	RcWatch _ANSI_ARGS_((ClientData clientData, int mask));

/* NULL'able - "blocking", is optional */
static int	RcBlock _ANSI_ARGS_((ClientData clientData,
				       int mode));

/* NULL'able - "seek", is optional */
static Tcl_WideInt RcSeekWide _ANSI_ARGS_((ClientData clientData,
		    Tcl_WideInt offset,
		    int mode, int *errorCodePtr));

static int RcSeek _ANSI_ARGS_((ClientData clientData,
		    long offset, int mode, int *errorCodePtr));

/* NULL'able - "cget" / "cgetall", are optional */
static int	RcGetOption _ANSI_ARGS_((ClientData clientData,
				       Tcl_Interp* interp,
				       CONST char *optionName,
				       Tcl_DString *dsPtr));

/* NULL'able - "configure", is optional */
static int	RcSetOption _ANSI_ARGS_((ClientData clientData,
				       Tcl_Interp* interp,
				       CONST char *optionName,
				       CONST char *newValue));


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

static Tcl_ChannelType tclRChannelType = {
  "tclrchannel",  /* Type name.                                    */
  TCL_CHANNEL_VERSION_3,
  RcClose,        /* Close channel, clean instance data            */
  RcInput,        /* Handle read request                           */
  RcOutput,       /* Handle write request                          */
  RcSeek,         /* Move location of access point.    NULL'able   */
  RcSetOption,    /* Set options.                      NULL'able   */
  RcGetOption,    /* Get options.                      NULL'able   */
  RcWatch,        /* Initialize notifier                           */
  NULL,           /* Get OS handle from the channel.   NULL'able   */
  NULL,           /* No close2 support.                NULL'able   */
  RcBlock,        /* Set blocking/nonblocking.         NULL'able   */
  NULL,           /* Flush channel. Not used by core.  NULL'able   */
  NULL,           /* Handle events.                    NULL'able   */
  RcSeekWide      /* Move access point (64 bit).       NULL'able   */
};

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

typedef struct {
  Tcl_Channel chan;    /* Back reference to generic channel structure.
		        */
  Tcl_Interp* interp;  /* Reference to the interpreter containing the
		        * Tcl level part of the channel. */
#ifdef TCL_THREADS
  Tcl_ThreadId thread; /* Thread the 'interp' belongs to. */
#endif

  /* 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
   * NOTE (9): for the method names ?
   */

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

  int mode;             /* Mask of R/W mode */
  int interest;         /* Mask of events the channel is interested in. */

  /* Note regarding the usage of timers.
   *
   * Most channel implementations need a timer in the
   * C level to ensure that data in buffers is flushed
   * out through the generation of fake file events.
   *
   * See 'rechan', 'memchan', etc.
   *
   * Here this is _not_ required. Interest in events is
   * posted to the Tcl level via 'watch'. And posting of
   * events is possible from the Tcl level as well, via
   * 'chan postevent'. This means that the generation of
   * all events, fake or not, timer based or not, is
   * completely in the hands of the Tcl level. Therefore
   * no timer here.
   */

} ReflectingChannel;

/*
 * Event literals. ==================================================
 */

static CONST char *eventOptions[] = {
  "read", "write", (char *) NULL
};
typedef enum {
  EVENT_READ, EVENT_WRITE
} EventOption;

/*
 * Method literals. ==================================================
 */

static CONST char *methodNames[] = {
  "blocking",	/* OPT */
  "cget",	/* OPT \/ Together or none */
  "cgetall",	/* OPT /\ of these two     */
  "configure",	/* OPT */
  "finalize",	/*     */
  "initialize",	/*     */
  "read",	/* OPT */
  "seek",	/* OPT */
  "watch",	/*     */
  "write",	/* OPT */
  (char *) NULL
};
typedef enum {
  METH_BLOCKING,
  METH_CGET,
  METH_CGETALL,
  METH_CONFIGURE,
  METH_FINAL,
  METH_INIT,
  METH_READ,
  METH_SEEK,
  METH_WATCH,
  METH_WRITE,
} MethodName;

#define FLAG(m) (1 << (m))
#define REQUIRED_METHODS (FLAG (METH_INIT) | FLAG (METH_FINAL) | FLAG (METH_WATCH))
#define NULLABLE_METHODS (FLAG (METH_BLOCKING) | FLAG (METH_SEEK) | \
	FLAG (METH_CONFIGURE) | FLAG (METH_CGET) | FLAG (METH_CGETALL))

#define RANDW (TCL_READABLE|TCL_WRITABLE)

#define IMPLIES(a,b) ((!(a)) || (b))
#define NEGIMPL(a,b)
#define HAS(x,f) (x & FLAG(f))


#ifdef TCL_THREADS
/*
 * Thread specific types and structures.
 *
 * We are here essentially creating a very specific implementation of
 * 'thread send'.
 */

/*
 * Enumeration of all operations which can be forwarded.
 */

typedef enum {
  RcOpClose,
  RcOpInput,
  RcOpOutput,
  RcOpSeek,
  RcOpWatch,
  RcOpBlock,
  RcOpSetOpt,
  RcOpGetOpt,
  RcOpGetOptAll
} RcOperation;

/*
 * 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 RcForwardParamBase {
  int   code; /* O: Ok/Fail of the cmd handler */
  char* msg;  /* O: Error message for handler failure */
  int   vol;  /* O: True - msg is allocated, False - msg is static */
} RcForwardParamBase;

/*
 * Operation specific parameter/result structures.
 */

typedef struct RcForwardParamClose {
  RcForwardParamBase b;
} RcForwardParamClose;

typedef struct RcForwardParamInput {
  RcForwardParamBase b;
  char* buf;    /* O: Where to store the read bytes */
  int   toRead; /* I: #bytes to read,
		 * O: #bytes actually read */
} RcForwardParamInput;

typedef struct RcForwardParamOutput {
  RcForwardParamBase b;
  CONST char* buf;     /* I: Where the bytes to write come from */
  int         toWrite; /* I: #bytes to write,
			* O: #bytes actually written */
} RcForwardParamOutput;

typedef struct RcForwardParamSeek {
  RcForwardParamBase b;
  int         seekMode; /* I: How to seek */
  Tcl_WideInt offset;   /* I: Where to seek,
			 * O: New location */
} RcForwardParamSeek;

typedef struct RcForwardParamWatch {
  RcForwardParamBase b;
  int mask; /* I: What events to watch for */
} RcForwardParamWatch;

typedef struct RcForwardParamBlock {
  RcForwardParamBase b;
  int nonblocking; /* I: What mode to activate */
} RcForwardParamBlock;

typedef struct RcForwardParamSetOpt {
  RcForwardParamBase b;
  CONST char* name;  /* Name of option to set */
  CONST char* value; /* Value to set */
} RcForwardParamSetOpt;

typedef struct RcForwardParamGetOpt {
  RcForwardParamBase b;
  CONST char*  name;  /* Name of option to get, maybe NULL */
  Tcl_DString* value; /* Result */
} RcForwardParamGetOpt;

/*
 * General event structure, with reference to
 * operation specific data.
 */

typedef struct RcForwardingEvent {
  Tcl_Event                  event; /* Basic event data, has to be first item */
  struct RcForwardingResult* resultPtr;

  RcOperation               op;    /* Forwarded driver operation */
  ReflectingChannel*        rcPtr; /* Channel instance */
  CONST RcForwardParamBase* param; /* Arguments, a RcForwardParamXXX pointer */
} RcForwardingEvent;

/*
 * Structure to manage the result of the forwarding.  This is not the
 * result of the operation itself, but about the success of the
 * forward event itself. The event can be successful, even if the
 * operation which was forwarded failed. It is also there to manage
 * the synchronization between the involved threads.
 */

typedef struct RcForwardingResult {

  Tcl_ThreadId  src;    /* Originating thread. */
  Tcl_ThreadId  dst;    /* Thread the op was forwarded to. */
  Tcl_Condition done;   /* Condition variable the forwarder blocks on. */
  int           result; /* TCL_OK or TCL_ERROR */

  struct RcForwardingEvent*  evPtr; /* Event the result belongs to. */

  struct RcForwardingResult* prevPtr; /* Links into the list of pending */
  struct RcForwardingResult* nextPtr; /* forwarded results. */

} RcForwardingResult;

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

static RcForwardingResult* forwardList = (RcForwardingResult*) NULL;
TCL_DECLARE_MUTEX (rcForwardMutex)

/*
 * Function containing the generic code executing a forward, and
 * wrapper macros for the actual operations we wish to forward.
 */

static void
RcForwardOp _ANSI_ARGS_ ((ReflectingChannel* rcPtr, RcOperation op,
			  Tcl_ThreadId dst, CONST VOID* param));

/*
 * The event function executed by the thread receiving a forwarding
 * event. Executes the appropriate function and collects the result,
 * if any.
 */

static int
RcForwardProc _ANSI_ARGS_ ((Tcl_Event *evPtr, int mask));

/*
 * Helpers which intercept when threads are going away, and clean up
 * after pending forwarding events. Different actions depending on
 * which thread went away, originator (src), or receiver (dst).
 */

static void
RcSrcExitProc _ANSI_ARGS_ ((ClientData clientData));

static void
RcDstExitProc _ANSI_ARGS_ ((ClientData clientData));

#define RcFreeReceivedError(pb) \
	if ((pb).vol) {ckfree ((pb).msg);}

#define RcPassReceivedErrorInterp(i,pb) \
	if ((i)) {Tcl_SetChannelErrorInterp ((i), Tcl_NewStringObj ((pb).msg,-1));} \
	RcFreeReceivedError (pb)

#define RcPassReceivedError(c,pb) \
	Tcl_SetChannelError ((c), Tcl_NewStringObj ((pb).msg,-1)); \
	RcFreeReceivedError (pb)

#define RcForwardSetStaticError(p,emsg) \
       (p)->code = TCL_ERROR; (p)->vol  = 0; (p)->msg  = (char*) (emsg);

#define RcForwardSetDynError(p,emsg) \
       (p)->code = TCL_ERROR; (p)->vol  = 1; (p)->msg  = (char*) (emsg);

static void
RcForwardSetObjError _ANSI_ARGS_ ((RcForwardParamBase* p,
				   Tcl_Obj*            obj));

#endif /* TCL_THREADS */

#define RcSetChannelErrorStr(c,msg) \
	Tcl_SetChannelError ((c), Tcl_NewStringObj ((msg),-1))

static Tcl_Obj* RcErrorMarshall _ANSI_ARGS_ ((Tcl_Interp *interp));
static void     RcErrorReturn   _ANSI_ARGS_ ((Tcl_Interp* interp, Tcl_Obj* msg));



/*
 * Static functions for this file:
 */

static int RcEncodeEventMask _ANSI_ARGS_((Tcl_Interp* interp,
		 CONST char* objName, Tcl_Obj* obj,
		 int* mask));

static Tcl_Obj* RcDecodeEventMask _ANSI_ARGS_ ((int mask));

static ReflectingChannel* RcNew _ANSI_ARGS_ ((Tcl_Interp* interp,
	     Tcl_Obj* cmdpfxObj, int mode,
	     Tcl_Obj* id));

static Tcl_Obj* RcNewHandle _ANSI_ARGS_ ((void));

static void RcFree _ANSI_ARGS_ ((ReflectingChannel* rcPtr));

static void
RcInvokeTclMethod _ANSI_ARGS_((ReflectingChannel* rcPtr,
       CONST char* method, Tcl_Obj* argone, Tcl_Obj* argtwo,
       int* result, Tcl_Obj** resultObj, int capture));

#define NO_CAPTURE (0)
#define DO_CAPTURE (1)

/*
 * 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_unsup       = "{read not supported by Tcl driver}";
static CONST char* msg_read_toomuch     = "{read delivered more than requested}";
static CONST char* msg_write_unsup      = "{write not supported by Tcl driver}";
static CONST char* msg_write_toomuch    = "{write wrote more than requested}";
static CONST char* msg_seek_beforestart = "{Tried to seek before origin}";

#ifdef TCL_THREADS
static CONST char* msg_send_originlost  = "{Origin thread lost}";
static CONST char* msg_send_dstlost     = "{Destination thread lost}";
#endif /* TCL_THREADS */

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

/*
 *----------------------------------------------------------------------
 *
 * TclChanCreateObjCmd --
 *
 *	This procedure is invoked to process the "chan create" 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
TclChanCreateObjCmd (/*ignored*/ clientData, interp, objc, objv)
     ClientData      clientData;
     Tcl_Interp*     interp;
     int             objc;
     Tcl_Obj* CONST* objv;
{
    ReflectingChannel* rcPtr;       /* Instance data of the new channel */
    Tcl_Obj*           rcId;        /* Handle of the new channel */
    int                mode;        /* R/W mode of new channel. Has to
				     * match abilities of handler commands */
    Tcl_Obj*           cmdObj;      /* Command prefix, list of words */
    Tcl_Obj*           cmdNameObj;  /* Command name */
    Tcl_Channel        chan;        /* Token for the new 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                res;         /* Result code for 'initialize' */
    Tcl_Obj*           resObj;      /* Result data for 'initialize' */
    int                methods;     /* Bitmask for supported methods. */
    Channel*           chanPtr;     /* 'chan' resolved to internal struct. */

    /* Syntax:   chan create MODE CMDPREFIX
     *           [0]  [1]    [2]  [3]
     *
     * Actually: rCreate MODE CMDPREFIX
     *           [0]     [1]  [2]
     */

#define MODE (1)
#define CMD  (2)

    /* Number of arguments ... */

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

    /* First argument is a list of modes. Allowed entries are "read",
     * "write". Expect at least one list element.  Abbreviations are
     * ok.
     */

    modeObj = objv [MODE];
    if (RcEncodeEventMask (interp, "mode", objv [MODE], &mode) != TCL_OK) {
        return TCL_ERROR;
    }

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

    /* Basic check that the command prefix truly is a list. */

    if (Tcl_ListObjIndex(interp, cmdObj, 0, &cmdNameObj) != TCL_OK) {
        return TCL_ERROR;
    }

    /* Now create the channel.
     */

    rcId  = RcNewHandle ();
    rcPtr = RcNew (interp, cmdObj, mode, rcId);
    chan  = Tcl_CreateChannel (&tclRChannelType,
			       Tcl_GetString (rcId),
			       rcPtr, mode);
    rcPtr->chan = chan;
    chanPtr = (Channel*) chan;

    /* Invoke 'initialize' and validate that the handler
     * is present and ok. Squash the channel if not.
     */

    /* Note: The conversion of 'mode' back into a Tcl_Obj ensures that
     * 'initialize' is invoked with canonical mode names, and no
     * abbreviations. Using modeObj directly could feed abbreviations
     * into the handler, and the handler is not specified to handle
     * such.
     */

    modeObj = RcDecodeEventMask (mode);
    RcInvokeTclMethod (rcPtr, "initialize", modeObj, NULL,
		       &res, &resObj, NO_CAPTURE);
    Tcl_DecrRefCount (modeObj);

    if (res != TCL_OK) {
        Tcl_Obj* err = Tcl_NewStringObj ("Initialize failure: ",-1);

	Tcl_AppendObjToObj(err,resObj);
	Tcl_SetObjResult (interp,err);
	Tcl_DecrRefCount (resObj); /* Remove reference we held from the 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.
     */

    Tcl_AppendResult (interp, "Initialize failure: ", (char*) NULL);

    if (Tcl_ListObjGetElements (interp, resObj,
			&listc, &listv) != TCL_OK) {
        /* The function above replaces my prefix in case of an error,
	 * so more work for us to get the prefix back into the error
	 * message
	 */

        Tcl_Obj* err = Tcl_NewStringObj ("Initialize failure: ",-1);

	Tcl_AppendObjToObj(err,Tcl_GetObjResult (interp));
	Tcl_SetObjResult (interp,err);
	goto error;
    }

    methods = 0;
    while (listc > 0) {
        if (Tcl_GetIndexFromObj (interp, listv [listc-1],
				 methodNames, "method", TCL_EXACT, &methIndex) != TCL_OK) {
	    Tcl_Obj* err = Tcl_NewStringObj ("Initialize failure: ",-1);

	    Tcl_AppendObjToObj(err,Tcl_GetObjResult (interp));
	    Tcl_SetObjResult (interp,err);
	    goto error;
	}

	methods |= FLAG (methIndex);
	listc --;
    }

    if ((REQUIRED_METHODS & methods) != REQUIRED_METHODS) {
        Tcl_AppendResult (interp, "Not all required methods supported",
			  (char*) NULL);
	goto error;
    }

    if ((mode & TCL_READABLE) && !HAS(methods,METH_READ)) {
        Tcl_AppendResult (interp, "Reading not supported, but requested",
			  (char*) NULL);
	goto error;
    }

    if ((mode & TCL_WRITABLE) && !HAS(methods,METH_WRITE)) {
        Tcl_AppendResult (interp, "Writing not supported, but requested",
			  (char*) NULL);
	goto error;
    }

    if (!IMPLIES (HAS(methods,METH_CGET), HAS(methods,METH_CGETALL))) {
        Tcl_AppendResult (interp, "'cgetall' not supported, but should be, as 'cget' is",
			  (char*) NULL);
	goto error;
    }

    if (!IMPLIES (HAS(methods,METH_CGETALL),HAS(methods,METH_CGET))) {
        Tcl_AppendResult (interp, "'cget' not supported, but should be, as 'cgetall' is",
			  (char*) NULL);
	goto error;
    }

    Tcl_ResetResult (interp);

    /* Everything is fine now */

    rcPtr->methods = methods;

    if ((methods & NULLABLE_METHODS) != NULLABLE_METHODS) {
        /* Some of the nullable methods are not supported.  We clone
	 * the channel type, null the associated C functions, and use
	 * the result as the actual channel type.
	 */

        Tcl_ChannelType* clonePtr = (Tcl_ChannelType*) ckalloc (sizeof (Tcl_ChannelType));
	if (clonePtr == (Tcl_ChannelType*) NULL) {
	    Tcl_Panic ("Out of memory in Tcl_RcCreate");
	}

	memcpy (clonePtr, &tclRChannelType, sizeof (Tcl_ChannelType));

	if (!(methods & FLAG (METH_CONFIGURE))) {
	  clonePtr->setOptionProc = NULL;
	}

	if (
	    !(methods & FLAG (METH_CGET)) &&
	    !(methods & FLAG (METH_CGETALL))
	    ) {
	    clonePtr->getOptionProc = NULL;
	}
	if (!(methods & FLAG (METH_BLOCKING))) {
	    clonePtr->blockModeProc = NULL;
	}
	if (!(methods & FLAG (METH_SEEK))) {
	    clonePtr->seekProc     = NULL;
	    clonePtr->wideSeekProc = NULL;
	}

	chanPtr->typePtr = clonePtr;
    }

    Tcl_RegisterChannel (interp, chan);

    /* Return handle as result of command */

    Tcl_SetObjResult (interp, rcId);
    return TCL_OK;

 error:
    /* Signal to RcClose to not call 'finalize' */
    rcPtr->methods = 0;
    Tcl_Close (interp, chan);
    return TCL_ERROR;

#undef MODE
#undef CMD
}

/*
 *----------------------------------------------------------------------
 *
 * TclChanPostEventObjCmd --
 *
 *	This procedure is invoked to process the "chan postevent"
 *	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.
 *
 *----------------------------------------------------------------------
 */

int
TclChanPostEventObjCmd (/*ignored*/ clientData, interp, objc, objv)
     ClientData      clientData;
     Tcl_Interp*     interp;
     int             objc;
     Tcl_Obj* CONST* objv;
{
    /* Syntax:   chan postevent CHANNEL EVENTSPEC
     *           [0]  [1]       [2]     [3]
     *
     * Actually: rPostevent CHANNEL EVENTSPEC
     *           [0]        [1]     [2]
     *
     *         where EVENTSPEC = {read write ...} (Abbreviations allowed as well.
     */

#define CHAN  (1)
#define EVENT (2)

    CONST char*        chanId;      /* Tcl level channel handle */
    Tcl_Channel        chan;        /* Channel associated to the handle */
    Tcl_ChannelType*   chanTypePtr; /* Its associated driver structure */
    ReflectingChannel* rcPtr;       /* Associated instance data */
    int                mode;        /* Dummy, r|w mode of the channel */
    int                events;      /* Mask of events to post */

    /* Number of arguments ... */

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

    /* First argument is a channel, a reflected channel, and the call
     * of this command is done from the interp defining the channel
     * handler cmd.
     */

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

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

    chanTypePtr = Tcl_GetChannelType (chan);

    /* We use a function referenced by the channel type as our cookie
     * to detect calls to non-reflecting channels. The channel type
     * itself is not suitable, as it might not be the static
     * definition in this file, but a clone thereof. And while we have
     * reserved the name of the type nothing in the core checks
     * against violation, so someone else might have created a channel
     * type using our name, clashing with ourselves.
     */

    if (chanTypePtr->watchProc != &RcWatch) {
        Tcl_AppendResult(interp, "channel \"", chanId,
			 "\" is not a reflected channel",
			 (char *) NULL);
	return TCL_ERROR;
    }

    rcPtr = (ReflectingChannel*) Tcl_GetChannelInstanceData (chan);

    if (rcPtr->interp != interp) {
        Tcl_AppendResult(interp, "postevent for channel \"", chanId,
			 "\" called from outside interpreter",
			 (char *) NULL);
	return TCL_ERROR;
    }

    /* Second argument is a list of events. Allowed entries are
     * "read", "write". Expect at least one list element.
     * Abbreviations are ok.
     */

    if (RcEncodeEventMask (interp, "event", objv [EVENT], &events) != TCL_OK) {
        return TCL_ERROR;
    }
    
    /* Check that the channel is actually interested in the provided
     * events.
     */

    if (events & ~rcPtr->interest) {
        Tcl_AppendResult(interp, "tried to post events channel \"", chanId,
			 "\" is not interested in",
			 (char *) NULL);
	return TCL_ERROR;
    }

    /* We have the channel and the events to post.
     */

    Tcl_NotifyChannel (chan, events);

    /* Squash interp results left by the event script.
     */

    Tcl_ResetResult (interp);
    return TCL_OK;

#undef CHAN
#undef EVENT
}


static Tcl_Obj*
RcErrorMarshall (interp)
     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.
     */
    
    Tcl_Obj* returnOpt = Tcl_GetReturnOptions (interp, TCL_ERROR);

    /* => returnOpt.refCount == 0. We can append directly.
     */

    Tcl_ListObjAppendElement (NULL, returnOpt, Tcl_GetObjResult (interp));
    return returnOpt;
}

static void
RcErrorReturn (interp, msg)
     Tcl_Interp *interp;
     Tcl_Obj    *msg;
{
    int       res;
    int       lc;
    Tcl_Obj** lv;
    int       explicitResult;
    int       numOptions;

    /* Process the caught message.
     *
     * Syntax = (option value)... ?message?
     *
     * Bad syntax causes a panic. Because the other side uses
     * Tcl_GetReturnOptions and list construction functions to marshall the
     * information.
     */

    res = Tcl_ListObjGetElements (interp, msg, &lc, &lv);
    if (res != TCL_OK) {
	Tcl_Panic ("TclChanCaughtErrorBypass: Bad syntax of caught result");
    }

    explicitResult = (1 == (lc % 2));
    numOptions     = lc - explicitResult;

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

    (void) Tcl_SetReturnOptions(interp, Tcl_NewListObj (numOptions, lv));
}

int
TclChanCaughtErrorBypass (interp, chan)
     Tcl_Interp *interp;
     Tcl_Channel chan;
{
    Tcl_Obj* msgc = NULL;
    Tcl_Obj* msgi = NULL;
    Tcl_Obj* msg  = NULL;

    /* Get a bypassed error message from channel and/or interpreter, save the
     * reference, then kill the returned objects, if there were any. If there
     * are messages in both the channel has preference.
     */

    if ((chan == NULL) && (interp == NULL)) {
	return 0;
    }

    if (chan != NULL) {
	Tcl_GetChannelError       (chan,   &msgc);
    }
    if (interp != NULL) {
	Tcl_GetChannelErrorInterp (interp, &msgi);
    }

    if (msgc != NULL) {
	msg = msgc;
	Tcl_IncrRefCount (msg);
    } else if (msgi != NULL) {
	msg = msgi;
	Tcl_IncrRefCount (msg);
    }

    if (msgc != NULL) {
	Tcl_DecrRefCount (msgc);
    }
    if (msgi != NULL) {
	Tcl_DecrRefCount (msgi);
    }

    /* No message returned, nothing caught.
     */

    if (msg == NULL) {
	return 0;
    }

    RcErrorReturn (interp, msg);

    Tcl_DecrRefCount (msg);
    return 1;
}

/*
 * Driver functions. ================================================
 */

/*
 *----------------------------------------------------------------------
 *
 * RcClose --
 *
 *	This function is invoked when the channel is closed, to delete
 *	the driver specific instance data.
 *
 * Results:
 *	A posix error.
 *
 * Side effects:
 *	Releases memory. Arbitrary, as it calls upon a script.
 *
 *----------------------------------------------------------------------
 */

static int
RcClose (clientData, interp)
     ClientData  clientData;
     Tcl_Interp* interp;
{
    ReflectingChannel* rcPtr = (ReflectingChannel*) clientData;
    int                res;         /* Result code for 'close' */
    Tcl_Obj*           resObj;      /* Result data for 'close' */

    if (interp == (Tcl_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 our C level data structures and leave
	 * the Tcl level to the other finalization functions.
	 */

      /* THREADED => Forward this to the origin thread */
      /* Note: Have a thread delete handler for the origin
       * thread. Use this to clean up the structure!
       */

#ifdef TCL_THREADS
        /* Are we in the correct thread ?
	 */

        if (rcPtr->thread != Tcl_GetCurrentThread ()) {
	    RcForwardParamClose p;

	    RcForwardOp (rcPtr, RcOpClose, rcPtr->thread, &p);
	    res = p.b.code;

	    /* RcFree is done in the forwarded operation!,
	     * in the other thread. rcPtr here is gone!
	     */

	    if (res != TCL_OK) {
	        RcFreeReceivedError (p.b);
	    }
	} else {
#endif
	    RcFree (rcPtr);
#ifdef TCL_THREADS
	}
#endif
	return EOK;
    }

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

    /* -- No -- ASSERT rcPtr->methods & FLAG (METH_FINAL) */

    /* A cleaned method mask here implies that the channel creation
     * was aborted, and "finalize" must not be called.
     */

    if (rcPtr->methods == 0) {
        RcFree (rcPtr);
        return EOK;
    } else {
#ifdef TCL_THREADS
        /* Are we in the correct thread ?
	 */

        if (rcPtr->thread != Tcl_GetCurrentThread ()) {
	    RcForwardParamClose p;

	    RcForwardOp (rcPtr, RcOpClose, rcPtr->thread, &p);
	    res = p.b.code;

	    /* RcFree is done in the forwarded operation!,
	     * in the other thread. rcPtr here is gone!
	     */

	    if (res != TCL_OK) {
	        RcPassReceivedErrorInterp (interp, p.b);
	    }
	} else {
#endif
	    RcInvokeTclMethod (rcPtr, "finalize", NULL, NULL,
			       &res, &resObj, DO_CAPTURE);

	    if ((res != TCL_OK) && (interp != NULL)) {
	        Tcl_SetChannelErrorInterp (interp, resObj);
	    }

	    Tcl_DecrRefCount (resObj); /* Remove reference we held from the invoke */
#ifdef TCL_THREADS
	    RcFree (rcPtr);
	}
#endif
	return (res == TCL_OK) ? EOK : EINVAL;
    }

    Tcl_Panic ("Should not be reached");
    return EINVAL;
}

/*
 *----------------------------------------------------------------------
 *
 * RcInput --
 *
 *	This function is invoked when more data is requested from the
 *	channel.
 *
 * Results:
 *	The number of bytes read.
 *
 * Side effects:
 *	Allocates memory. Arbitrary, as it calls upon a script.
 *
 *----------------------------------------------------------------------
 */

static int
RcInput (clientData, buf, toRead, errorCodePtr)
     ClientData clientData;
     char* buf;
     int toRead;
     int* errorCodePtr;
{
    ReflectingChannel* rcPtr = (ReflectingChannel*) clientData;
    Tcl_Obj*           toReadObj;
    int                bytec;       /* Number of returned bytes */
    unsigned char*     bytev;       /* Array of returned bytes */
    int                res;         /* Result code for 'read' */
    Tcl_Obj*           resObj;      /* Result data for '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 (!(rcPtr->methods & FLAG (METH_READ))) {
        RcSetChannelErrorStr (rcPtr->chan, msg_read_unsup);
	*errorCodePtr = EINVAL;
	return -1;
    }

#ifdef TCL_THREADS
    /* Are we in the correct thread ?
     */

    if (rcPtr->thread != Tcl_GetCurrentThread ()) {
        RcForwardParamInput p;

	p.buf    = buf;
	p.toRead = toRead;

	RcForwardOp (rcPtr, RcOpInput, rcPtr->thread, &p);

	if (p.b.code != TCL_OK) {
	    RcPassReceivedError (rcPtr->chan, p.b);
	    *errorCodePtr = EINVAL;
	} else {
	    *errorCodePtr = EOK;
	}

	return p.toRead;
    }
#endif

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

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

    toReadObj = Tcl_NewIntObj(toRead);
    if (toReadObj == (Tcl_Obj*) NULL) {
        Tcl_Panic ("Out of memory in RcInput");
    }

    RcInvokeTclMethod (rcPtr, "read", toReadObj, NULL,
		       &res, &resObj, DO_CAPTURE);

    if (res != TCL_OK) {
	Tcl_SetChannelError (rcPtr->chan, resObj);
        Tcl_DecrRefCount (resObj); /* Remove reference we held from the invoke */
	*errorCodePtr = EINVAL;
	return -1;
    }

    bytev = Tcl_GetByteArrayFromObj(resObj, &bytec);

    if (toRead < bytec) {
        Tcl_DecrRefCount (resObj); /* Remove reference we held from the invoke */
	RcSetChannelErrorStr (rcPtr->chan, msg_read_toomuch);
	*errorCodePtr = EINVAL;
	return -1;
    }

    *errorCodePtr = EOK;

    if (bytec > 0) {
        memcpy (buf, bytev, bytec);
    }

    Tcl_DecrRefCount (resObj); /* Remove reference we held from the invoke */
    return bytec;
}

/*
 *----------------------------------------------------------------------
 *
 * RcOutput --
 *
 *	This function is invoked when data is writen to the
 *	channel.
 *
 * Results:
 *	The number of bytes actually written.
 *
 * Side effects:
 *	Allocates memory. Arbitrary, as it calls upon a script.
 *
 *----------------------------------------------------------------------
 */

static int
RcOutput (clientData, buf, toWrite, errorCodePtr)
     ClientData clientData;
     CONST char* buf;
     int toWrite;
     int* errorCodePtr;
{
    ReflectingChannel* rcPtr = (ReflectingChannel*) clientData;
    Tcl_Obj*       bufObj;
    int            res;         /* Result code for 'write' */
    Tcl_Obj*       resObj;      /* Result data for 'write' */
    int            written;

    /* 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 (!(rcPtr->methods & FLAG (METH_WRITE))) {
        RcSetChannelErrorStr (rcPtr->chan, msg_write_unsup);
        *errorCodePtr = EINVAL;
	return -1;
    }

#ifdef TCL_THREADS
    /* Are we in the correct thread ?
     */

    if (rcPtr->thread != Tcl_GetCurrentThread ()) {
      RcForwardParamOutput p;

      p.buf     = buf;
      p.toWrite = toWrite;

      RcForwardOp (rcPtr, RcOpOutput, rcPtr->thread, &p);

      if (p.b.code != TCL_OK) {
	  RcPassReceivedError (rcPtr->chan, p.b);
	  *errorCodePtr = EINVAL;
      } else {
	  *errorCodePtr = EOK;
      }

      return p.toWrite;
    }
#endif

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

    /* ASSERT: rcPtr->method & FLAG (METH_WRITE) */
    /* ASSERT: rcPtr->mode & TCL_WRITABLE */
    
    bufObj = Tcl_NewByteArrayObj((unsigned char*) buf, toWrite);
    if (bufObj == (Tcl_Obj*) NULL) {
        Tcl_Panic ("Out of memory in RcOutput");
    }

    RcInvokeTclMethod (rcPtr, "write", bufObj, NULL,
		       &res, &resObj, DO_CAPTURE);

    if (res != TCL_OK) {
	Tcl_SetChannelError (rcPtr->chan, resObj);
	Tcl_DecrRefCount (resObj); /* Remove reference we held from the invoke */
	*errorCodePtr = EINVAL;
	return -1;
    }

    res = Tcl_GetIntFromObj (rcPtr->interp, resObj, &written);
    if (res != TCL_OK) {
        Tcl_DecrRefCount (resObj); /* Remove reference we held from the invoke */
	Tcl_SetChannelError (rcPtr->chan, RcErrorMarshall (rcPtr->interp));
	*errorCodePtr = EINVAL;
	return -1;
    }

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

    if ((written == 0) || (toWrite < written)) {
        /* The handler claims to have written more than it was given.
	 * That is bad. Note that the I/O core would crash if we were
	 * to return this information, trying to write -nnn bytes in
	 * the next iteration.
	 */

        RcSetChannelErrorStr (rcPtr->chan, msg_write_toomuch);
	*errorCodePtr = EINVAL;
	return -1;
    }

    *errorCodePtr = EOK;
    return written;
}

/*
 *----------------------------------------------------------------------
 *
 * RcSeekWide / RcSeek --
 *
 *	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, as it calls upon a script.
 *
 *----------------------------------------------------------------------
 */

static Tcl_WideInt
RcSeekWide (clientData, offset, seekMode, errorCodePtr)
     ClientData  clientData;
     Tcl_WideInt offset;
     int         seekMode;
     int*        errorCodePtr;
{
    ReflectingChannel* rcPtr = (ReflectingChannel*) clientData;
    Tcl_Obj*       offObj;
    Tcl_Obj*       baseObj;
    int            res;         /* Result code for 'seek' */
    Tcl_Obj*       resObj;      /* Result data for 'seek' */
    Tcl_WideInt    newLoc;

#ifdef TCL_THREADS
    /* Are we in the correct thread ?
     */

    if (rcPtr->thread != Tcl_GetCurrentThread ()) {
        RcForwardParamSeek p;

	p.seekMode = seekMode;
	p.offset   = offset;

	RcForwardOp (rcPtr, RcOpSeek, rcPtr->thread, &p);

	if (p.b.code != TCL_OK) {
	    RcPassReceivedError (rcPtr->chan, p.b);
	    *errorCodePtr = EINVAL;
	} else {
	    *errorCodePtr = EOK;
	}

	return p.offset;
    }
#endif

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

    /* ASSERT: rcPtr->method & FLAG (METH_SEEK) */

    offObj = Tcl_NewWideIntObj(offset);
    if (offObj == (Tcl_Obj*) NULL) {
        Tcl_Panic ("Out of memory in RcSeekWide");
    }

    baseObj = Tcl_NewStringObj((seekMode == SEEK_SET) ?
			       "start" :
			       ((seekMode == SEEK_CUR) ?
				"current" :
				"end"), -1);

    if (baseObj == (Tcl_Obj*) NULL) {
        Tcl_Panic ("Out of memory in RcSeekWide");
    }

    RcInvokeTclMethod (rcPtr, "seek", offObj, baseObj,
		       &res, &resObj, DO_CAPTURE);

    if (res != TCL_OK) {
	Tcl_SetChannelError (rcPtr->chan, resObj);
        Tcl_DecrRefCount (resObj); /* Remove reference we held from the invoke */
	*errorCodePtr = EINVAL;
	return -1;
    }

    res = Tcl_GetWideIntFromObj (rcPtr->interp, resObj, &newLoc);
    if (res != TCL_OK) {
        Tcl_DecrRefCount (resObj); /* Remove reference we held from the invoke */
	Tcl_SetChannelError (rcPtr->chan, RcErrorMarshall (rcPtr->interp));
	*errorCodePtr = EINVAL;
	return -1;
    }

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

    if (newLoc < Tcl_LongAsWide (0)) {
        RcSetChannelErrorStr (rcPtr->chan, msg_seek_beforestart);
        *errorCodePtr = EINVAL;
	return -1;
    }

    *errorCodePtr = EOK;
    return newLoc;
}

static int
RcSeek (clientData, offset, seekMode, errorCodePtr)
     ClientData  clientData;
     long        offset;
     int         seekMode;
     int*        errorCodePtr;
{
  /* This function can be invoked from a transformation which is based
   * on standard seeking, i.e. non-wide. Because o this we have to
   * implement it, a dummy is not enough. We simply delegate the call
   * to the wide routine.
   */

  return (int) RcSeekWide (clientData, Tcl_LongAsWide (offset),
			   seekMode, errorCodePtr);
}

/*
 *----------------------------------------------------------------------
 *
 * RcWatch --
 *
 *	This function is invoked to tell the channel what events
 *	the I/O system is interested in.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	Allocates memory. Arbitrary, as it calls upon a script.
 *
 *----------------------------------------------------------------------
 */

static void
RcWatch (clientData, mask)
     ClientData clientData;
     int mask;
{
    ReflectingChannel* rcPtr = (ReflectingChannel*) clientData;
    Tcl_Obj* maskObj;

    /* ASSERT rcPtr->methods & FLAG (METH_WATCH) */

    /* We restrict the interest to what the channel can support
     * IOW there will never be write events for a channel which is
     * not writable. Analoguous for read events.
     */

    mask = mask & rcPtr->mode; 

    if (mask == rcPtr->interest) {
        /* Same old, same old, why should we do something ? */
      return;
    }

    rcPtr->interest = mask;

#ifdef TCL_THREADS
    /* Are we in the correct thread ?
     */

    if (rcPtr->thread != Tcl_GetCurrentThread ()) {
        RcForwardParamWatch p;

	p.mask = mask;

	RcForwardOp (rcPtr, RcOpWatch, rcPtr->thread, &p);

	/* Any failure from the forward is ignored. We have no place to
	 * put this.
	 */
	return;
    }
#endif

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

    maskObj = RcDecodeEventMask (mask);
    RcInvokeTclMethod (rcPtr, "watch", maskObj, NULL,
		       NULL, NULL, NO_CAPTURE);
    Tcl_DecrRefCount (maskObj);
}

/*
 *----------------------------------------------------------------------
 *
 * RcBlock --
 *
 *	This function is invoked to tell the channel which blocking
 *	behaviour is required of it.
 *
 * Results:
 *	A posix error number.
 *
 * Side effects:
 *	Allocates memory. Arbitrary, as it calls upon a script.
 *
 *----------------------------------------------------------------------
 */

static int
RcBlock (clientData, nonblocking)
     ClientData clientData;
     int nonblocking;
{
    ReflectingChannel* rcPtr = (ReflectingChannel*) clientData;
    Tcl_Obj*           blockObj;
    int                res;         /* Result code for 'blocking' */
    Tcl_Obj*           resObj;      /* Result data for 'blocking' */

#ifdef TCL_THREADS
    /* Are we in the correct thread ?
     */

    if (rcPtr->thread != Tcl_GetCurrentThread ()) {
        RcForwardParamBlock p;

	p.nonblocking = nonblocking;

	RcForwardOp (rcPtr, RcOpBlock, rcPtr->thread, &p);

	if (p.b.code != TCL_OK) {
	    RcPassReceivedError (rcPtr->chan, p.b);
	    return EINVAL;
	} else {
	    return EOK;
	}
    }
#endif

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

    blockObj = Tcl_NewBooleanObj(!nonblocking);
    if (blockObj == (Tcl_Obj*) NULL) {
        Tcl_Panic ("Out of memory in RcBlock");
    }

    RcInvokeTclMethod (rcPtr, "blocking", blockObj, NULL,
		       &res, &resObj, DO_CAPTURE);

    if (res != TCL_OK) {
	Tcl_SetChannelError (rcPtr->chan, resObj);
	res = EINVAL;
    } else {
        res = EOK;
    }

    Tcl_DecrRefCount (resObj); /* Remove reference we held from the invoke */
    return res;
}

/*
 *----------------------------------------------------------------------
 *
 * RcSetOption --
 *
 *	This function is invoked to configure a channel option.
 *
 * Results:
 *	A standard Tcl result code.
 *
 * Side effects:
 *	Arbitrary, as it calls upon a Tcl script.
 *
 *----------------------------------------------------------------------
 */

static int
RcSetOption (clientData, interp, optionName, newValue)
     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 */
{
    ReflectingChannel* rcPtr = (ReflectingChannel*) clientData;
    Tcl_Obj*           optionObj;
    Tcl_Obj*           valueObj;
    int                res;         /* Result code for 'configure' */
    Tcl_Obj*           resObj;      /* Result data for 'configure' */

#ifdef TCL_THREADS
    /* Are we in the correct thread ?
     */

    if (rcPtr->thread != Tcl_GetCurrentThread ()) {
        RcForwardParamSetOpt p;

	p.name  = optionName;
	p.value = newValue;

	RcForwardOp (rcPtr, RcOpSetOpt, rcPtr->thread, &p);

	if (p.b.code != TCL_OK) {
	    Tcl_Obj* err = Tcl_NewStringObj (p.b.msg, -1);

	    RcErrorReturn (interp, err);

	    Tcl_DecrRefCount (err);
	    if (p.b.vol) {ckfree (p.b.msg);}
	}

	return p.b.code;
    }
#endif

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

  optionObj = Tcl_NewStringObj(optionName,-1);
  if (optionObj == (Tcl_Obj*) NULL) {
    Tcl_Panic ("Out of memory in RcSetOption");
  }

  valueObj = Tcl_NewStringObj(newValue,-1);
  if (valueObj == (Tcl_Obj*) NULL) {
    Tcl_Panic ("Out of memory in RcSetOption");
  }

  RcInvokeTclMethod (rcPtr, "configure", optionObj, valueObj,
		     &res, &resObj, DO_CAPTURE);

  if (res != TCL_OK) {
    RcErrorReturn (interp, resObj);
  }

  Tcl_DecrRefCount (resObj); /* Remove reference we held from the invoke */
  return res;
}

/*
 *----------------------------------------------------------------------
 *
 * RcGetOption --
 *
 *	This function is invoked to retrieve all or a channel option.
 *
 * Results:
 *	A standard Tcl result code.
 *
 * Side effects:
 *	Arbitrary, as it calls upon a Tcl script.
 *
 *----------------------------------------------------------------------
 */

static int
RcGetOption (clientData, interp, optionName, dsPtr)
     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 */
{
    /* This code is special. It has regular passing of Tcl result, and
     * errors. The bypass functions are not required.
     */

    ReflectingChannel* rcPtr = (ReflectingChannel*) clientData;
    Tcl_Obj*           optionObj;
    int                res;         /* Result code for 'configure' */
    Tcl_Obj*           resObj;      /* Result data for 'configure' */
    int                listc;
    Tcl_Obj**          listv;
    const char*        method;

#ifdef TCL_THREADS
    /* Are we in the correct thread ?
     */

    if (rcPtr->thread != Tcl_GetCurrentThread ()) {
        int opcode;
        RcForwardParamGetOpt p;

	p.name  = optionName;
	p.value = dsPtr;

	if (optionName == (char*) NULL) {
	    opcode = RcOpGetOptAll;
	} else {
	    opcode = RcOpGetOpt;
	}

	RcForwardOp (rcPtr, opcode, rcPtr->thread, &p);

	if (p.b.code != TCL_OK) {
	    Tcl_Obj* err = Tcl_NewStringObj (p.b.msg, -1);

	    RcErrorReturn (interp, err);

	    Tcl_DecrRefCount (err);
	    if (p.b.vol) {ckfree (p.b.msg);}
	}

	return p.b.code;
    }
#endif

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

    if (optionName == (char*) NULL) {
        /* Retrieve all options. */
        method    = "cgetall";
	optionObj = NULL;
    } else {
        /* Retrieve the value of one option */
      
        method    = "cget";
	optionObj = Tcl_NewStringObj(optionName,-1);
	if (optionObj == (Tcl_Obj*) NULL) {
	    Tcl_Panic ("Out of memory in RcGetOption");
	}
    }

    RcInvokeTclMethod (rcPtr, method, optionObj, NULL,
			 &res, &resObj, DO_CAPTURE);

    if (res != TCL_OK) {
        RcErrorReturn (interp, resObj);
	Tcl_DecrRefCount (resObj); /* Remove reference we held from the invoke */
	return res;
    }

    /* The result has to go into the 'dsPtr' for propagation to the
     * caller of the driver.
     */

    if (optionObj != NULL) {
        Tcl_DStringAppend (dsPtr, Tcl_GetString (resObj), -1);
	Tcl_DecrRefCount (resObj); /* Remove reference we held from the invoke */
	return res;
    }

    /* Extract the list and append each item as element.
     */

    /* NOTE (4): If we extract the string rep we can assume a
     * NOTE (4): properly quoted string. Together with a separating
     * NOTE (4): space this way of simply appending the whole string
     * NOTE (4): rep might be faster. It also doesn't check if the
     * NOTE (4): result is a valid list. Nor that the list has an
     * NOTE (4): even number elements.
     * NOTE (4): ---
     */

    res = Tcl_ListObjGetElements (interp, resObj, &listc, &listv);

    if (res != TCL_OK) {
        Tcl_DecrRefCount (resObj); /* Remove reference we held from the invoke */
	return res;
    }

    if ((listc % 2) == 1) {
        /* Odd number of elements is wrong.
	 */

        char buf [20];

	sprintf (buf, "%d", listc);
	Tcl_ResetResult  (interp);
	Tcl_AppendResult (interp,
			  "Expected list with even number of elements, got ",
			  buf, (listc == 1 ? " element" : " elements"),
			  " instead", (char*) NULL);

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


    {
        int len;
	char* str = Tcl_GetStringFromObj (resObj, &len);

	if (len) {
	    Tcl_DStringAppend (dsPtr, " ", 1);
	    Tcl_DStringAppend (dsPtr, str, len);
	}
    }
    Tcl_DecrRefCount (resObj); /* Remove reference we held from the invoke */
    return res;
}

/*
 * Helpers. =========================================================
 */

/*
 *----------------------------------------------------------------------
 *
 * RcEncodeEventMask --
 *
 *	This function takes a list of event items and constructs the
 *	equivalent internal bitmask. The list has to contain at
 *	least one element. Elements are "read", "write", or any unique
 *	abbreviation thereof. Note that the bitmask is not changed if
 *	problems are encountered.
 *
 * Results:
 *	A standard Tcl error code. A bitmask where TCL_READABLE
 *	and/or TCL_WRITABLE can be set.
 *
 * Side effects:
 *	May shimmer 'obj' to a list representation. May place an
 *	error message into the interp result.
 *
 *----------------------------------------------------------------------
 */

static int
RcEncodeEventMask (interp, objName, obj, mask)
     Tcl_Interp* interp;
     CONST char* objName;
     Tcl_Obj*    obj;
     int*        mask;
{
    int        events;	/* Mask of events to post */
    int        listc;     /* #elements in eventspec list */
    Tcl_Obj**  listv;     /* Elements of eventspec list */
    int        evIndex;   /* Id of event for an element of the
			 * eventspec list */

    if (Tcl_ListObjGetElements (interp, obj,
				&listc, &listv) != TCL_OK) {
        return TCL_ERROR;
    }

    if (listc < 1) {
        Tcl_AppendResult(interp, "bad ", objName, " list: is empty",
			 (char *) NULL);
	return TCL_ERROR;
    }

    events = 0;
    while (listc > 0) {
        if (Tcl_GetIndexFromObj (interp, listv [listc-1],
				 eventOptions, objName, 0, &evIndex) != TCL_OK) {
	    return TCL_ERROR;
	}
	switch (evIndex) {
	    case EVENT_READ:  events |= TCL_READABLE; break;
	    case EVENT_WRITE: events |= TCL_WRITABLE; break;
	}
	listc --;
    }

    *mask = events;
    return TCL_OK;
}

/*
 *----------------------------------------------------------------------
 *
 * RcDecodeEventMask --
 *
 *	This function takes an internal bitmask of events and
 *	constructs the equivalent list of event items.
 *
 * Results:
 *	A Tcl_Obj reference. The object will have a refCount of
 *	one. The user has to decrement it to release the object.
 *
 * Side effects:
 *	None.
 *
 *----------------------------------------------------------------------
 */

static Tcl_Obj*
RcDecodeEventMask (mask)
{
    Tcl_Obj* evObj = Tcl_NewStringObj (((mask & RANDW) == RANDW) ?
				       "read write" :
				       ((mask & TCL_READABLE) ?
					"read" :
					((mask & TCL_WRITABLE) ?
					 "write" : "")), -1);
    if (evObj == (Tcl_Obj*) NULL) {
        Tcl_Panic ("Out of memory in RcDecodeEventMask");
    }

    Tcl_IncrRefCount (evObj);
    return evObj;
}

/*
 *----------------------------------------------------------------------
 *
 * RcNew --
 *
 *	This function is invoked to allocate and initialize the
 *	instance data of a new reflected channel.
 *
 * Results:
 *	A heap-allocated channel instance.
 *
 * Side effects:
 *	Allocates memory.
 *
 *----------------------------------------------------------------------
 */

static ReflectingChannel*
RcNew (interp, cmdpfxObj, mode, id)
       Tcl_Interp* interp;
       Tcl_Obj*    cmdpfxObj;
       int         mode;
       Tcl_Obj*    id;
{
    ReflectingChannel* rcPtr;
    int                listc;
    Tcl_Obj**          listv;
    Tcl_Obj*           word;
    int                i;

    rcPtr = (ReflectingChannel*) ckalloc (sizeof(ReflectingChannel));

    /* rcPtr->chan    : Assigned by caller. Dummy data here. */
    /* rcPtr->methods : Assigned by caller. Dummy data here. */

    rcPtr->chan     = (Tcl_Channel) NULL;
    rcPtr->methods  = 0;
    rcPtr->interp   = interp;
#ifdef TCL_THREADS
    rcPtr->thread   = Tcl_GetCurrentThread ();
#endif
    rcPtr->mode     = mode;
    rcPtr->interest = 0; /* Initially no interest registered */

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

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

    for (i = 0; i < listc ; i++) {
        word = rcPtr->argv [i] = listv [i];
        Tcl_IncrRefCount (word);
    }

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

    rcPtr->argv [i] = id ; Tcl_IncrRefCount (id);

    /* The next two objects are kept empty, varying arguments */

    /* Initialization complete */
    return rcPtr;
}

/*
 *----------------------------------------------------------------------
 *
 * RcNewHandle --
 *
 *	This function is invoked to generate a channel handle for
 *	a new reflected channel.
 *
 * Results:
 *	A Tcl_Obj containing the string of the new channel handle.
 *	The refcount of the returned object is -- zero --.
 *
 * Side effects:
 *	May allocate memory. Mutex protected critical section
 *	locks out other threads for a short time.
 *
 *----------------------------------------------------------------------
 */

Tcl_Obj*
RcNewHandle ()
{
    /* Count number of generated reflected channels.  Used for id
     * generation. Ids are never reclaimed and there is no dealing
     * with wrap around. On the other hand, "unsigned long" should be
     * big enough except for absolute longrunners (generate a 100 ids
     * per second => overflow will occur in 1 1/3 years).
     */

#ifdef TCL_THREADS
    TCL_DECLARE_MUTEX (rcCounterMutex)
#endif
    static unsigned long rcCounter = 0;

    char     channelName [50];
    Tcl_Obj* res = Tcl_NewStringObj ("rc", -1);

#ifdef TCL_THREADS
    Tcl_MutexLock (&rcCounterMutex);
#endif

    sprintf (channelName, "%lu", (unsigned long) rcCounter);
    rcCounter ++;

#ifdef TCL_THREADS
    Tcl_MutexUnlock (&rcCounterMutex);
#endif

    Tcl_AppendStringsToObj (res, channelName, (char*) NULL);
    return res;
}


static void
RcFree (rcPtr)
     ReflectingChannel* rcPtr;
{
    Channel* chanPtr = (Channel*) rcPtr->chan;
    int      i, n;

    if (chanPtr->typePtr != &tclRChannelType) {
        /* Delete a cloned ChannelType structure. */
        ckfree ((char*) chanPtr->typePtr);
    }

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

    ckfree ((char*) rcPtr->argv);
    ckfree ((char*) rcPtr);
    return;
}

/*
 *----------------------------------------------------------------------
 *
 * RcInvokeTclMethod --
 *
 *	This function is used to invoke the Tcl level of a reflected
 *	channel. It handles all the command assembly, invokation, and
 *	generic state and result mgmt.
 *
 * Results:
 *      Result code and data as returned by the method.
 *
 * Side effects:
 *	Arbitrary, as it calls upo na Tcl script.
 *
 *----------------------------------------------------------------------
 */

static void
RcInvokeTclMethod (rcPtr, method, argone, argtwo, result, resultObj, capture)
     ReflectingChannel* rcPtr;
     CONST char*        method;
     Tcl_Obj*           argone;    /* NULL'able */
     Tcl_Obj*           argtwo;    /* NULL'able */
     int*               result;    /* NULL'able */
     Tcl_Obj**          resultObj; /* NULL'able */
     int                capture;
{
    /* Thread redirection was done by higher layers */
    /* ASSERT: Tcl_GetCurrentThread () == rcPtr->thread */

    int             cmdc;           /* #words in constructed command */
    Tcl_Obj*        methObj = NULL; /* Method name in object form */
    Tcl_InterpState sr;             /* State of handler interp */
    int             res;            /* Result code of method invokation */
    Tcl_Obj*        resObj  = NULL; /* Result of method invokation. */

    /* NOTE (5): Decide impl. issue: Cache objects with method names ?
     * NOTE (5): Requires TSD data as reflections can be created in
     * NOTE (5): many different threads.
     * NOTE (5): ---
     */

    /* Insert method into the pre-allocated area, after the command
     * prefix, before the channel id.
     */

    methObj = Tcl_NewStringObj (method, -1);
    if (methObj == (Tcl_Obj*) NULL) {
        Tcl_Panic ("Out of memory in RcInvokeTclMethod");
    }
    Tcl_IncrRefCount (methObj);
    rcPtr->argv [rcPtr->argc - 2] = methObj;

    /* Append the additional argument containing method specific
     * details behind the channel id. If specified.
     */

    cmdc = rcPtr->argc ;
    if (argone) {
        Tcl_IncrRefCount (argone);
	rcPtr->argv [cmdc] = argone;
	cmdc++;
    }
    if (argtwo) {
        Tcl_IncrRefCount (argtwo);
	rcPtr->argv [cmdc] = argtwo;
	cmdc++;
    }

    /* And run the handler ...  This is done in auch a manner which
     * leaves any existing state intact.
     */

    sr  = Tcl_SaveInterpState (rcPtr->interp, 0 /* Dummy */);
    res = Tcl_EvalObjv        (rcPtr->interp, cmdc, rcPtr->argv, TCL_EVAL_GLOBAL);

    /* We do not try to extract the result information if the caller has no
     * interest in it. I.e. there is no need to put effort into creating
     * something which is discarded immediately after.
     */

    if (resultObj) {
	if ((res == TCL_OK) || !capture) {
	    /* Ok result taken as is, also if the caller requests that there
	     * is no capture.
	     */

	    resObj = Tcl_GetObjResult (rcPtr->interp);
	} else {
	    /* Non-ok ressult is always treated as an error.
	     * We have to capture the full state of the result,
	     * including additional options.
	     */

	    res    = TCL_ERROR;
	    resObj = RcErrorMarshall (rcPtr->interp);
	}
	Tcl_IncrRefCount(resObj);
    }
    Tcl_RestoreInterpState (rcPtr->interp, sr);

    /* ... */

    /* Cleanup of the dynamic parts of the command */

    Tcl_DecrRefCount (methObj);
    if (argone) {Tcl_DecrRefCount (argone);}
    if (argtwo) {Tcl_DecrRefCount (argtwo);}

    /* The resObj has a ref count of 1 at this location.  This means
     * that the caller of RcInvoke has to dispose of it (but only if
     * it was returned to it).
     */

    if (result) {
        *result = res;
    }
    if (resultObj) {
        *resultObj = resObj;
    }
    /* There no need to handle the case where nothing is returned, because for
     * that case resObj was not set anyway.
     */
}

#ifdef TCL_THREADS
static void
RcForwardOp (rcPtr, op, dst, param)
  ReflectingChannel* rcPtr; /* Channel instance */
  RcOperation        op;    /* Forwarded driver operation */
  Tcl_ThreadId       dst;   /* Destination thread */
  CONST VOID*        param; /* Arguments */
{
    RcForwardingEvent*  evPtr;
    RcForwardingResult* resultPtr;
    int                 result;

    /* Create and initialize the event and data structures */

    evPtr     = (RcForwardingEvent*)  ckalloc (sizeof (RcForwardingEvent));
    resultPtr = (RcForwardingResult*) ckalloc (sizeof (RcForwardingResult));

    evPtr->event.proc = RcForwardProc;
    evPtr->resultPtr  = resultPtr;
    evPtr->op         = op;
    evPtr->rcPtr      = rcPtr;
    evPtr->param      = param;

    resultPtr->src    = Tcl_GetCurrentThread ();
    resultPtr->dst    = dst;
    resultPtr->done   = (Tcl_Condition) NULL;
    resultPtr->result = -1;
    resultPtr->evPtr  = evPtr;

    /* Now execute the forward */

    Tcl_MutexLock(&rcForwardMutex);
    TclSpliceIn(resultPtr, forwardList);

    /*
     * Ensure cleanup of the event if any of the two involved threads
     * exits while this event is pending or in progress.
     */

    Tcl_CreateThreadExitHandler(RcSrcExitProc, (ClientData) evPtr);
    Tcl_CreateThreadExitHandler(RcDstExitProc, (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.
     */

    while (resultPtr->result < 0) {
        /* NOTE (1): Is it possible that the current thread goes away while waiting here ?
	 * NOTE (1): IOW Is it possible that "RcSrcExitProc" is called while we are here ?
	 * NOTE (1): See complementary note (2) in "RcSrcExitProc"
	 * NOTE (1): ---
	 */

        Tcl_ConditionWait(&resultPtr->done, &rcForwardMutex, NULL);
    }

    /*
     * Unlink result from the forwarder list.
     */

    TclSpliceOut(resultPtr, forwardList);

    resultPtr->nextPtr  = NULL;
    resultPtr->prevPtr  = NULL;

    Tcl_MutexUnlock(&rcForwardMutex);
    Tcl_ConditionFinalize(&resultPtr->done);

    /*
     * Kill the cleanup handlers now, and the result structure as well,
     * before returning the success code.
     *
     * Note: The event structure has already been deleted.
     */

    Tcl_DeleteThreadExitHandler(RcSrcExitProc, (ClientData) evPtr);
    Tcl_DeleteThreadExitHandler(RcDstExitProc, (ClientData) evPtr);
    
    result =  resultPtr->result;
    ckfree ((char*) resultPtr);
}

static int
RcForwardProc (evGPtr, mask)
     Tcl_Event *evGPtr; 
     int mask;
{
    /* Notes regarding access to the referenced data.
     *
     * In principle the data belongs to the originating thread (see
     * evPtr->src), however this thread is currently blocked at (*),
     * i.e. quiescent. Because of this we can treat the data as
     * belonging to us, without fear of race conditions. I.e. we can
     * read and write as we like.
     *
     * The only thing we cannot be sure of is the resultPtr. This can be
     * be NULLed if the originating thread went away while the event
     * is handled here now.
     */

    RcForwardingEvent*  evPtr     = (RcForwardingEvent*) evGPtr;
    RcForwardingResult* resultPtr = evPtr->resultPtr;
    ReflectingChannel*  rcPtr     = evPtr->rcPtr;
    Tcl_Interp*         interp    = rcPtr->interp;
    RcForwardParamBase* paramPtr  = (RcForwardParamBase*) evPtr->param;
    int                 res       = TCL_OK; /* Result code   of RcInvokeTclMethod */
    Tcl_Obj*            resObj    = NULL;   /* Interp result of RcInvokeTclMethod */

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

    if (!resultPtr) {
        return 1;
    }

    paramPtr->code = TCL_OK;
    paramPtr->msg  = NULL;
    paramPtr->vol  = 0;

    switch (evPtr->op) {
      /* The destination thread for the following operations is
       * rcPtr->thread, which contains rcPtr->interp, the interp
       * we have to call upon for the driver.
       */

    case RcOpClose:
      {
	  /* No parameters/results */
	  RcInvokeTclMethod (rcPtr, "finalize", NULL, NULL,
			     &res, &resObj, DO_CAPTURE);

	  if (res != TCL_OK) {
	     RcForwardSetObjError (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
	   */

	  RcFree (rcPtr);
      }
      break;

    case RcOpInput:
      {
	  RcForwardParamInput* p = (RcForwardParamInput*) paramPtr;
	  Tcl_Obj*     toReadObj = Tcl_NewIntObj (p->toRead);

	  if (toReadObj == (Tcl_Obj*) NULL) {
	      Tcl_Panic ("Out of memory in RcInput");
	  }

	  RcInvokeTclMethod (rcPtr, "read", toReadObj, NULL,
			     &res, &resObj, DO_CAPTURE);

	  if (res != TCL_OK) {
	      RcForwardSetObjError (paramPtr, resObj);
	      p->toRead = -1;
	  } else {
	      /* Process a regular result. */

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

	      bytev = Tcl_GetByteArrayFromObj(resObj, &bytec);

	      if (p->toRead < bytec) {
		  RcForwardSetStaticError (paramPtr, msg_read_toomuch);
		  p->toRead   = -1;

	      } else {
	          if (bytec > 0) {
		      memcpy (p->buf, bytev, bytec);
		  }

		  p->toRead = bytec;
	      }
	  }
      }
      break;

    case RcOpOutput:
      {
	  RcForwardParamOutput* p = (RcForwardParamOutput*) paramPtr;
	  Tcl_Obj*         bufObj = Tcl_NewByteArrayObj((unsigned char*) p->buf, p->toWrite);

	  if (bufObj == (Tcl_Obj*) NULL) {
	      Tcl_Panic ("Out of memory in RcOutput");
	  }

	  RcInvokeTclMethod (rcPtr, "write", bufObj, NULL,
			     &res, &resObj, DO_CAPTURE);

	  if (res != TCL_OK) {
	      RcForwardSetObjError (paramPtr, resObj);
	      p->toWrite = -1;
	  } else {
	      /* Process a regular result. */

	      int written;

	      res = Tcl_GetIntFromObj (interp, resObj, &written);
	      if (res != TCL_OK) {

		  RcForwardSetObjError (paramPtr, RcErrorMarshall (interp));
		  p->toWrite = -1;

	      } else if ((written == 0) || (p->toWrite < written)) {

		  RcForwardSetStaticError (paramPtr, msg_write_toomuch);
		  p->toWrite = -1;

	      } else {
		  p->toWrite = written;
	      }
	  }
      }
      break;

    case RcOpSeek:
      {
	  RcForwardParamSeek* p = (RcForwardParamSeek*) paramPtr;

	  Tcl_Obj*       offObj;
	  Tcl_Obj*       baseObj;

	  offObj = Tcl_NewWideIntObj(p->offset);
	  if (offObj == (Tcl_Obj*) NULL) {
	      Tcl_Panic ("Out of memory in RcSeekWide");
	  }

	  baseObj = Tcl_NewStringObj((p->seekMode == SEEK_SET) ?
				     "start" :
				     ((p->seekMode == SEEK_CUR) ?
				      "current" :
				      "end"), -1);

	  if (baseObj == (Tcl_Obj*) NULL) {
	      Tcl_Panic ("Out of memory in RcSeekWide");
	  }

	  RcInvokeTclMethod (rcPtr, "seek", offObj, baseObj,
			     &res, &resObj, DO_CAPTURE);

	  if (res != TCL_OK) {
	      RcForwardSetObjError (paramPtr, resObj);
	      p->offset = -1;
	  } else {
	      /* Process a regular result. If the type is wrong this
	       * may change into an error.
	       */

	      Tcl_WideInt newLoc;
	      res = Tcl_GetWideIntFromObj (interp, resObj, &newLoc);

	      if (res == TCL_OK) {
		  if (newLoc < Tcl_LongAsWide (0)) {
		      RcForwardSetStaticError (paramPtr, msg_seek_beforestart);
		      p->offset = -1;
		  } else {
		      p->offset = newLoc;
		  }
	      } else {
		  RcForwardSetObjError (paramPtr, RcErrorMarshall (interp));
		  p->offset = -1;
	      }
	  }
      }
      break;

    case RcOpWatch:
      {
	  RcForwardParamWatch* p = (RcForwardParamWatch*) paramPtr;

	  Tcl_Obj* maskObj = RcDecodeEventMask (p->mask);
	  RcInvokeTclMethod (rcPtr, "watch", maskObj, NULL,
			     NULL, NULL, NO_CAPTURE);
	  Tcl_DecrRefCount (maskObj);
      }
    break;

    case RcOpBlock:
      {
	  RcForwardParamBlock* p = (RcForwardParamBlock*) evPtr->param;
	  Tcl_Obj*      blockObj = Tcl_NewBooleanObj(!p->nonblocking);

	  if (blockObj == (Tcl_Obj*) NULL) {
	      Tcl_Panic ("Out of memory in RcBlock");
	  }

	  RcInvokeTclMethod (rcPtr, "blocking", blockObj, NULL,
			     &res, &resObj, DO_CAPTURE);

	  if (res != TCL_OK) {
	      RcForwardSetObjError (paramPtr, resObj);
	  }
      }
      break;

    case RcOpSetOpt:
      {
	  RcForwardParamSetOpt* p = (RcForwardParamSetOpt*) paramPtr;
	  Tcl_Obj* optionObj;
	  Tcl_Obj* valueObj;

	  optionObj = Tcl_NewStringObj(p->name,-1);
	  if (optionObj == (Tcl_Obj*) NULL) {
	      Tcl_Panic ("Out of memory in RcSetOption");
	  }

	  valueObj = Tcl_NewStringObj(p->value,-1);
	  if (valueObj == (Tcl_Obj*) NULL) {
	      Tcl_Panic ("Out of memory in RcSetOption");
	  }

	  RcInvokeTclMethod (rcPtr, "configure", optionObj, valueObj,
			     &res, &resObj, DO_CAPTURE);

	  if (res != TCL_OK) {
	      RcForwardSetObjError (paramPtr, resObj);
	  }
      }
      break;

    case RcOpGetOpt:
      {
	  /* Retrieve the value of one option */

	  RcForwardParamGetOpt* p = (RcForwardParamGetOpt*) paramPtr;
	  Tcl_Obj*           optionObj;

	  optionObj = Tcl_NewStringObj(p->name,-1);
	  if (optionObj == (Tcl_Obj*) NULL) {
	      Tcl_Panic ("Out of memory in RcGetOption");
	  }

	  RcInvokeTclMethod (rcPtr, "cget", optionObj, NULL,
			     &res, &resObj, DO_CAPTURE);

	  if (res != TCL_OK) {
	      RcForwardSetObjError (paramPtr, resObj);
	  } else {
	      Tcl_DStringAppend (p->value, Tcl_GetString (resObj), -1);
	  }
      }
      break;

    case RcOpGetOptAll:
      {
	  /* Retrieve all options. */

	  RcForwardParamGetOpt* p = (RcForwardParamGetOpt*) paramPtr;

	  RcInvokeTclMethod (rcPtr, "cgetall", NULL, NULL,
			     &res, &resObj, DO_CAPTURE);

	  if (res != TCL_OK) {
	      RcForwardSetObjError (paramPtr, resObj);
	  } else {
	      /* Extract list, validate that it is a list, and
	       * #elements. See NOTE (4) as well.
	       */

	      int       listc;
	      Tcl_Obj** listv;

	      res = Tcl_ListObjGetElements (interp, resObj, &listc, &listv);
	      if (res != TCL_OK) {
		  RcForwardSetObjError (paramPtr, RcErrorMarshall (interp));

	      } else if ((listc % 2) == 1) {
	          /* Odd number of elements is wrong.
		   * [x].
		   */

	          char* buf = ckalloc (200);
		  sprintf (buf,
			   "{Expected list with even number of elements, got %d %s instead}",
			   listc,
			   (listc == 1 ? "element" : "elements"));
		  
		  RcForwardSetDynError (paramPtr, buf);
	      } else {
		  int len;
		  char* str = Tcl_GetStringFromObj (resObj, &len);

		  if (len) {
		      Tcl_DStringAppend (p->value, " ", 1);
		      Tcl_DStringAppend (p->value, str, len);
		  }
	      }
	  }
      }
      break;

    default:
      /* Bad operation code */
      Tcl_Panic ("Bad operation code in RcForwardProc");
      break;
    }

    /* Remove the reference we held on the result of the invoke, if we had
     * such
     */
    if (resObj != NULL) {
	Tcl_DecrRefCount (resObj);
    }

    if (resultPtr) {
        /*
	 * Report the forwarding result synchronously to the waiting
	 * caller. This unblocks (*) as well. This is wrapped into a
	 * conditional because the caller may have exited in the mean
	 * time.
	 */

        Tcl_MutexLock(&rcForwardMutex);
	resultPtr->result = TCL_OK;
	Tcl_ConditionNotify(&resultPtr->done);
	Tcl_MutexUnlock(&rcForwardMutex);
    }

    return 1;
}


static void
RcSrcExitProc (clientData)
     ClientData clientData;
{
  RcForwardingEvent*  evPtr = (RcForwardingEvent*) clientData;
  RcForwardingResult* resultPtr;
  RcForwardParamBase* paramPtr;

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

  /* The originator for the event exited. It is not sure if this
   * can happen, as the originator should be blocked at (*) while
   * the event is in transit/pending.
   */

  /*
   * We make sure that the event cannot refer to the result anymore,
   * remove it from the list of pending results and free the
   * structure. Locking the access ensures that we cannot get in
   * conflict with "RcForwardProc", should it already execute the
   * event.
   */

  Tcl_MutexLock(&rcForwardMutex);

  resultPtr = evPtr->resultPtr;
  paramPtr  = (RcForwardParamBase*) evPtr->param;

  evPtr->resultPtr  = NULL;
  resultPtr->evPtr  = NULL;
  resultPtr->result = TCL_ERROR;

  RcForwardSetStaticError (paramPtr, msg_send_originlost);

  /* See below: TclSpliceOut(resultPtr, forwardList); */

  Tcl_MutexUnlock(&rcForwardMutex);

  /*
   * This unlocks (*). The structure will be spliced out and freed by
   * "RcForwardProc". Maybe.
   */

  Tcl_ConditionNotify(&resultPtr->done);
}


static void
RcDstExitProc (clientData)
     ClientData clientData;
{
  RcForwardingEvent*  evPtr     = (RcForwardingEvent*) clientData;
  RcForwardingResult* resultPtr = evPtr->resultPtr;
  RcForwardParamBase* paramPtr  = (RcForwardParamBase*) evPtr->param;

  /* NOTE (3): It is not clear if the event still exists when this handler is called..
   * NOTE (3): We might have to use 'resultPtr' as our clientData instead.
   * NOTE (3): ---
   */

  /* The receiver for the event exited, before processing the
   * event. We detach the result now, wake the originator up
   * and signal failure.
   */

  evPtr->resultPtr = NULL;
  resultPtr->evPtr  = NULL;
  resultPtr->result = TCL_ERROR;

  RcForwardSetStaticError (paramPtr, msg_send_dstlost);

  Tcl_ConditionNotify(&resultPtr->done);
}


static void
RcForwardSetObjError (p,obj)
     RcForwardParamBase* p;
     Tcl_Obj*            obj;
{
    int   len;
    char* msg;

    msg = Tcl_GetStringFromObj (obj, &len);

    p->code = TCL_ERROR;
    p->vol  = 1;
    p->msg  = strcpy(ckalloc (1+len), msg);
}
#endif

/*
 * Local Variables:
 * mode: c
 * c-basic-offset: 4
 * fill-column: 78
 * End:
 */

 * Copyright (c) 1994-1998 Sun Microsystems, Inc.
 * Copyright (c) 1998-19/99 by Scriptics Corporation.
 * Copyright (c) 2001, 2002 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: tclInt.h,v 1.202.2.34 2005/08/25 15:46:31 dgp Exp $
 */

#ifndef _TCLINT
#define _TCLINT

/*
 * Some numerics configuration options

				 * we're not processing an ensemble. */
	int numRemovedObjs;	/* How many arguments have been stripped off
				 * because of ensemble processing. */
	int numInsertedObjs;	/* How many of the current arguments were
				 * inserted by an ensemble. */
    } ensembleRewrite;

    /* TIP #219 ... Global info for the I/O system ...
     * Error message set by channel drivers, for the propagation of
     * arbitrary Tcl errors. This information, if present (chanMsg not
     * NULL), takes precedence over a posix error code returned by a
     * channel operation.
     */

    Tcl_Obj* chanMsg;

    /*
     * Statistical information about the bytecode compiler and interpreter's
     * operation.
     */

#ifdef TCL_COMPILE_STATS
    ByteCodeStats stats;	/* Holds compilation and execution
				 * statistics for this interpreter. */
#endif /* TCL_COMPILE_STATS */	  
} Interp;

/*
 * General list of interpreters. Doubly linked for easier
 * removal of items deep in the list.
 */

typedef struct InterpList {
   Interp* interpPtr;
   struct InterpList* prevPtr;
   struct InterpList* nextPtr;
} InterpList;

/*
 * Macros for splicing into and out of doubly linked lists.
 * They assume existence of struct items 'prevPtr' and 'nextPtr'.
 *
 * a = element to add or remove.
 * b = list head.
 *
 * TclSpliceIn adds to the head of the list.
 */

#define TclSpliceIn(a,b)                       \
    (a)->nextPtr = (b);                        \
    if ((b) != NULL)                           \
        (b)->prevPtr = (a);                    \
    (a)->prevPtr = NULL, (b) = (a);

#define TclSpliceOut(a,b)                      \
    if ((a)->prevPtr != NULL)                  \
        (a)->prevPtr->nextPtr = (a)->nextPtr;  \
    else                                       \
        (b) = (a)->nextPtr;                    \
    if ((a)->nextPtr != NULL)                  \
        (a)->nextPtr->prevPtr = (a)->prevPtr;


/*
 * EvalFlag bits for Interp structures:
 *
 * TCL_ALLOW_EXCEPTIONS	1 means it's OK for the script to terminate with
 *			a code other than TCL_OK or TCL_ERROR;	0 means
 *			codes other than these should be turned into errors.

			    Tcl_Interp *interp, Tcl_Obj *objPtr));
MODULE_SCOPE int	TclArraySet _ANSI_ARGS_((Tcl_Interp *interp,
			    Tcl_Obj *arrayNameObj, Tcl_Obj *arrayElemObj));
MODULE_SCOPE double     TclBignumToDouble _ANSI_ARGS_((mp_int* bignum));
MODULE_SCOPE double	TclCeil _ANSI_ARGS_((mp_int* a));
MODULE_SCOPE int	TclCheckBadOctal _ANSI_ARGS_((Tcl_Interp *interp,
			    CONST char *value));
MODULE_SCOPE int        TclChanCreateObjCmd _ANSI_ARGS_((ClientData clientData,
			    Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]));
MODULE_SCOPE int        TclChanPostEventObjCmd _ANSI_ARGS_((ClientData clientData,
			    Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]));
MODULE_SCOPE int        TclChanCaughtErrorBypass _ANSI_ARGS_((Tcl_Interp *interp,
			    Tcl_Channel chan));
MODULE_SCOPE void	TclCleanupLiteralTable _ANSI_ARGS_((
			    Tcl_Interp* interp, LiteralTable* tablePtr));
MODULE_SCOPE int	TclDoubleDigits _ANSI_ARGS_((char* buf,
						     double value,
						     int* signum));
MODULE_SCOPE void	TclExpandTokenArray _ANSI_ARGS_((
			    Tcl_Parse *parsePtr));

 * Copyright (c) 1999 by Scriptics Corporation.
 * Copyright (c) 2001 by ActiveState Corporation.
 * Copyright (c) 2005 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: tclObj.c,v 1.72.2.31 2005/08/25 15:46:31 dgp Exp $
 */

#include "tclInt.h"
#include "tommath.h"
#include <float.h>

#define BIGNUM_AUTO_NARROW 1

    (objPtrVar) = (contextPtr)->deletionStack; \
    (contextPtr)->deletionStack = (Tcl_Obj *) (objPtrVar)->bytes

/*
 * Macro to set up the local reference to the deletion context.
 */
#ifndef TCL_THREADS
static PendingObjData pendingObjData;
#define ObjInitDeletionContext(contextPtr) \
    PendingObjData *CONST contextPtr = &pendingObjData
#else
Tcl_ThreadDataKey pendingObjDataKey;
#define ObjInitDeletionContext(contextPtr) \
    PendingObjData *CONST contextPtr = (PendingObjData *) \
	    Tcl_GetThreadData(&pendingObjDataKey, sizeof(PendingObjData))

/* 
 * tclStubInit.c --
 *
 *	This file contains the initializers for the Tcl stub vectors.
 *
 * 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: tclStubInit.c,v 1.109.2.16 2005/08/25 15:46:31 dgp Exp $



 */

#include "tclInt.h"

/*
 * Remove macros that will interfere with the definitions below.
 */

    Tcl_ChannelThreadActionProc, /* 554 */
    Tcl_NewBignumObj, /* 555 */
    Tcl_DbNewBignumObj, /* 556 */
    Tcl_SetBignumObj, /* 557 */
    Tcl_GetBignumFromObj, /* 558 */
    Tcl_TruncateChannel, /* 559 */
    Tcl_ChannelTruncateProc, /* 560 */
    Tcl_SetChannelErrorInterp, /* 561 */
    Tcl_GetChannelErrorInterp, /* 562 */
    Tcl_SetChannelError, /* 563 */
    Tcl_GetChannelError, /* 564 */
};

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

 * Copyright (c) 1994-1997 Sun Microsystems, Inc.
 * Copyright (c) 1998-2000 Ajuba Solutions.
 * Copyright (c) 2003 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: tclTest.c,v 1.86.2.6 2005/08/25 15:46:31 dgp Exp $
 */

#define TCL_TEST
#include "tclInt.h"

/*
 * Required for Testregexp*Cmd

 */
typedef struct TestEvent {
    Tcl_Event header;		/* Header common to all events */
    Tcl_Interp* interp;		/* Interpreter that will handle the event */
    Tcl_Obj* command;		/* Command to evaluate when the event occurs */
    Tcl_Obj* tag;		/* Tag for this event used to delete it */
} TestEvent;


/*
 * Simple detach/attach facility for testchannel cut|splice.
 * Allow testing of channel transfer in core testsuite.
 */

typedef struct TestChannel {
    Tcl_Channel         chan;    /* Detached channel */
    struct TestChannel* nextPtr; /* Next in pool of detached channels */
} TestChannel;

static TestChannel* firstDetached;


/*
 * Forward declarations for procedures defined later in this file:
 */

int			Tcltest_Init _ANSI_ARGS_((Tcl_Interp *interp));
static int		AsyncHandlerProc _ANSI_ARGS_((ClientData clientData,

    }
    cmdName = argv[1];
    len = strlen(cmdName);

    chanPtr = (Channel *) NULL;

    if (argc > 2) {
        if ((cmdName[0] == 's') && (strncmp(cmdName, "splice", len) == 0)) {
	    /* For splice access the pool of detached channels.
	     * Locate channel, remove from the list.
	     */

	    TestChannel** nextPtrPtr;
	    TestChannel*  curPtr;

	    chan = (Tcl_Channel) NULL;
	    for (nextPtrPtr = &firstDetached, curPtr = firstDetached;
		 curPtr != NULL;
		 nextPtrPtr = &(curPtr->nextPtr), curPtr = curPtr->nextPtr) {

	        if (strcmp (argv[2], Tcl_GetChannelName (curPtr->chan)) == 0) {
		    *nextPtrPtr    = curPtr->nextPtr;
		    curPtr->nextPtr = NULL;
		    chan = curPtr->chan;
		    ckfree ((char*) curPtr);
		    break;
		}
	    }
	} else {
	    chan = Tcl_GetChannel(interp, argv[2], &mode);
	}
	if (chan == (Tcl_Channel) NULL) {
	    return TCL_ERROR;
	}
        chanPtr		= (Channel *) chan;
	statePtr	= chanPtr->state;
        chanPtr		= statePtr->topChanPtr;
	chan		= (Tcl_Channel) chanPtr;
    } else {
	/* lint */
	statePtr	= NULL;
	chan		= NULL;
    }

    if ((cmdName[0] == 's') && (strncmp(cmdName, "setchannelerror", len) == 0)) {

	Tcl_Obj* msg = Tcl_NewStringObj (argv [3],-1);

	Tcl_IncrRefCount (msg);
	Tcl_SetChannelError (chan, msg);
	Tcl_DecrRefCount (msg);

	Tcl_GetChannelError (chan, &msg);
	Tcl_SetObjResult (interp, msg);
	Tcl_DecrRefCount (msg);
	return TCL_OK;
    }
    if ((cmdName[0] == 's') && (strncmp(cmdName, "setchannelerrorinterp", len) == 0)) {

	Tcl_Obj* msg = Tcl_NewStringObj (argv [3],-1);

	Tcl_IncrRefCount (msg);
	Tcl_SetChannelErrorInterp (interp, msg);
	Tcl_DecrRefCount (msg);

	Tcl_GetChannelErrorInterp (interp, &msg);
	Tcl_SetObjResult (interp, msg);
	Tcl_DecrRefCount (msg);
	return TCL_OK;
    }

    /*
     * "cut" is actually more a simplified detach facility as provided
     * by the Thread package. Without the safeguards of a regular
     * command (no checking that the command is truly cut'able, no
     * mutexes for thread-safety). Its complementary command is
     * "splice", see below.
     */

    if ((cmdName[0] == 'c') && (strncmp(cmdName, "cut", len) == 0)) {
        TestChannel* det;

        if (argc != 3) {
            Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
                    " cut channelName\"", (char *) NULL);
            return TCL_ERROR;
        }

	Tcl_RegisterChannel((Tcl_Interp *) NULL, chan); /* prevent closing */
	Tcl_UnregisterChannel(interp, chan);

        Tcl_CutChannel(chan);

	/* Remember the channel in the pool of detached channels */

	det = (TestChannel*) ckalloc (sizeof(TestChannel));
	det->chan     = chan;
	det->nextPtr  = firstDetached;
	firstDetached = det;

        return TCL_OK;
    }

    if ((cmdName[0] == 'c') &&
	    (strncmp(cmdName, "clearchannelhandlers", len) == 0)) {
        if (argc != 3) {
            Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],

        }
        
        TclFormatInt(buf, statePtr->refCount);
        Tcl_AppendResult(interp, buf, (char *) NULL);
        return TCL_OK;
    }

    /*
     * "splice" is actually more a simplified attach facility as
     * provided by the Thread package. Without the safeguards of a
     * regular command (no checking that the command is truly
     * cut'able, no mutexes for thread-safety). Its complementary
     * command is "cut", see above.
     */

    if ((cmdName[0] == 's') && (strncmp(cmdName, "splice", len) == 0)) {
        if (argc != 3) {
            Tcl_AppendResult(interp, "channel name required", (char *) NULL);
            return TCL_ERROR;
        }

        Tcl_SpliceChannel(chan);

	Tcl_RegisterChannel(interp, chan);
	Tcl_UnregisterChannel((Tcl_Interp *)NULL, chan);

        return TCL_OK;
    }

    if ((cmdName[0] == 't') && (strncmp(cmdName, "type", len) == 0)) {
        if (argc != 3) {
            Tcl_AppendResult(interp, "channel name required",
                    (char *) NULL);

	    total += val;
	}
	TclFormatInt(buf, total);
	Tcl_SetResult(interp, buf, TCL_VOLATILE);
	return TCL_OK;
    }
}

/*
 * Local Variables:
 * mode: c
 * c-basic-offset: 4
 * fill-column: 78
 * End:
 */

/* 
 * tclThreadTest.c --
 *
 *	This file implements the testthread command.  Eventually this
 *	should be tclThreadCmd.c
 *	Some of this code is based on work done by Richard Hipp on behalf of
 *	Conservation Through Innovation, Limited, with their permission.
 *
 * Copyright (c) 1998 by 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: tclThreadTest.c,v 1.17.2.2 2005/08/25 15:46:31 dgp Exp $
 */

#include "tclInt.h"

#ifdef TCL_THREADS
/*
 * Each thread has an single instance of the following structure.  There

     * Initialize the interpreter.  This should be more general.
     */

    tsdPtr->interp = Tcl_CreateInterp();
    result = Tcl_Init(tsdPtr->interp);
    result = TclThread_Init(tsdPtr->interp);

    /* This is part of the test facility.
     * Initialize _ALL_ test commands for
     * use by the new thread.
     */
    result = Tcltest_Init(tsdPtr->interp);

    /*
     * Update the list of threads.
     */

    Tcl_MutexLock(&threadMutex);
    ListUpdateInner(tsdPtr);
    /*

# init.tcl --
#
# Default system startup file for Tcl-based applications.  Defines
# "unknown" procedure and auto-load facilities.
#
# RCS: @(#) $Id: init.tcl,v 1.69.2.5 2005/08/25 15:46:31 dgp Exp $
#
# Copyright (c) 1991-1993 The Regents of the University of California.
# Copyright (c) 1994-1996 Sun Microsystems, Inc.
# Copyright (c) 1998-1999 Scriptics Corporation.
# Copyright (c) 2004 by Kevin B. Kenny.  All rights reserved.
#
# See the file "license.terms" for information on usage and redistribution

    variable Path [unsupported::EncodingDirs]
    set Dir [file join $::tcl_library encoding]
    if {$Dir ni $Path} {
	lappend Path $Dir
	unsupported::EncodingDirs $Path
    }

    # Set up the 'chan' ensemble (TIP #208).
    namespace eval chan {
        # TIP #219. Added methods: create, postevent.
        namespace ensemble create -command ::chan -map {
            blocked     ::fblocked
            close       ::close
            configure   ::fconfigure
            copy        ::fcopy
            create      ::tcl::chan::rCreate
            eof         ::eof
            event       ::fileevent
            flush       ::flush
            gets        ::gets
            names       {::file channels}
            postevent   ::tcl::chan::rPostevent
            puts        ::puts
            read        ::read
            seek        ::seek
            tell        ::tell
            truncate    ::tcl::chan::Truncate
        }
    }
}

# Windows specific end of initialization

if {(![interp issafe]) && ($tcl_platform(platform) eq "windows")} {
    namespace eval tcl {

# created by tools/loadICU.tcl -- do not edit
namespace eval ::tcl::clock {
    ::msgcat::mcset af_ZA DATE_FORMAT "%d %B %Y"
    ::msgcat::mcset af_ZA TIME_FORMAT_12 "%l:%M:%S %P"
    ::msgcat::mcset af_ZA DATE_TIME_FORMAT "%d %B %Y %l:%M:%S %P %z"
}

# created by tools/loadICU.tcl -- do not edit
namespace eval ::tcl::clock {
    ::msgcat::mcset ar_IN DATE_FORMAT "%A %d %B %Y"
    ::msgcat::mcset ar_IN TIME_FORMAT_12 "%I:%M:%S  %z"
    ::msgcat::mcset ar_IN DATE_TIME_FORMAT "%A %d %B %Y %I:%M:%S  %z %z"
}

# created by tools/loadICU.tcl -- do not edit
namespace eval ::tcl::clock {
    ::msgcat::mcset ar_JO DAYS_OF_WEEK_ABBREV [list \
        "\u0627\u0644\u0623\u062d\u062f"\
        "\u0627\u0644\u0627\u062b\u0646\u064a\u0646"\
        "\u0627\u0644\u062b\u0644\u0627\u062b\u0627\u0621"\
        "\u0627\u0644\u0623\u0631\u0628\u0639\u0627\u0621"\
        "\u0627\u0644\u062e\u0645\u064a\u0633"\
        "\u0627\u0644\u062c\u0645\u0639\u0629"\
        "\u0627\u0644\u0633\u0628\u062a"]
    ::msgcat::mcset ar_JO MONTHS_ABBREV [list \
        "\u0643\u0627\u0646\u0648\u0646 \u0627\u0644\u062b\u0627\u0646\u064a"\
        "\u0634\u0628\u0627\u0637"\
        "\u0622\u0630\u0627\u0631"\
        "\u0646\u064a\u0633\u0627\u0646"\
        "\u0646\u0648\u0627\u0631"\
        "\u062d\u0632\u064a\u0631\u0627\u0646"\
        "\u062a\u0645\u0648\u0632"\
        "\u0622\u0628"\
        "\u0623\u064a\u0644\u0648\u0644"\
        "\u062a\u0634\u0631\u064a\u0646 \u0627\u0644\u0623\u0648\u0644"\
        "\u062a\u0634\u0631\u064a\u0646 \u0627\u0644\u062b\u0627\u0646\u064a"\
        "\u0643\u0627\u0646\u0648\u0646 \u0627\u0644\u0623\u0648\u0644"\
        ""]
    ::msgcat::mcset ar_JO MONTHS_FULL [list \
        "\u0643\u0627\u0646\u0648\u0646 \u0627\u0644\u062b\u0627\u0646\u064a"\
        "\u0634\u0628\u0627\u0637"\
        "\u0622\u0630\u0627\u0631"\
        "\u0646\u064a\u0633\u0627\u0646"\
        "\u0646\u0648\u0627\u0631"\
        "\u062d\u0632\u064a\u0631\u0627\u0646"\
        "\u062a\u0645\u0648\u0632"\
        "\u0622\u0628"\
        "\u0623\u064a\u0644\u0648\u0644"\
        "\u062a\u0634\u0631\u064a\u0646 \u0627\u0644\u0623\u0648\u0644"\
        "\u062a\u0634\u0631\u064a\u0646 \u0627\u0644\u062b\u0627\u0646\u064a"\
        "\u0643\u0627\u0646\u0648\u0646 \u0627\u0644\u0623\u0648\u0644"\
        ""]
}

# created by tools/loadICU.tcl -- do not edit
namespace eval ::tcl::clock {
    ::msgcat::mcset ar_LB DAYS_OF_WEEK_ABBREV [list \
        "\u0627\u0644\u0623\u062d\u062f"\
        "\u0627\u0644\u0627\u062b\u0646\u064a\u0646"\
        "\u0627\u0644\u062b\u0644\u0627\u062b\u0627\u0621"\
        "\u0627\u0644\u0623\u0631\u0628\u0639\u0627\u0621"\
        "\u0627\u0644\u062e\u0645\u064a\u0633"\
        "\u0627\u0644\u062c\u0645\u0639\u0629"\
        "\u0627\u0644\u0633\u0628\u062a"]
    ::msgcat::mcset ar_LB MONTHS_ABBREV [list \
        "\u0643\u0627\u0646\u0648\u0646 \u0627\u0644\u062b\u0627\u0646\u064a"\
        "\u0634\u0628\u0627\u0637"\
        "\u0622\u0630\u0627\u0631"\
        "\u0646\u064a\u0633\u0627\u0646"\
        "\u0646\u0648\u0627\u0631"\
        "\u062d\u0632\u064a\u0631\u0627\u0646"\
        "\u062a\u0645\u0648\u0632"\
        "\u0622\u0628"\
        "\u0623\u064a\u0644\u0648\u0644"\
        "\u062a\u0634\u0631\u064a\u0646 \u0627\u0644\u0623\u0648\u0644"\
        "\u062a\u0634\u0631\u064a\u0646 \u0627\u0644\u062b\u0627\u0646\u064a"\
        "\u0643\u0627\u0646\u0648\u0646 \u0627\u0644\u0623\u0648\u0644"\
        ""]
    ::msgcat::mcset ar_LB MONTHS_FULL [list \
        "\u0643\u0627\u0646\u0648\u0646 \u0627\u0644\u062b\u0627\u0646\u064a"\
        "\u0634\u0628\u0627\u0637"\
        "\u0622\u0630\u0627\u0631"\
        "\u0646\u064a\u0633\u0627\u0646"\
        "\u0646\u0648\u0627\u0631"\
        "\u062d\u0632\u064a\u0631\u0627\u0646"\
        "\u062a\u0645\u0648\u0632"\
        "\u0622\u0628"\
        "\u0623\u064a\u0644\u0648\u0644"\
        "\u062a\u0634\u0631\u064a\u0646 \u0627\u0644\u0623\u0648\u0644"\
        "\u062a\u0634\u0631\u064a\u0646 \u0627\u0644\u062b\u0627\u0646\u064a"\
        "\u0643\u0627\u0646\u0648\u0646 \u0627\u0644\u0623\u0648\u0644"\
        ""]
}

# created by tools/loadICU.tcl -- do not edit
namespace eval ::tcl::clock {
    ::msgcat::mcset ar_SY DAYS_OF_WEEK_ABBREV [list \
        "\u0627\u0644\u0623\u062d\u062f"\
        "\u0627\u0644\u0627\u062b\u0646\u064a\u0646"\
        "\u0627\u0644\u062b\u0644\u0627\u062b\u0627\u0621"\
        "\u0627\u0644\u0623\u0631\u0628\u0639\u0627\u0621"\
        "\u0627\u0644\u062e\u0645\u064a\u0633"\
        "\u0627\u0644\u062c\u0645\u0639\u0629"\
        "\u0627\u0644\u0633\u0628\u062a"]
    ::msgcat::mcset ar_SY MONTHS_ABBREV [list \
        "\u0643\u0627\u0646\u0648\u0646 \u0627\u0644\u062b\u0627\u0646\u064a"\
        "\u0634\u0628\u0627\u0637"\
        "\u0622\u0630\u0627\u0631"\
        "\u0646\u064a\u0633\u0627\u0646"\
        "\u0646\u0648\u0627\u0631"\
        "\u062d\u0632\u064a\u0631\u0627\u0646"\
        "\u062a\u0645\u0648\u0632"\
        "\u0622\u0628"\
        "\u0623\u064a\u0644\u0648\u0644"\
        "\u062a\u0634\u0631\u064a\u0646 \u0627\u0644\u0623\u0648\u0644"\
        "\u062a\u0634\u0631\u064a\u0646 \u0627\u0644\u062b\u0627\u0646\u064a"\
        "\u0643\u0627\u0646\u0648\u0646 \u0627\u0644\u0623\u0648\u0644"\
        ""]
    ::msgcat::mcset ar_SY MONTHS_FULL [list \
        "\u0643\u0627\u0646\u0648\u0646 \u0627\u0644\u062b\u0627\u0646\u064a"\
        "\u0634\u0628\u0627\u0637"\
        "\u0622\u0630\u0627\u0631"\
        "\u0646\u064a\u0633\u0627\u0646"\
        "\u0646\u0648\u0627\u0631\u0627\u0646"\
        "\u062d\u0632\u064a\u0631"\
        "\u062a\u0645\u0648\u0632"\
        "\u0622\u0628"\
        "\u0623\u064a\u0644\u0648\u0644"\
        "\u062a\u0634\u0631\u064a\u0646 \u0627\u0644\u0623\u0648\u0644"\
        "\u062a\u0634\u0631\u064a\u0646 \u0627\u0644\u062b\u0627\u0646\u064a"\
        "\u0643\u0627\u0646\u0648\u0646 \u0627\u0644\u0623\u0648\u0644"\
        ""]
}

# created by tools/loadICU.tcl -- do not edit
namespace eval ::tcl::clock {
    ::msgcat::mcset bn_IN DATE_FORMAT "%A %d %b %Y"
    ::msgcat::mcset bn_IN TIME_FORMAT_12 "%I:%M:%S  %z"
    ::msgcat::mcset bn_IN DATE_TIME_FORMAT "%A %d %b %Y %I:%M:%S  %z %z"
}

# created by tools/loadICU.tcl -- do not edit
namespace eval ::tcl::clock {
    ::msgcat::mcset de_AT MONTHS_ABBREV [list \
        "J\u00e4n"\
        "Feb"\
        "M\u00e4r"\
        "Apr"\
        "Mai"\
        "Jun"\
        "Jul"\
        "Aug"\
        "Sep"\
        "Okt"\
        "Nov"\
        "Dez"\
        ""]
    ::msgcat::mcset de_AT MONTHS_FULL [list \
        "J\u00e4nner"\
        "Februar"\
        "M\u00e4rz"\
        "April"\
        "Mai"\
        "Juni"\
        "Juli"\
        "August"\
        "September"\
        "Oktober"\
        "November"\
        "Dezember"\
        ""]
    ::msgcat::mcset de_AT DATE_FORMAT "%Y-%m-%d"
    ::msgcat::mcset de_AT TIME_FORMAT "%T"
    ::msgcat::mcset de_AT TIME_FORMAT_12 "%T"
    ::msgcat::mcset de_AT DATE_TIME_FORMAT "%a %d %b %Y %T %z"
}

# created by tools/loadICU.tcl -- do not edit
namespace eval ::tcl::clock {
    ::msgcat::mcset de_BE DAYS_OF_WEEK_ABBREV [list \
        "Son"\
        "Mon"\
        "Die"\
        "Mit"\
        "Don"\
        "Fre"\
        "Sam"]
    ::msgcat::mcset de_BE DAYS_OF_WEEK_FULL [list \
        "Sonntag"\
        "Montag"\
        "Dienstag"\
        "Mittwoch"\
        "Donnerstag"\
        "Freitag"\
        "Samstag"]
    ::msgcat::mcset de_BE MONTHS_ABBREV [list \
        "Jan"\
        "Feb"\
        "M\u00e4r"\
        "Apr"\
        "Mai"\
        "Jun"\
        "Jul"\
        "Aug"\
        "Sep"\
        "Okt"\
        "Nov"\
        "Dez"\
        ""]
    ::msgcat::mcset de_BE MONTHS_FULL [list \
        "Januar"\
        "Februar"\
        "M\u00e4rz"\
        "April"\
        "Mai"\
        "Juni"\
        "Juli"\
        "August"\
        "September"\
        "Oktober"\
        "November"\
        "Dezember"\
        ""]
    ::msgcat::mcset de_BE AM "vorm"
    ::msgcat::mcset de_BE PM "nachm"
    ::msgcat::mcset de_BE DATE_FORMAT "%Y-%m-%d"
    ::msgcat::mcset de_BE TIME_FORMAT "%T"
    ::msgcat::mcset de_BE TIME_FORMAT_12 "%T"
    ::msgcat::mcset de_BE DATE_TIME_FORMAT "%a %d %b %Y %T %z"
}

# created by tools/loadICU.tcl -- do not edit
namespace eval ::tcl::clock {
    ::msgcat::mcset en_AU DATE_FORMAT "%e/%m/%Y"
    ::msgcat::mcset en_AU TIME_FORMAT "%H:%M:%S"
    ::msgcat::mcset en_AU TIME_FORMAT_12 "%I:%M:%S %P %z"
    ::msgcat::mcset en_AU DATE_TIME_FORMAT "%e/%m/%Y %H:%M:%S %z"
}

# created by tools/loadICU.tcl -- do not edit
namespace eval ::tcl::clock {
    ::msgcat::mcset en_BE DATE_FORMAT "%d %b %Y"
    ::msgcat::mcset en_BE TIME_FORMAT "%k:%M:%S"
    ::msgcat::mcset en_BE TIME_FORMAT_12 "%k h %M min %S s %z"
    ::msgcat::mcset en_BE DATE_TIME_FORMAT "%d %b %Y %k:%M:%S %z"
}

# created by tools/loadICU.tcl -- do not edit
namespace eval ::tcl::clock {
    ::msgcat::mcset en_BW DATE_FORMAT "%d %B %Y"
    ::msgcat::mcset en_BW TIME_FORMAT_12 "%l:%M:%S %P"
    ::msgcat::mcset en_BW DATE_TIME_FORMAT "%d %B %Y %l:%M:%S %P %z"
}

# created by tools/loadICU.tcl -- do not edit
namespace eval ::tcl::clock {
    ::msgcat::mcset en_CA DATE_FORMAT "%d/%m/%y"
    ::msgcat::mcset en_CA TIME_FORMAT "%r"
    ::msgcat::mcset en_CA TIME_FORMAT_12 "%I:%M:%S %p"
    ::msgcat::mcset en_CA DATE_TIME_FORMAT "%a %d %b %Y %r %z"
}

# created by tools/loadICU.tcl -- do not edit
namespace eval ::tcl::clock {
    ::msgcat::mcset en_GB DATE_FORMAT "%d/%m/%y"
    ::msgcat::mcset en_GB TIME_FORMAT "%T"
    ::msgcat::mcset en_GB TIME_FORMAT_12 "%T"
    ::msgcat::mcset en_GB DATE_TIME_FORMAT "%a %d %b %Y %T %z"
}

# created by tools/loadICU.tcl -- do not edit
namespace eval ::tcl::clock {
    ::msgcat::mcset en_HK AM "AM"
    ::msgcat::mcset en_HK PM "PM"
    ::msgcat::mcset en_HK DATE_FORMAT "%B %e, %Y"
    ::msgcat::mcset en_HK TIME_FORMAT_12 "%l:%M:%S %P"
    ::msgcat::mcset en_HK DATE_TIME_FORMAT "%B %e, %Y %l:%M:%S %P %z"
}

# created by tools/loadICU.tcl -- do not edit
namespace eval ::tcl::clock {
    ::msgcat::mcset en_IE DATE_FORMAT "%d/%m/%y"
    ::msgcat::mcset en_IE TIME_FORMAT "%T"
    ::msgcat::mcset en_IE TIME_FORMAT_12 "%T"
    ::msgcat::mcset en_IE DATE_TIME_FORMAT "%a %d %b %Y %T %z"
}

# created by tools/loadICU.tcl -- do not edit
namespace eval ::tcl::clock {
    ::msgcat::mcset en_IN AM "AM"
    ::msgcat::mcset en_IN PM "PM"
    ::msgcat::mcset en_IN DATE_FORMAT "%d %B %Y"
    ::msgcat::mcset en_IN TIME_FORMAT "%H:%M:%S"
    ::msgcat::mcset en_IN DATE_TIME_FORMAT "%d %B %Y %H:%M:%S %z"
}

# created by tools/loadICU.tcl -- do not edit
namespace eval ::tcl::clock {
    ::msgcat::mcset en_NZ DATE_FORMAT "%e/%m/%Y"
    ::msgcat::mcset en_NZ TIME_FORMAT "%H:%M:%S"
    ::msgcat::mcset en_NZ TIME_FORMAT_12 "%I:%M:%S %P %z"
    ::msgcat::mcset en_NZ DATE_TIME_FORMAT "%e/%m/%Y %H:%M:%S %z"
}

# created by tools/loadICU.tcl -- do not edit
namespace eval ::tcl::clock {
    ::msgcat::mcset en_PH AM "AM"
    ::msgcat::mcset en_PH PM "PM"
    ::msgcat::mcset en_PH DATE_FORMAT "%B %e, %Y"
    ::msgcat::mcset en_PH TIME_FORMAT_12 "%l:%M:%S %P"
    ::msgcat::mcset en_PH DATE_TIME_FORMAT "%B %e, %Y %l:%M:%S %P %z"
}

# created by tools/loadICU.tcl -- do not edit
namespace eval ::tcl::clock {
    ::msgcat::mcset en_SG DATE_FORMAT "%d %b %Y"
    ::msgcat::mcset en_SG TIME_FORMAT_12 "%P %I:%M:%S"
    ::msgcat::mcset en_SG DATE_TIME_FORMAT "%d %b %Y %P %I:%M:%S %z"
}

# created by tools/loadICU.tcl -- do not edit
namespace eval ::tcl::clock {
    ::msgcat::mcset en_ZA DATE_FORMAT "%Y/%m/%d"
    ::msgcat::mcset en_ZA TIME_FORMAT_12 "%I:%M:%S"
    ::msgcat::mcset en_ZA DATE_TIME_FORMAT "%Y/%m/%d %I:%M:%S %z"
}

# created by tools/loadICU.tcl -- do not edit
namespace eval ::tcl::clock {
    ::msgcat::mcset en_ZW DATE_FORMAT "%d %B %Y"
    ::msgcat::mcset en_ZW TIME_FORMAT_12 "%l:%M:%S %P"
    ::msgcat::mcset en_ZW DATE_TIME_FORMAT "%d %B %Y %l:%M:%S %P %z"
}

# created by tools/loadICU.tcl -- do not edit
namespace eval ::tcl::clock {
    ::msgcat::mcset es_AR DATE_FORMAT "%d/%m/%Y"
    ::msgcat::mcset es_AR TIME_FORMAT "%H:%M:%S"
    ::msgcat::mcset es_AR DATE_TIME_FORMAT "%d/%m/%Y %H:%M:%S %z"
}

# created by tools/loadICU.tcl -- do not edit
namespace eval ::tcl::clock {
    ::msgcat::mcset es_BO DATE_FORMAT "%d-%m-%Y"
    ::msgcat::mcset es_BO TIME_FORMAT_12 "%I:%M:%S %P"
    ::msgcat::mcset es_BO DATE_TIME_FORMAT "%d-%m-%Y %I:%M:%S %P %z"
}

# created by tools/loadICU.tcl -- do not edit
namespace eval ::tcl::clock {
    ::msgcat::mcset es_CL DATE_FORMAT "%d-%m-%Y"
    ::msgcat::mcset es_CL TIME_FORMAT_12 "%I:%M:%S %P"
    ::msgcat::mcset es_CL DATE_TIME_FORMAT "%d-%m-%Y %I:%M:%S %P %z"
}

# created by tools/loadICU.tcl -- do not edit
namespace eval ::tcl::clock {
    ::msgcat::mcset es_CO DATE_FORMAT "%e/%m/%Y"
    ::msgcat::mcset es_CO TIME_FORMAT_12 "%I:%M:%S %P"
    ::msgcat::mcset es_CO DATE_TIME_FORMAT "%e/%m/%Y %I:%M:%S %P %z"
}

# created by tools/loadICU.tcl -- do not edit
namespace eval ::tcl::clock {
    ::msgcat::mcset es_CR DATE_FORMAT "%d/%m/%Y"
    ::msgcat::mcset es_CR TIME_FORMAT_12 "%I:%M:%S %P"
    ::msgcat::mcset es_CR DATE_TIME_FORMAT "%d/%m/%Y %I:%M:%S %P %z"
}

# created by tools/loadICU.tcl -- do not edit
namespace eval ::tcl::clock {
    ::msgcat::mcset es_DO DATE_FORMAT "%m/%d/%Y"
    ::msgcat::mcset es_DO TIME_FORMAT_12 "%I:%M:%S %P"
    ::msgcat::mcset es_DO DATE_TIME_FORMAT "%m/%d/%Y %I:%M:%S %P %z"
}

# created by tools/loadICU.tcl -- do not edit
namespace eval ::tcl::clock {
    ::msgcat::mcset es_EC DATE_FORMAT "%d/%m/%Y"
    ::msgcat::mcset es_EC TIME_FORMAT_12 "%I:%M:%S %P"
    ::msgcat::mcset es_EC DATE_TIME_FORMAT "%d/%m/%Y %I:%M:%S %P %z"
}

# created by tools/loadICU.tcl -- do not edit
namespace eval ::tcl::clock {
    ::msgcat::mcset es_GT DATE_FORMAT "%e/%m/%Y"
    ::msgcat::mcset es_GT TIME_FORMAT_12 "%I:%M:%S %P"
    ::msgcat::mcset es_GT DATE_TIME_FORMAT "%e/%m/%Y %I:%M:%S %P %z"
}

# created by tools/loadICU.tcl -- do not edit
namespace eval ::tcl::clock {
    ::msgcat::mcset es_HN DATE_FORMAT "%m-%d-%Y"
    ::msgcat::mcset es_HN TIME_FORMAT_12 "%I:%M:%S %P"
    ::msgcat::mcset es_HN DATE_TIME_FORMAT "%m-%d-%Y %I:%M:%S %P %z"
}

# created by tools/loadICU.tcl -- do not edit
namespace eval ::tcl::clock {
    ::msgcat::mcset es_MX DATE_FORMAT "%e/%m/%Y"
    ::msgcat::mcset es_MX TIME_FORMAT_12 "%I:%M:%S %P"
    ::msgcat::mcset es_MX DATE_TIME_FORMAT "%e/%m/%Y %I:%M:%S %P %z"
}

# created by tools/loadICU.tcl -- do not edit
namespace eval ::tcl::clock {
    ::msgcat::mcset es_NI DATE_FORMAT "%m-%d-%Y"
    ::msgcat::mcset es_NI TIME_FORMAT_12 "%I:%M:%S %P"
    ::msgcat::mcset es_NI DATE_TIME_FORMAT "%m-%d-%Y %I:%M:%S %P %z"
}

# created by tools/loadICU.tcl -- do not edit
namespace eval ::tcl::clock {
    ::msgcat::mcset es_PA DATE_FORMAT "%m/%d/%Y"
    ::msgcat::mcset es_PA TIME_FORMAT_12 "%I:%M:%S %P"
    ::msgcat::mcset es_PA DATE_TIME_FORMAT "%m/%d/%Y %I:%M:%S %P %z"
}

# created by tools/loadICU.tcl -- do not edit
namespace eval ::tcl::clock {
    ::msgcat::mcset es_PE DATE_FORMAT "%d/%m/%Y"
    ::msgcat::mcset es_PE TIME_FORMAT_12 "%I:%M:%S %P"
    ::msgcat::mcset es_PE DATE_TIME_FORMAT "%d/%m/%Y %I:%M:%S %P %z"
}

# created by tools/loadICU.tcl -- do not edit
namespace eval ::tcl::clock {
    ::msgcat::mcset es_PR DATE_FORMAT "%m-%d-%Y"
    ::msgcat::mcset es_PR TIME_FORMAT_12 "%I:%M:%S %P"
    ::msgcat::mcset es_PR DATE_TIME_FORMAT "%m-%d-%Y %I:%M:%S %P %z"
}

# created by tools/loadICU.tcl -- do not edit
namespace eval ::tcl::clock {
    ::msgcat::mcset es_PY DATE_FORMAT "%d/%m/%Y"
    ::msgcat::mcset es_PY TIME_FORMAT_12 "%I:%M:%S %P"
    ::msgcat::mcset es_PY DATE_TIME_FORMAT "%d/%m/%Y %I:%M:%S %P %z"
}

# created by tools/loadICU.tcl -- do not edit
namespace eval ::tcl::clock {
    ::msgcat::mcset es_SV DATE_FORMAT "%m-%d-%Y"
    ::msgcat::mcset es_SV TIME_FORMAT_12 "%I:%M:%S %P"
    ::msgcat::mcset es_SV DATE_TIME_FORMAT "%m-%d-%Y %I:%M:%S %P %z"
}

# created by tools/loadICU.tcl -- do not edit
namespace eval ::tcl::clock {
    ::msgcat::mcset es_UY DATE_FORMAT "%d/%m/%Y"
    ::msgcat::mcset es_UY TIME_FORMAT_12 "%I:%M:%S %P"
    ::msgcat::mcset es_UY DATE_TIME_FORMAT "%d/%m/%Y %I:%M:%S %P %z"
}

# created by tools/loadICU.tcl -- do not edit
namespace eval ::tcl::clock {
    ::msgcat::mcset es_VE DATE_FORMAT "%d/%m/%Y"
    ::msgcat::mcset es_VE TIME_FORMAT_12 "%I:%M:%S %P"
    ::msgcat::mcset es_VE DATE_TIME_FORMAT "%d/%m/%Y %I:%M:%S %P %z"
}

# created by tools/loadICU.tcl -- do not edit
namespace eval ::tcl::clock {
    ::msgcat::mcset eu_ES DATE_FORMAT "%a, %Yeko %bren %da"
    ::msgcat::mcset eu_ES TIME_FORMAT "%T"
    ::msgcat::mcset eu_ES TIME_FORMAT_12 "%T"
    ::msgcat::mcset eu_ES DATE_TIME_FORMAT "%y-%m-%d %T %z"
}

# created by tools/loadICU.tcl -- do not edit
namespace eval ::tcl::clock {
    ::msgcat::mcset fa_IN DAYS_OF_WEEK_ABBREV [list \
        "\u06cc\u2214"\
        "\u062f\u2214"\
        "\u0633\u2214"\
        "\u0686\u2214"\
        "\u067e\u2214"\
        "\u062c\u2214"\
        "\u0634\u2214"]
    ::msgcat::mcset fa_IN DAYS_OF_WEEK_FULL [list \
        "\u06cc\u06cc\u200c\u0634\u0646\u0628\u0647"\
        "\u062f\u0648\u0634\u0646\u0628\u0647"\
        "\u0633\u0647\u200c\u0634\u0646\u0628\u0647"\
        "\u0686\u0647\u0627\u0631\u0634\u0646\u0628\u0647"\
        "\u067e\u0646\u062c\u200c\u0634\u0646\u0628\u0647"\
        "\u062c\u0645\u0639\u0647"\
        "\u0634\u0646\u0628\u0647"]
    ::msgcat::mcset fa_IN MONTHS_ABBREV [list \
        "\u0698\u0627\u0646"\
        "\u0641\u0648\u0631"\
        "\u0645\u0627\u0631"\
        "\u0622\u0648\u0631"\
        "\u0645\u0640\u0647"\
        "\u0698\u0648\u0646"\
        "\u0698\u0648\u06cc"\
        "\u0627\u0648\u062a"\
        "\u0633\u067e\u062a"\
        "\u0627\u0643\u062a"\
        "\u0646\u0648\u0627"\
        "\u062f\u0633\u0627"\
        ""]
    ::msgcat::mcset fa_IN MONTHS_FULL [list \
        "\u0698\u0627\u0646\u0648\u06cc\u0647"\
        "\u0641\u0648\u0631\u0648\u06cc\u0647"\
        "\u0645\u0627\u0631\u0633"\
        "\u0622\u0648\u0631\u06cc\u0644"\
        "\u0645\u0647"\
        "\u0698\u0648\u0626\u0646"\
        "\u0698\u0648\u0626\u06cc\u0647"\
        "\u0627\u0648\u062a"\
        "\u0633\u067e\u062a\u0627\u0645\u0628\u0631"\
        "\u0627\u0643\u062a\u0628\u0631"\
        "\u0646\u0648\u0627\u0645\u0628\u0631"\
        "\u062f\u0633\u0627\u0645\u0628\u0631"\
        ""]
    ::msgcat::mcset fa_IN AM "\u0635\u0628\u062d"
    ::msgcat::mcset fa_IN PM "\u0639\u0635\u0631"
    ::msgcat::mcset fa_IN DATE_FORMAT "%A %d %B %Y"
    ::msgcat::mcset fa_IN TIME_FORMAT_12 "%I:%M:%S  %z"
    ::msgcat::mcset fa_IN DATE_TIME_FORMAT "%A %d %B %Y %I:%M:%S  %z %z"
}

# created by tools/loadICU.tcl -- do not edit
namespace eval ::tcl::clock {
    ::msgcat::mcset fa_IR AM "\u0635\u0628\u062d"
    ::msgcat::mcset fa_IR PM "\u0639\u0635\u0631"
    ::msgcat::mcset fa_IR DATE_FORMAT "%d\u2044%m\u2044%Y"
    ::msgcat::mcset fa_IR TIME_FORMAT "%S:%M:%H"
    ::msgcat::mcset fa_IR TIME_FORMAT_12 "%S:%M:%l %P"
    ::msgcat::mcset fa_IR DATE_TIME_FORMAT "%d\u2044%m\u2044%Y %S:%M:%H %z"
}