variable defaultPrompt   ; # default prompt if tcl_prompt1 isn't used

    if {$inPlugin} {
	set defaultPrompt {subst {[history nextid] % }}
    } else {
	set defaultPrompt {subst {([file tail [pwd]]) [history nextid] % }}
    }



}

# simple compat function for tkcon code added for this console
interp alias {} EvalAttached {} consoleinterp eval

# ::tk::ConsoleInit --
# This procedure constructs and configures the console windows.
................................................................................
                [list ::tk::console::FontchooserVisibility $index]
	    ::tk::console::FontchooserVisibility $index
        } else {
            AmpMenuArgs .menubar.edit add command -label [mc "&Font..."] \
                -command [list ::tk::console::FontchooserToggle]
        }
	bind Console <FocusIn>  [list ::tk::console::FontchooserFocus %W 1]

	bind Console <FocusOut> [list ::tk::console::FontchooserFocus %W 0]

    }
    AmpMenuArgs .menubar.edit add command -label [mc "&Increase Font Size"] \
        -accel "$mod++" -command {event generate .console <<Console_FontSizeIncr>>}
    AmpMenuArgs .menubar.edit add command -label [mc "&Decrease Font Size"] \
        -accel "$mod+-" -command {event generate .console <<Console_FontSizeDecr>>}
    AmpMenuArgs .menubar.edit add command -label [mc "Fit To Screen Width"] \
        -command {event generate .console <<Console_FitScreenWidth>>}
................................................................................
	tk fontchooser hide
    } else {
	tk fontchooser show
    }
}
proc ::tk::console::FontchooserVisibility {index} {
    if {[tk fontchooser configure -visible]} {
	.menubar.edit entryconfigure $index -label [msgcat::mc "Hide Fonts"]

    } else {
	.menubar.edit entryconfigure $index -label [msgcat::mc "Show Fonts"]

    }
}
proc ::tk::console::FontchooserFocus {w isFocusIn} {





    if {$isFocusIn} {
	tk fontchooser configure -parent $w -font TkConsoleFont \
		-command [namespace code [list FontchooserApply]]
    } else {
	tk fontchooser configure -parent $w -font {} -command {}
    }
}

    variable defaultPrompt   ; # default prompt if tcl_prompt1 isn't used

    if {$inPlugin} {
	set defaultPrompt {subst {[history nextid] % }}
    } else {
	set defaultPrompt {subst {([file tail [pwd]]) [history nextid] % }}
    }
    if {!$useFontchooser} {
	set useFontchooser [info exists ::auto_index(::tk::fontchooser)]
    }
}

# simple compat function for tkcon code added for this console
interp alias {} EvalAttached {} consoleinterp eval

# ::tk::ConsoleInit --
# This procedure constructs and configures the console windows.
................................................................................
                [list ::tk::console::FontchooserVisibility $index]
	    ::tk::console::FontchooserVisibility $index
        } else {
            AmpMenuArgs .menubar.edit add command -label [mc "&Font..."] \
                -command [list ::tk::console::FontchooserToggle]
        }
	bind Console <FocusIn>  [list ::tk::console::FontchooserFocus %W 1]
        if {[tk windowingsystem] ne "x11"} {
	    bind Console <FocusOut> [list ::tk::console::FontchooserFocus %W 0]
	}
    }
    AmpMenuArgs .menubar.edit add command -label [mc "&Increase Font Size"] \
        -accel "$mod++" -command {event generate .console <<Console_FontSizeIncr>>}
    AmpMenuArgs .menubar.edit add command -label [mc "&Decrease Font Size"] \
        -accel "$mod+-" -command {event generate .console <<Console_FontSizeDecr>>}
    AmpMenuArgs .menubar.edit add command -label [mc "Fit To Screen Width"] \
        -command {event generate .console <<Console_FitScreenWidth>>}
................................................................................
	tk fontchooser hide
    } else {
	tk fontchooser show
    }
}
proc ::tk::console::FontchooserVisibility {index} {
    if {[tk fontchooser configure -visible]} {
	.menubar.edit entryconfigure $index \
	    -label [::tk::msgcat::mc "Hide Fonts"]
    } else {
	.menubar.edit entryconfigure $index \
	    -label [::tk::msgcat::mc "Show Fonts"]
    }
}
proc ::tk::console::FontchooserFocus {w isFocusIn} {
    if {[tk windowingsystem] eq "x11"} {
	tk fontchooser configure -parent $w \
		-command [namespace code [list FontchooserApply]]
	return
    }
    if {$isFocusIn} {
	tk fontchooser configure -parent $w -font TkConsoleFont \
		-command [namespace code [list FontchooserApply]]
    } else {
	tk fontchooser configure -parent $w -font {} -command {}
    }
}

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

namespace eval ::tk::fontchooser {
    variable S

    set S(W) .__tk__fontchooser
    set S(fonts) [lsort -dictionary [font families]]
    set S(styles) [list \
	[::msgcat::mc "Regular"] \
	[::msgcat::mc "Italic"] \
	[::msgcat::mc "Bold"] \
	[::msgcat::mc "Bold Italic"] \
    ]

................................................................................
proc ::tk::fontchooser::Show {} {
    variable S
    if {![winfo exists $S(W)]} {
        Create
        wm transient $S(W) [winfo toplevel $S(-parent)]
        tk::PlaceWindow $S(W) widget $S(-parent)
    }
    set S(fonts) [lsort -dictionary [font families]]
    set S(fonts,lcase) {}
    foreach font $S(fonts) { lappend S(fonts,lcase) [string tolower $font]}
    wm deiconify $S(W)
}

proc ::tk::fontchooser::Hide {} {
    variable S

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

namespace eval ::tk::fontchooser {
    variable S

    set S(W) .__tk__fontchooser
    set S(fonts) [lsort -dictionary -nocase -unique [font families]]
    set S(styles) [list \
	[::msgcat::mc "Regular"] \
	[::msgcat::mc "Italic"] \
	[::msgcat::mc "Bold"] \
	[::msgcat::mc "Bold Italic"] \
    ]

................................................................................
proc ::tk::fontchooser::Show {} {
    variable S
    if {![winfo exists $S(W)]} {
        Create
        wm transient $S(W) [winfo toplevel $S(-parent)]
        tk::PlaceWindow $S(W) widget $S(-parent)
    }
    set S(fonts) [lsort -dictionary -nocase -unique [font families]]
    set S(fonts,lcase) {}
    foreach font $S(fonts) { lappend S(fonts,lcase) [string tolower $font]}
    wm deiconify $S(W)
}

proc ::tk::fontchooser::Hide {} {
    variable S

    Namespace *globalNsPtr;	/* The interpreter's global namespace. */
    Tcl_HashTable *hiddenCmdTablePtr;
				/* Hash table used by tclBasic.c to keep track
				 * of hidden commands on a per-interp
				 * basis. */
    ClientData interpInfo;	/* Information used by tclInterp.c to keep
				 * track of master/slave interps on a
				 * per-interp basis. */
    union {
	void (*optimizer)(void *envPtr);
	Tcl_HashTable unused2;	/* No longer used (was mathFuncTable). The
				 * unused space in interp was repurposed for
				 * pluggable bytecode optimizers. The core
				 * contains one optimizer, which can be
................................................................................
    /*
     * The thread-specific data ekeko: cache pointers or values that
     *  (a) do not change during the thread's lifetime
     *  (b) require access to TSD to determine at runtime
     *  (c) are accessed very often (e.g., at each command call)
     *
     * Note that these are the same for all interps in the same thread. They
     * just have to be initialised for the thread's master interp, slaves
     * inherit the value.
     *
     * They are used by the macros defined below.
     */

    AllocCache *allocCache;
    void *pendingObjDataPtr;	/* Pointer to the Cache and PendingObjData
................................................................................

typedef void (TclInitProcessGlobalValueProc)(char **valuePtr, int *lengthPtr,
	Tcl_Encoding *encodingPtr);

/*
 * A ProcessGlobalValue struct exists for each internal value in Tcl that is
 * to be shared among several threads. Each thread sees a (Tcl_Obj) copy of
 * the value, and the master is kept as a counted string, with epoch and mutex
 * control. Each ProcessGlobalValue struct should be a static variable in some
 * file.
 */

typedef struct ProcessGlobalValue {
    int epoch;			/* Epoch counter to detect changes in the
				 * master value. */
    int numBytes;		/* Length of the master string. */
    char *value;		/* The master string value. */
    Tcl_Encoding encoding;	/* system encoding when master string was
				 * initialized. */
    TclInitProcessGlobalValueProc *proc;
    				/* A procedure to initialize the master string
				 * copy when a "get" request comes in before
				 * any "set" request has been received. */
    Tcl_Mutex mutex;		/* Enforce orderly access from multiple
				 * threads. */
    Tcl_ThreadDataKey key;	/* Key for per-thread data holding the
				 * (Tcl_Obj) copy for each thread. */
} ProcessGlobalValue;
................................................................................
MODULE_SCOPE int	TclpFindVariable(const char *name, int *lengthPtr);
MODULE_SCOPE void	TclpInitLibraryPath(char **valuePtr,
			    int *lengthPtr, Tcl_Encoding *encodingPtr);
MODULE_SCOPE void	TclpInitLock(void);
MODULE_SCOPE void	TclpInitPlatform(void);
MODULE_SCOPE void	TclpInitUnlock(void);
MODULE_SCOPE Tcl_Obj *	TclpObjListVolumes(void);
MODULE_SCOPE void	TclpMasterLock(void);
MODULE_SCOPE void	TclpMasterUnlock(void);
MODULE_SCOPE int	TclpMatchFiles(Tcl_Interp *interp, char *separators,
			    Tcl_DString *dirPtr, char *pattern, char *tail);
MODULE_SCOPE int	TclpObjNormalizePath(Tcl_Interp *interp,
			    Tcl_Obj *pathPtr, int nextCheckpoint);
MODULE_SCOPE void	TclpNativeJoinPath(Tcl_Obj *prefix, const char *joining);
MODULE_SCOPE Tcl_Obj *	TclpNativeSplitPath(Tcl_Obj *pathPtr, int *lenPtr);
MODULE_SCOPE Tcl_PathType TclpGetNativePathType(Tcl_Obj *pathPtr,
................................................................................
#   endif
#endif
MODULE_SCOPE Tcl_WideInt TclpGetMicroseconds(void);

MODULE_SCOPE int	TclZlibInit(Tcl_Interp *interp);
MODULE_SCOPE void *	TclpThreadCreateKey(void);
MODULE_SCOPE void	TclpThreadDeleteKey(void *keyPtr);
MODULE_SCOPE void	TclpThreadSetMasterTSD(void *tsdKeyPtr, void *ptr);
MODULE_SCOPE void *	TclpThreadGetMasterTSD(void *tsdKeyPtr);

MODULE_SCOPE void	TclErrorStackResetIf(Tcl_Interp *interp, const char *msg, int length);

#if TCL_UTF_MAX > 3
MODULE_SCOPE int	TclCollapseSurrogatePair(Tcl_Token *tokenPtr,
			    int *numReadPtr, char *buffer);
#define	TclUCS4ToUpper(ch) Tcl_UniCharToUpper((ch))

    Namespace *globalNsPtr;	/* The interpreter's global namespace. */
    Tcl_HashTable *hiddenCmdTablePtr;
				/* Hash table used by tclBasic.c to keep track
				 * of hidden commands on a per-interp
				 * basis. */
    ClientData interpInfo;	/* Information used by tclInterp.c to keep
				 * track of parent/child interps on a
				 * per-interp basis. */
    union {
	void (*optimizer)(void *envPtr);
	Tcl_HashTable unused2;	/* No longer used (was mathFuncTable). The
				 * unused space in interp was repurposed for
				 * pluggable bytecode optimizers. The core
				 * contains one optimizer, which can be
................................................................................
    /*
     * The thread-specific data ekeko: cache pointers or values that
     *  (a) do not change during the thread's lifetime
     *  (b) require access to TSD to determine at runtime
     *  (c) are accessed very often (e.g., at each command call)
     *
     * Note that these are the same for all interps in the same thread. They
     * just have to be initialised for the thread's parent interp, children
     * inherit the value.
     *
     * They are used by the macros defined below.
     */

    AllocCache *allocCache;
    void *pendingObjDataPtr;	/* Pointer to the Cache and PendingObjData
................................................................................

typedef void (TclInitProcessGlobalValueProc)(char **valuePtr, int *lengthPtr,
	Tcl_Encoding *encodingPtr);

/*
 * A ProcessGlobalValue struct exists for each internal value in Tcl that is
 * to be shared among several threads. Each thread sees a (Tcl_Obj) copy of
 * the value, and the gobal value is kept as a counted string, with epoch and
 * mutex control. Each ProcessGlobalValue struct should be a static variable in
 * some file.
 */

typedef struct ProcessGlobalValue {
    int epoch;			/* Epoch counter to detect changes in the
				 * global value. */
    int numBytes;		/* Length of the global string. */
    char *value;		/* The global string value. */
    Tcl_Encoding encoding;	/* system encoding when global string was
				 * initialized. */
    TclInitProcessGlobalValueProc *proc;
    				/* A procedure to initialize the global string
				 * copy when a "get" request comes in before
				 * any "set" request has been received. */
    Tcl_Mutex mutex;		/* Enforce orderly access from multiple
				 * threads. */
    Tcl_ThreadDataKey key;	/* Key for per-thread data holding the
				 * (Tcl_Obj) copy for each thread. */
} ProcessGlobalValue;
................................................................................
MODULE_SCOPE int	TclpFindVariable(const char *name, int *lengthPtr);
MODULE_SCOPE void	TclpInitLibraryPath(char **valuePtr,
			    int *lengthPtr, Tcl_Encoding *encodingPtr);
MODULE_SCOPE void	TclpInitLock(void);
MODULE_SCOPE void	TclpInitPlatform(void);
MODULE_SCOPE void	TclpInitUnlock(void);
MODULE_SCOPE Tcl_Obj *	TclpObjListVolumes(void);
MODULE_SCOPE void	TclpGlobalLock(void);
MODULE_SCOPE void	TclpGlobalUnlock(void);
MODULE_SCOPE int	TclpMatchFiles(Tcl_Interp *interp, char *separators,
			    Tcl_DString *dirPtr, char *pattern, char *tail);
MODULE_SCOPE int	TclpObjNormalizePath(Tcl_Interp *interp,
			    Tcl_Obj *pathPtr, int nextCheckpoint);
MODULE_SCOPE void	TclpNativeJoinPath(Tcl_Obj *prefix, const char *joining);
MODULE_SCOPE Tcl_Obj *	TclpNativeSplitPath(Tcl_Obj *pathPtr, int *lenPtr);
MODULE_SCOPE Tcl_PathType TclpGetNativePathType(Tcl_Obj *pathPtr,
................................................................................
#   endif
#endif
MODULE_SCOPE Tcl_WideInt TclpGetMicroseconds(void);

MODULE_SCOPE int	TclZlibInit(Tcl_Interp *interp);
MODULE_SCOPE void *	TclpThreadCreateKey(void);
MODULE_SCOPE void	TclpThreadDeleteKey(void *keyPtr);
MODULE_SCOPE void	TclpThreadSetGlobalTSD(void *tsdKeyPtr, void *ptr);
MODULE_SCOPE void *	TclpThreadGetGlobalTSD(void *tsdKeyPtr);

MODULE_SCOPE void	TclErrorStackResetIf(Tcl_Interp *interp, const char *msg, int length);

#if TCL_UTF_MAX > 3
MODULE_SCOPE int	TclCollapseSurrogatePair(Tcl_Token *tokenPtr,
			    int *numReadPtr, char *buffer);
#define	TclUCS4ToUpper(ch) Tcl_UniCharToUpper((ch))

 *----------------------------------------------------------------------
 *
 * RememberSyncObject
 *
 *	Keep a list of (mutexes/condition variable/data key) used during
 *	finalization.
 *
 *	Assume master lock is held.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	Add to the appropriate list.
 *
................................................................................
 
/*
 *----------------------------------------------------------------------
 *
 * ForgetSyncObject
 *
 *	Remove a single object from the list.
 *	Assume master lock is held.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	Remove from the appropriate list.
 *
................................................................................
 
/*
 *----------------------------------------------------------------------
 *
 * TclRememberMutex
 *
 *	Keep a list of mutexes used during finalization.
 *	Assume master lock is held.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	Add to the mutex list.
 *
................................................................................
void
Tcl_MutexFinalize(
    Tcl_Mutex *mutexPtr)
{
#ifdef TCL_THREADS
    TclpFinalizeMutex(mutexPtr);
#endif
    TclpMasterLock();
    ForgetSyncObject(mutexPtr, &mutexRecord);
    TclpMasterUnlock();
}
 
/*
 *----------------------------------------------------------------------
 *
 * TclRememberCondition
 *
 *	Keep a list of condition variables used during finalization.
 *	Assume master lock is held.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	Add to the condition variable list.
 *
................................................................................
void
Tcl_ConditionFinalize(
    Tcl_Condition *condPtr)
{
#ifdef TCL_THREADS
    TclpFinalizeCondition(condPtr);
#endif
    TclpMasterLock();
    ForgetSyncObject(condPtr, &condRecord);
    TclpMasterUnlock();
}
 
/*
 *----------------------------------------------------------------------
 *
 * TclFinalizeThreadData --
 *
................................................................................
    int i;
    void *blockPtr;
    Tcl_ThreadDataKey *keyPtr;
#ifdef TCL_THREADS
    Tcl_Mutex *mutexPtr;
    Tcl_Condition *condPtr;

    TclpMasterLock();
#endif

    /*
     * If we're running unthreaded, the TSD blocks are simply stored inside
     * their thread data keys. Free them here.
     */

................................................................................
	keyRecord.list = NULL;
    }
    keyRecord.max = 0;
    keyRecord.num = 0;

#ifdef TCL_THREADS
    /*
     * Call thread storage master cleanup.
     */

    TclFinalizeThreadStorage();

    for (i=0 ; i<mutexRecord.num ; i++) {
	mutexPtr = (Tcl_Mutex *)mutexRecord.list[i];
	if (mutexPtr != NULL) {
................................................................................
    if (condRecord.list != NULL) {
	ckfree(condRecord.list);
	condRecord.list = NULL;
    }
    condRecord.max = 0;
    condRecord.num = 0;

    TclpMasterUnlock();
#endif /* TCL_THREADS */
}
 
/*
 *----------------------------------------------------------------------
 *
 * Tcl_ExitThread --

 *----------------------------------------------------------------------
 *
 * RememberSyncObject
 *
 *	Keep a list of (mutexes/condition variable/data key) used during
 *	finalization.
 *
 *	Assume global lock is held.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	Add to the appropriate list.
 *
................................................................................
 
/*
 *----------------------------------------------------------------------
 *
 * ForgetSyncObject
 *
 *	Remove a single object from the list.
 *	Assume global lock is held.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	Remove from the appropriate list.
 *
................................................................................
 
/*
 *----------------------------------------------------------------------
 *
 * TclRememberMutex
 *
 *	Keep a list of mutexes used during finalization.
 *	Assume global lock is held.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	Add to the mutex list.
 *
................................................................................
void
Tcl_MutexFinalize(
    Tcl_Mutex *mutexPtr)
{
#ifdef TCL_THREADS
    TclpFinalizeMutex(mutexPtr);
#endif
    TclpGlobalLock();
    ForgetSyncObject(mutexPtr, &mutexRecord);
    TclpGlobalUnlock();
}
 
/*
 *----------------------------------------------------------------------
 *
 * TclRememberCondition
 *
 *	Keep a list of condition variables used during finalization.
 *	Assume global lock is held.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	Add to the condition variable list.
 *
................................................................................
void
Tcl_ConditionFinalize(
    Tcl_Condition *condPtr)
{
#ifdef TCL_THREADS
    TclpFinalizeCondition(condPtr);
#endif
    TclpGlobalLock();
    ForgetSyncObject(condPtr, &condRecord);
    TclpGlobalUnlock();
}
 
/*
 *----------------------------------------------------------------------
 *
 * TclFinalizeThreadData --
 *
................................................................................
    int i;
    void *blockPtr;
    Tcl_ThreadDataKey *keyPtr;
#ifdef TCL_THREADS
    Tcl_Mutex *mutexPtr;
    Tcl_Condition *condPtr;

    TclpGlobalLock();
#endif

    /*
     * If we're running unthreaded, the TSD blocks are simply stored inside
     * their thread data keys. Free them here.
     */

................................................................................
	keyRecord.list = NULL;
    }
    keyRecord.max = 0;
    keyRecord.num = 0;

#ifdef TCL_THREADS
    /*
     * Call thread storage global cleanup.
     */

    TclFinalizeThreadStorage();

    for (i=0 ; i<mutexRecord.num ; i++) {
	mutexPtr = (Tcl_Mutex *)mutexRecord.list[i];
	if (mutexPtr != NULL) {
................................................................................
    if (condRecord.list != NULL) {
	ckfree(condRecord.list);
	condRecord.list = NULL;
    }
    condRecord.max = 0;
    condRecord.num = 0;

    TclpGlobalUnlock();
#endif /* TCL_THREADS */
}
 
/*
 *----------------------------------------------------------------------
 *
 * Tcl_ExitThread --

 * it for storing a table pointer. Each Tcl_ThreadDataKey has an offset into
 * the table of TSD values. We don't use more than 1 platform-specific TSD
 * slot, because there is a hard limit on the number of TSD slots. Valid key
 * offsets are greater than 0; 0 is for the initialized Tcl_ThreadDataKey.
 */

/*
 * The master collection of information about TSDs. This is shared across the
 * whole process, and includes the mutex used to protect it.
 */

static struct TSDMaster {
    void *key;			/* Key into the system TSD structure. The
				 * collection of Tcl TSD values for a
				 * particular thread will hang off the
				 * back-end of this. */
    sig_atomic_t counter;	/* The number of different Tcl TSDs used
				 * across *all* threads. This is a strictly
				 * increasing value. */
    Tcl_Mutex mutex;		/* Protection for the rest of this structure,
				 * which holds per-process data. */
} tsdMaster = { NULL, 0, NULL };

/*
 * The type of the data held per thread in a system TSD.
 */

typedef struct TSDTable {
    ClientData *tablePtr;	/* The table of Tcl TSDs. */
    sig_atomic_t allocated;	/* The size of the table in the current
				 * thread. */
} TSDTable;

/*
 * The actual type of Tcl_ThreadDataKey.
 */

typedef union TSDUnion {
    volatile sig_atomic_t offset;
				/* The type is really an offset into the
				 * thread-local table of TSDs, which is this
				 * field. */
    void *ptr;			/* For alignment purposes only. Not actually
				 * accessed through this. */
} TSDUnion;
................................................................................
 *----------------------------------------------------------------------
 */

void *
TclThreadStorageKeyGet(
    Tcl_ThreadDataKey *dataKeyPtr)
{
    TSDTable *tsdTablePtr = TclpThreadGetMasterTSD(tsdMaster.key);
    ClientData resultPtr = NULL;
    TSDUnion *keyPtr = (TSDUnion *) dataKeyPtr;
    sig_atomic_t offset = keyPtr->offset;

    if ((tsdTablePtr != NULL) && (offset > 0)
	    && (offset < tsdTablePtr->allocated)) {
	resultPtr = tsdTablePtr->tablePtr[offset];
................................................................................
 */

void
TclThreadStorageKeySet(
    Tcl_ThreadDataKey *dataKeyPtr,
    void *value)
{
    TSDTable *tsdTablePtr = TclpThreadGetMasterTSD(tsdMaster.key);
    TSDUnion *keyPtr = (TSDUnion *) dataKeyPtr;

    if (tsdTablePtr == NULL) {
	tsdTablePtr = TSDTableCreate();
	TclpThreadSetMasterTSD(tsdMaster.key, tsdTablePtr);
    }

    /*
     * Get the lock while we check if this TSD is new or not. Note that this
     * is the only place where Tcl_ThreadDataKey values are set. We use a
     * double-checked lock to try to avoid having to grab this lock a lot,
     * since it is on quite a few critical paths and will only get set once in
     * each location.
     */

    if (keyPtr->offset == 0) {
	Tcl_MutexLock(&tsdMaster.mutex);
	if (keyPtr->offset == 0) {
	    /*
	     * The Tcl_ThreadDataKey hasn't been used yet. Make a new one.
	     */

	    keyPtr->offset = ++tsdMaster.counter;
	}
	Tcl_MutexUnlock(&tsdMaster.mutex);
    }

    /*
     * Check if this is the first time this Tcl_ThreadDataKey has been used
     * with the current thread. Note that we don't need to hold a lock when
     * doing this, as we are *definitely* the only point accessing this
     * tsdTablePtr right now; it's thread-local.
................................................................................
 *
 *----------------------------------------------------------------------
 */

void
TclFinalizeThreadDataThread(void)
{
    TSDTable *tsdTablePtr = TclpThreadGetMasterTSD(tsdMaster.key);

    if (tsdTablePtr != NULL) {
	TSDTableDelete(tsdTablePtr);
	TclpThreadSetMasterTSD(tsdMaster.key, NULL);
    }
}
 
/*
 *----------------------------------------------------------------------
 *
 * TclInitializeThreadStorage --
................................................................................
 *
 *----------------------------------------------------------------------
 */

void
TclInitThreadStorage(void)
{
    tsdMaster.key = TclpThreadCreateKey();
}
 
/*
 *----------------------------------------------------------------------
 *
 * TclFinalizeThreadStorage --
 *
................................................................................
 *
 *----------------------------------------------------------------------
 */

void
TclFinalizeThreadStorage(void)
{
    TclpThreadDeleteKey(tsdMaster.key);
    tsdMaster.key = NULL;
}
 
#else /* !TCL_THREADS */
/*
 * Stub functions for non-threaded builds
 */

 * it for storing a table pointer. Each Tcl_ThreadDataKey has an offset into
 * the table of TSD values. We don't use more than 1 platform-specific TSD
 * slot, because there is a hard limit on the number of TSD slots. Valid key
 * offsets are greater than 0; 0 is for the initialized Tcl_ThreadDataKey.
 */

/*
 * The global collection of information about TSDs. This is shared across the
 * whole process, and includes the mutex used to protect it.
 */

static struct {
    void *key;			/* Key into the system TSD structure. The
				 * collection of Tcl TSD values for a
				 * particular thread will hang off the
				 * back-end of this. */
    sig_atomic_t counter;	/* The number of different Tcl TSDs used
				 * across *all* threads. This is a strictly
				 * increasing value. */
    Tcl_Mutex mutex;		/* Protection for the rest of this structure,
				 * which holds per-process data. */
} tsdGlobal = { NULL, 0, NULL };

/*
 * The type of the data held per thread in a system TSD.
 */

typedef struct {
    ClientData *tablePtr;	/* The table of Tcl TSDs. */
    sig_atomic_t allocated;	/* The size of the table in the current
				 * thread. */
} TSDTable;

/*
 * The actual type of Tcl_ThreadDataKey.
 */

typedef union {
    volatile sig_atomic_t offset;
				/* The type is really an offset into the
				 * thread-local table of TSDs, which is this
				 * field. */
    void *ptr;			/* For alignment purposes only. Not actually
				 * accessed through this. */
} TSDUnion;
................................................................................
 *----------------------------------------------------------------------
 */

void *
TclThreadStorageKeyGet(
    Tcl_ThreadDataKey *dataKeyPtr)
{
    TSDTable *tsdTablePtr = TclpThreadGetGlobalTSD(tsdGlobal.key);
    ClientData resultPtr = NULL;
    TSDUnion *keyPtr = (TSDUnion *) dataKeyPtr;
    sig_atomic_t offset = keyPtr->offset;

    if ((tsdTablePtr != NULL) && (offset > 0)
	    && (offset < tsdTablePtr->allocated)) {
	resultPtr = tsdTablePtr->tablePtr[offset];
................................................................................
 */

void
TclThreadStorageKeySet(
    Tcl_ThreadDataKey *dataKeyPtr,
    void *value)
{
    TSDTable *tsdTablePtr = TclpThreadGetGlobalTSD(tsdGlobal.key);
    TSDUnion *keyPtr = (TSDUnion *) dataKeyPtr;

    if (tsdTablePtr == NULL) {
	tsdTablePtr = TSDTableCreate();
	TclpThreadSetGlobalTSD(tsdGlobal.key, tsdTablePtr);
    }

    /*
     * Get the lock while we check if this TSD is new or not. Note that this
     * is the only place where Tcl_ThreadDataKey values are set. We use a
     * double-checked lock to try to avoid having to grab this lock a lot,
     * since it is on quite a few critical paths and will only get set once in
     * each location.
     */

    if (keyPtr->offset == 0) {
	Tcl_MutexLock(&tsdGlobal.mutex);
	if (keyPtr->offset == 0) {
	    /*
	     * The Tcl_ThreadDataKey hasn't been used yet. Make a new one.
	     */

	    keyPtr->offset = ++tsdGlobal.counter;
	}
	Tcl_MutexUnlock(&tsdGlobal.mutex);
    }

    /*
     * Check if this is the first time this Tcl_ThreadDataKey has been used
     * with the current thread. Note that we don't need to hold a lock when
     * doing this, as we are *definitely* the only point accessing this
     * tsdTablePtr right now; it's thread-local.
................................................................................
 *
 *----------------------------------------------------------------------
 */

void
TclFinalizeThreadDataThread(void)
{
    TSDTable *tsdTablePtr = TclpThreadGetGlobalTSD(tsdGlobal.key);

    if (tsdTablePtr != NULL) {
	TSDTableDelete(tsdTablePtr);
	TclpThreadSetGlobalTSD(tsdGlobal.key, NULL);
    }
}
 
/*
 *----------------------------------------------------------------------
 *
 * TclInitializeThreadStorage --
................................................................................
 *
 *----------------------------------------------------------------------
 */

void
TclInitThreadStorage(void)
{
    tsdGlobal.key = TclpThreadCreateKey();
}
 
/*
 *----------------------------------------------------------------------
 *
 * TclFinalizeThreadStorage --
 *
................................................................................
 *
 *----------------------------------------------------------------------
 */

void
TclFinalizeThreadStorage(void)
{
    TclpThreadDeleteKey(tsdGlobal.key);
    tsdGlobal.key = NULL;
}
 
#else /* !TCL_THREADS */
/*
 * Stub functions for non-threaded builds
 */

    int epoch = pgvPtr->epoch;

    if (pgvPtr->encoding) {
	Tcl_Encoding current = Tcl_GetEncoding(NULL, NULL);

	if (pgvPtr->encoding != current) {
	    /*
	     * The system encoding has changed since the master string value
	     * was saved. Convert the master value to be based on the new
	     * system encoding.
	     */

	    Tcl_DString native, newValue;

	    Tcl_MutexLock(&pgvPtr->mutex);
	    epoch = ++pgvPtr->epoch;

    int epoch = pgvPtr->epoch;

    if (pgvPtr->encoding) {
	Tcl_Encoding current = Tcl_GetEncoding(NULL, NULL);

	if (pgvPtr->encoding != current) {
	    /*
	     * The system encoding has changed since the global string value
	     * was saved. Convert the global value to be based on the new
	     * system encoding.
	     */

	    Tcl_DString native, newValue;

	    Tcl_MutexLock(&pgvPtr->mutex);
	    epoch = ++pgvPtr->epoch;

    # errors go to stderr by default
    Option -errfile stderr {
	Send errors from test runs to the specified file.
    } AcceptOutFile errorFile
    trace add variable Option(-errfile) write \
	    [namespace code {errorChannel $Option(-errfile) ;#}]

    proc loadIntoSlaveInterpreter {slave args} {
	variable Version
	interp eval $slave [package ifneeded tcltest $Version]
	interp eval $slave "tcltest::configure {*}{$args}"
	interp alias $slave ::tcltest::ReportToMaster \
	    {} ::tcltest::ReportedFromSlave
    }
    proc ReportedFromSlave {total passed skipped failed because newfiles} {
	variable numTests
	variable skippedBecause
	variable createdNewFiles
	incr numTests(Total)   $total
	incr numTests(Passed)  $passed
	incr numTests(Skipped) $skipped
	incr numTests(Failed)  $failed
................................................................................
    variable originalTclPlatform
    variable coreModTime

    FillFilesExisted
    set testFileName [file tail [info script]]

    # Hook to handle reporting to a parent interpreter
    if {[llength [info commands [namespace current]::ReportToMaster]]} {
	ReportToMaster $numTests(Total) $numTests(Passed) $numTests(Skipped) \
	    $numTests(Failed) [array get skippedBecause] \
	    [array get createdNewFiles]
	set testSingleFile false
    }

    # Call the cleanup hook
    cleanupTestsHook

    # errors go to stderr by default
    Option -errfile stderr {
	Send errors from test runs to the specified file.
    } AcceptOutFile errorFile
    trace add variable Option(-errfile) write \
	    [namespace code {errorChannel $Option(-errfile) ;#}]

    proc loadIntoChildInterpreter {child args} {
	variable Version
	interp eval $child [package ifneeded tcltest $Version]
	interp eval $child "tcltest::configure {*}{$args}"
	interp alias $child ::tcltest::ReportToParent \
	    {} ::tcltest::ReportedFromChild
    }
    proc ReportedFromChild {total passed skipped failed because newfiles} {
	variable numTests
	variable skippedBecause
	variable createdNewFiles
	incr numTests(Total)   $total
	incr numTests(Passed)  $passed
	incr numTests(Skipped) $skipped
	incr numTests(Failed)  $failed
................................................................................
    variable originalTclPlatform
    variable coreModTime

    FillFilesExisted
    set testFileName [file tail [info script]]

    # Hook to handle reporting to a parent interpreter
    if {[llength [info commands [namespace current]::ReportToParent]]} {
	ReportToParent $numTests(Total) $numTests(Passed) $numTests(Skipped) \
	    $numTests(Failed) [array get skippedBecause] \
	    [array get createdNewFiles]
	set testSingleFile false
    }

    # Call the cleanup hook
    cleanupTestsHook

    lappend l [chan eof $f]
} -cleanup {
    chan close $f
} -result [list 7 a\rb\rc 7 {} 7 1]

test chan-io-50.1 {testing handler deletion} -setup {
    file delete $path(test1)
} -constraints {testchannelevent} -body {
    set f [open $path(test1) w]
    chan close $f
    set f [open $path(test1) r]
    testchannelevent $f add readable [namespace code {
	variable z called
	testchannelevent $f delete 0
    }]
................................................................................
} -cleanup {
    chan close $f
} -result called
test chan-io-50.2 {testing handler deletion with multiple handlers} -setup {
    file delete $path(test1)
    chan close [open $path(test1) w]
    set z ""
} -constraints {testchannelevent} -body {
    set f [open $path(test1) r]
    testchannelevent $f add readable [namespace code [list delhandler $f 1]]
    testchannelevent $f add readable [namespace code [list delhandler $f 0]]
    proc delhandler {f i} {
	variable z
	lappend z "called delhandler $f $i"
	testchannelevent $f delete 0
................................................................................
} -cleanup {
    chan close $f
} -result 1
test chan-io-50.3 {testing handler deletion with multiple handlers} -setup {
    file delete $path(test1)
    chan close [open $path(test1) w]
    set z ""
} -constraints {testchannelevent} -body {
    set f [open $path(test1) r]
    testchannelevent $f add readable [namespace code [list notcalled $f 1]]
    testchannelevent $f add readable [namespace code [list delhandler $f 0]]
    proc notcalled {f i} {
	variable z
	lappend z "notcalled was called!! $f $i"
    }
................................................................................
} -cleanup {
    chan close $f
} -result 1
test chan-io-50.4 {testing handler deletion vs reentrant calls} -setup {
    file delete $path(test1)
    set f [open $path(test1) w]
    chan close $f
} -constraints {testchannelevent} -body {
    set f [open $path(test1) r]
    testchannelevent $f add readable [namespace code {
	if {$u eq "recursive"} {
	    testchannelevent $f delete 0
	    lappend z "delrecursive deleting recursive"
	} else {
	    lappend z "delrecursive calling recursive"
................................................................................
} -cleanup {
    chan close $f
} -result {{delrecursive calling recursive} {delrecursive deleting recursive}}
test chan-io-50.5 {testing handler deletion vs reentrant calls} -setup {
    file delete $path(test1)
    set f [open $path(test1) w]
    chan close $f
} -constraints {testchannelevent} -body {
    set f [open $path(test1) r]
    testchannelevent $f add readable [namespace code [list notcalled $f]]
    testchannelevent $f add readable [namespace code [list del $f]]
    proc notcalled {f} {
	variable z
	lappend z "notcalled was called!! $f"
    }
................................................................................
    chan close $f
} -result [list {del calling recursive} {del deleted notcalled} \
	       {del deleted myself} {del after update}]
test chan-io-50.6 {testing handler deletion vs reentrant calls} -setup {
    file delete $path(test1)
    set f [open $path(test1) w]
    chan close $f
} -constraints {testchannelevent} -body {
    set f [open $path(test1) r]
    testchannelevent $f add readable [namespace code [list second $f]]
    testchannelevent $f add readable [namespace code [list first $f]]
    proc first {f} {
	variable u
	variable z
	if {$u eq "toplevel"} {

    lappend l [chan eof $f]
} -cleanup {
    chan close $f
} -result [list 7 a\rb\rc 7 {} 7 1]

test chan-io-50.1 {testing handler deletion} -setup {
    file delete $path(test1)
} -constraints {testchannelevent nonPortable} -body {
    set f [open $path(test1) w]
    chan close $f
    set f [open $path(test1) r]
    testchannelevent $f add readable [namespace code {
	variable z called
	testchannelevent $f delete 0
    }]
................................................................................
} -cleanup {
    chan close $f
} -result called
test chan-io-50.2 {testing handler deletion with multiple handlers} -setup {
    file delete $path(test1)
    chan close [open $path(test1) w]
    set z ""
} -constraints {testchannelevent nonPortable} -body {
    set f [open $path(test1) r]
    testchannelevent $f add readable [namespace code [list delhandler $f 1]]
    testchannelevent $f add readable [namespace code [list delhandler $f 0]]
    proc delhandler {f i} {
	variable z
	lappend z "called delhandler $f $i"
	testchannelevent $f delete 0
................................................................................
} -cleanup {
    chan close $f
} -result 1
test chan-io-50.3 {testing handler deletion with multiple handlers} -setup {
    file delete $path(test1)
    chan close [open $path(test1) w]
    set z ""
} -constraints {testchannelevent nonPortable} -body {
    set f [open $path(test1) r]
    testchannelevent $f add readable [namespace code [list notcalled $f 1]]
    testchannelevent $f add readable [namespace code [list delhandler $f 0]]
    proc notcalled {f i} {
	variable z
	lappend z "notcalled was called!! $f $i"
    }
................................................................................
} -cleanup {
    chan close $f
} -result 1
test chan-io-50.4 {testing handler deletion vs reentrant calls} -setup {
    file delete $path(test1)
    set f [open $path(test1) w]
    chan close $f
} -constraints {testchannelevent nonPortable} -body {
    set f [open $path(test1) r]
    testchannelevent $f add readable [namespace code {
	if {$u eq "recursive"} {
	    testchannelevent $f delete 0
	    lappend z "delrecursive deleting recursive"
	} else {
	    lappend z "delrecursive calling recursive"
................................................................................
} -cleanup {
    chan close $f
} -result {{delrecursive calling recursive} {delrecursive deleting recursive}}
test chan-io-50.5 {testing handler deletion vs reentrant calls} -setup {
    file delete $path(test1)
    set f [open $path(test1) w]
    chan close $f
} -constraints {testchannelevent nonPortable} -body {
    set f [open $path(test1) r]
    testchannelevent $f add readable [namespace code [list notcalled $f]]
    testchannelevent $f add readable [namespace code [list del $f]]
    proc notcalled {f} {
	variable z
	lappend z "notcalled was called!! $f"
    }
................................................................................
    chan close $f
} -result [list {del calling recursive} {del deleted notcalled} \
	       {del deleted myself} {del after update}]
test chan-io-50.6 {testing handler deletion vs reentrant calls} -setup {
    file delete $path(test1)
    set f [open $path(test1) w]
    chan close $f
} -constraints {testchannelevent nonPortable} -body {
    set f [open $path(test1) r]
    testchannelevent $f add readable [namespace code [list second $f]]
    testchannelevent $f add readable [namespace code [list first $f]]
    proc first {f} {
	variable u
	variable z
	if {$u eq "toplevel"} {

testConstraint testexithandler [llength [info commands testexithandler]]
testConstraint testfilewait [llength [info commands testfilewait]]
testConstraint exec [llength [info commands exec]]
 
test event-1.1 {Tcl_CreateFileHandler, reading} -setup {
    testfilehandler close
    set result ""
} -constraints {testfilehandler} -body {
    testfilehandler create 0 readable off
    testfilehandler clear 0
    testfilehandler oneevent
    lappend result [testfilehandler counts 0]
    testfilehandler fillpartial 0
    testfilehandler oneevent
    lappend result [testfilehandler counts 0]

testConstraint testexithandler [llength [info commands testexithandler]]
testConstraint testfilewait [llength [info commands testfilewait]]
testConstraint exec [llength [info commands exec]]
 
test event-1.1 {Tcl_CreateFileHandler, reading} -setup {
    testfilehandler close
    set result ""
} -constraints {testfilehandler nonPortable} -body {
    testfilehandler create 0 readable off
    testfilehandler clear 0
    testfilehandler oneevent
    lappend result [testfilehandler counts 0]
    testfilehandler fillpartial 0
    testfilehandler oneevent
    lappend result [testfilehandler counts 0]

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

package require tcltest 2
namespace import -force ::tcltest::*

package require http 2.8

# start the server
variable httpd_output
proc create_httpd {} {
    proc httpd_read {chan} {
        variable httpd_output
        if {[gets $chan line] != -1} {

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

package require tcltest 2
namespace import -force ::tcltest::*

package require http 2.9

# start the server
variable httpd_output
proc create_httpd {} {
    proc httpd_read {chan} {
        variable httpd_output
        if {[gets $chan line] != -1} {

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

package require tcltest 2
namespace import -force ::tcltest::*

package require http 2.8

set sourcedir [file normalize [file dirname [info script]]]
source [file join $sourcedir httpTest.tcl]
source [file join $sourcedir httpTestScript.tcl]

# ------------------------------------------------------------------------------
# (1) Define the test scripts that will be used to generate logs for analysis -

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

package require tcltest 2
namespace import -force ::tcltest::*

package require http 2.9

set sourcedir [file normalize [file dirname [info script]]]
source [file join $sourcedir httpTest.tcl]
source [file join $sourcedir httpTestScript.tcl]

# ------------------------------------------------------------------------------
# (1) Define the test scripts that will be used to generate logs for analysis -

    namespace import -force ::tcltest::*
}

# Clear out any namespaces called test_ns_*
catch {namespace delete {*}[namespace children :: test_ns_*]}
 
test init-0.1 {no error on initialization phase (init.tcl)} -setup {
    interp create slave
} -body {
    slave eval {
	list [set v [info exists ::errorInfo]] \
		[if {$v} {set ::errorInfo}] \
	     [set v [info exists ::errorCode]] \
		[if {$v} {set ::errorCode}]
    }
} -cleanup {
    interp delete slave
} -result {0 {} 0 {}}

# Six cases - white box testing

test init-1.1 {auto_qualify - absolute cmd - namespace} {
    auto_qualify ::foo::bar ::blue
} ::foo::bar
................................................................................
test init-1.7 {auto_qualify - multiples colons 1} {
    auto_qualify :::foo::::bar ::blue
} ::foo::bar
test init-1.8 {auto_qualify - multiple colons 2} {
    auto_qualify :::foo ::bar
} foo
 
# We use a sub-interp and auto_reset and double the tests because there is 2
# places where auto_loading occur (before loading the indexes files and after)

set testInterp [interp create]
tcltest::loadIntoSlaveInterpreter $testInterp {*}$argv
interp eval $testInterp {
    namespace import -force ::tcltest::*
    customMatch pairwise {apply {{mode pair} {
	if {[llength $pair] != 2} {error "need a pair of values to check"}
	string $mode [lindex $pair 0] [lindex $pair 1]
    }}}

    namespace import -force ::tcltest::*
}

# Clear out any namespaces called test_ns_*
catch {namespace delete {*}[namespace children :: test_ns_*]}
 
test init-0.1 {no error on initialization phase (init.tcl)} -setup {
    interp create child
} -body {
    child eval {
	list [set v [info exists ::errorInfo]] \
		[if {$v} {set ::errorInfo}] \
	     [set v [info exists ::errorCode]] \
		[if {$v} {set ::errorCode}]
    }
} -cleanup {
    interp delete child
} -result {0 {} 0 {}}

# Six cases - white box testing

test init-1.1 {auto_qualify - absolute cmd - namespace} {
    auto_qualify ::foo::bar ::blue
} ::foo::bar
................................................................................
test init-1.7 {auto_qualify - multiples colons 1} {
    auto_qualify :::foo::::bar ::blue
} ::foo::bar
test init-1.8 {auto_qualify - multiple colons 2} {
    auto_qualify :::foo ::bar
} foo
 
# We use a child interp and auto_reset and double the tests because there is 2
# places where auto_loading occur (before loading the indexes files and after)

set testInterp [interp create]
tcltest::loadIntoChildInterpreter $testInterp {*}$argv
interp eval $testInterp {
    namespace import -force ::tcltest::*
    customMatch pairwise {apply {{mode pair} {
	if {[llength $pair] != 2} {error "need a pair of values to check"}
	string $mode [lindex $pair 0] [lindex $pair 1]
    }}}

    lappend l [gets $f]
    lappend l [tell $f]
    lappend l [eof $f]
    close $f
    set l
} [list 7 a\rb\rc 7 {} 7 1]

test io-50.1 {testing handler deletion} {testchannelevent} {
    file delete $path(test1)
    set f [open $path(test1) w]
    close $f
    set f [open $path(test1) r]
    testchannelevent $f add readable [namespace code [list delhandler $f]]
    proc delhandler {f} {
	variable z
................................................................................
	testchannelevent $f delete 0
    }
    set z not_called
    update
    close $f
    set z
} called
test io-50.2 {testing handler deletion with multiple handlers} {testchannelevent} {
    file delete $path(test1)
    set f [open $path(test1) w]
    close $f
    set f [open $path(test1) r]
    testchannelevent $f add readable [namespace code [list delhandler $f 1]]
    testchannelevent $f add readable [namespace code [list delhandler $f 0]]
    proc delhandler {f i} {
................................................................................
    }
    set z ""
    update
    close $f
    string compare [string tolower $z] \
	[list [list called delhandler $f 0] [list called delhandler $f 1]]
} 0
test io-50.3 {testing handler deletion with multiple handlers} {testchannelevent} {
    file delete $path(test1)
    set f [open $path(test1) w]
    close $f
    set f [open $path(test1) r]
    testchannelevent $f add readable [namespace code [list notcalled $f 1]]
    testchannelevent $f add readable [namespace code [list delhandler $f 0]]
    set z ""
................................................................................
    set z ""
    update
    close $f
    string compare [string tolower $z] \
	[list [list delhandler $f 0 called] \
	      [list delhandler $f 0 deleted myself]]
} 0
test io-50.4 {testing handler deletion vs reentrant calls} {testchannelevent} {
    file delete $path(test1)
    set f [open $path(test1) w]
    close $f
    set f [open $path(test1) r]
    testchannelevent $f add readable [namespace code [list delrecursive $f]]
    proc delrecursive {f} {
	variable z
................................................................................
	    update
	}
    }
    variable u toplevel
    variable z ""
    update
    close $f
    string compare [string tolower $z] \
	{{delrecursive calling recursive} {delrecursive deleting recursive}}
} 0
test io-50.5 {testing handler deletion vs reentrant calls} {testchannelevent} {
    file delete $path(test1)
    set f [open $path(test1) w]
    close $f
    set f [open $path(test1) r]
    testchannelevent $f add readable [namespace code [list notcalled $f]]
    testchannelevent $f add readable [namespace code [list del $f]]
    proc notcalled {f} {
................................................................................
	    lappend z "del after update"
	}
    }
    set z ""
    set u toplevel
    update
    close $f
    string compare [string tolower $z] \
	[list {del calling recursive} {del deleted notcalled} \
	      {del deleted myself} {del after update}]
} 0
test io-50.6 {testing handler deletion vs reentrant calls} {testchannelevent} {
    file delete $path(test1)
    set f [open $path(test1) w]
    close $f
    set f [open $path(test1) r]
    testchannelevent $f add readable [namespace code [list second $f]]
    testchannelevent $f add readable [namespace code [list first $f]]
    proc first {f} {
................................................................................
	    testchannelevent $f removeall
	}
    }
    set z ""
    set u toplevel
    update
    close $f
    string compare [string tolower $z] \
	[list {first called} {first called not toplevel} \
	      {second called, first time} {second called, second time} \
	      {first after update}]
} 0

test io-51.1 {Test old socket deletion on Macintosh} {socket} {
    set x 0
    set result ""
    proc accept {s a p} {
	variable x
	variable wait

    lappend l [gets $f]
    lappend l [tell $f]
    lappend l [eof $f]
    close $f
    set l
} [list 7 a\rb\rc 7 {} 7 1]

test io-50.1 {testing handler deletion} {testchannelevent nonPortable} {
    file delete $path(test1)
    set f [open $path(test1) w]
    close $f
    set f [open $path(test1) r]
    testchannelevent $f add readable [namespace code [list delhandler $f]]
    proc delhandler {f} {
	variable z
................................................................................
	testchannelevent $f delete 0
    }
    set z not_called
    update
    close $f
    set z
} called
test io-50.2 {testing handler deletion with multiple handlers} {testchannelevent nonPortable} {
    file delete $path(test1)
    set f [open $path(test1) w]
    close $f
    set f [open $path(test1) r]
    testchannelevent $f add readable [namespace code [list delhandler $f 1]]
    testchannelevent $f add readable [namespace code [list delhandler $f 0]]
    proc delhandler {f i} {
................................................................................
    }
    set z ""
    update
    close $f
    string compare [string tolower $z] \
	[list [list called delhandler $f 0] [list called delhandler $f 1]]
} 0
test io-50.3 {testing handler deletion with multiple handlers} {testchannelevent nonPortable} {
    file delete $path(test1)
    set f [open $path(test1) w]
    close $f
    set f [open $path(test1) r]
    testchannelevent $f add readable [namespace code [list notcalled $f 1]]
    testchannelevent $f add readable [namespace code [list delhandler $f 0]]
    set z ""
................................................................................
    set z ""
    update
    close $f
    string compare [string tolower $z] \
	[list [list delhandler $f 0 called] \
	      [list delhandler $f 0 deleted myself]]
} 0
test io-50.4 {testing handler deletion vs reentrant calls} {testchannelevent nonPortable} {
    file delete $path(test1)
    set f [open $path(test1) w]
    close $f
    set f [open $path(test1) r]
    testchannelevent $f add readable [namespace code [list delrecursive $f]]
    proc delrecursive {f} {
	variable z
................................................................................
	    update
	}
    }
    variable u toplevel
    variable z ""
    update
    close $f
    set z
} {{delrecursive calling recursive} {delrecursive deleting recursive}}

test io-50.5 {testing handler deletion vs reentrant calls} {testchannelevent nonPortable} {
    file delete $path(test1)
    set f [open $path(test1) w]
    close $f
    set f [open $path(test1) r]
    testchannelevent $f add readable [namespace code [list notcalled $f]]
    testchannelevent $f add readable [namespace code [list del $f]]
    proc notcalled {f} {
................................................................................
	    lappend z "del after update"
	}
    }
    set z ""
    set u toplevel
    update
    close $f
    set z	
} [list {del calling recursive} {del deleted notcalled} \
	{del deleted myself} {del after update}]

test io-50.6 {testing handler deletion vs reentrant calls} {testchannelevent nonPortable} {
    file delete $path(test1)
    set f [open $path(test1) w]
    close $f
    set f [open $path(test1) r]
    testchannelevent $f add readable [namespace code [list second $f]]
    testchannelevent $f add readable [namespace code [list first $f]]
    proc first {f} {
................................................................................
	    testchannelevent $f removeall
	}
    }
    set z ""
    set u toplevel
    update
    close $f
    set z
} [list {first called} {first called not toplevel} \
	{second called, first time} {second called, second time} \
	{first after update}]


test io-51.1 {Test old socket deletion on Macintosh} {socket} {
    set x 0
    set result ""
    proc accept {s a p} {
	variable x
	variable wait

# this file, and for a DISCLAIMER OF ALL WARRANTIES.

if {"::tcltest" ni [namespace children]} {
    package require tcltest 2.3.3
    namespace import -force ::tcltest::*
}

# Do all this in a slave interp to avoid garbaging the package list
set i [interp create]
tcltest::loadIntoSlaveInterpreter $i {*}$argv
interp eval $i {
namespace import -force ::tcltest::*
package forget {*}[package names]
set oldPkgUnknown [package unknown]
package unknown {}
set oldPath $auto_path
set auto_path ""
................................................................................
test package-4.56 {Tcl_PackageCmd procedure, "vsatisfies" option} -body {
    package vsatisfies 2.1 x.y-3.2
} -returnCodes error -result {expected version number but got "x.y"}

# No tests for FindPackage; can't think up anything detectable errors.

test package-5.1 {TclFreePackageInfo procedure} {
    interp create slave
    slave eval {
	package ifneeded t 2.3 x
	package ifneeded t 2.4 y
	package ifneeded x 3.1 z
	package provide q 4.3
	package unknown "will this get freed?"
    }
    interp delete slave
} {}
test package-5.2 {TclFreePackageInfo procedure} -body {
    interp create foo
    foo eval {
	package ifneeded t 2.3 x
	package ifneeded t 2.4 y
	package ifneeded x 3.1 z

# this file, and for a DISCLAIMER OF ALL WARRANTIES.

if {"::tcltest" ni [namespace children]} {
    package require tcltest 2.3.3
    namespace import -force ::tcltest::*
}

# Do all this in a child interp to avoid garbaging the package list
set i [interp create]
tcltest::loadIntoChildInterpreter $i {*}$argv
interp eval $i {
namespace import -force ::tcltest::*
package forget {*}[package names]
set oldPkgUnknown [package unknown]
package unknown {}
set oldPath $auto_path
set auto_path ""
................................................................................
test package-4.56 {Tcl_PackageCmd procedure, "vsatisfies" option} -body {
    package vsatisfies 2.1 x.y-3.2
} -returnCodes error -result {expected version number but got "x.y"}

# No tests for FindPackage; can't think up anything detectable errors.

test package-5.1 {TclFreePackageInfo procedure} {
    interp create child
    child eval {
	package ifneeded t 2.3 x
	package ifneeded t 2.4 y
	package ifneeded x 3.1 z
	package provide q 4.3
	package unknown "will this get freed?"
    }
    interp delete child
} {}
test package-5.2 {TclFreePackageInfo procedure} -body {
    interp create foo
    foo eval {
	package ifneeded t 2.3 x
	package ifneeded t 2.4 y
	package ifneeded x 3.1 z

test socket_$af-5.1 {byte order problems, socket numbers, htons} -body {
    if {![catch {socket -server dodo 0x1} msg]} {
	close $msg
        return {htons problem, should be disallowed, are you running as SU?}
    }
    return {couldn't open socket: not owner}
} -constraints [list socket supported_$af unix notRoot] -result {couldn't open socket: not owner}
test socket_$af-5.2 {byte order problems, socket numbers, htons} -body {
    if {![catch {socket -server dodo 0x10000} msg]} {
	close $msg
	return {port resolution problem, should be disallowed}
    }
    return {couldn't open socket: port number too high}
} -constraints [list socket supported_$af] -result {couldn't open socket: port number too high}
test socket_$af-5.3 {byte order problems, socket numbers, htons} -body {
    if {![catch {socket -server dodo 21} msg]} {
	close $msg
	return {htons problem, should be disallowed, are you running as SU?}
    }
    return {couldn't open socket: not owner}
} -constraints [list socket supported_$af unix notRoot] -result {couldn't open socket: not owner}

test socket_$af-6.1 {accept callback error} -constraints [list socket supported_$af stdio] -setup {
    proc myHandler {msg options} {
	variable x $msg
    }
    set handler [interp bgerror {}]
    interp bgerror {} [namespace which myHandler]

test socket_$af-5.1 {byte order problems, socket numbers, htons} -body {
    if {![catch {socket -server dodo 0x1} msg]} {
	close $msg
        return {htons problem, should be disallowed, are you running as SU?}
    }
    return {couldn't open socket: not owner}
} -constraints [list socket supported_$af unix notRoot notOSX] -result {couldn't open socket: not owner}
test socket_$af-5.2 {byte order problems, socket numbers, htons} -body {
    if {![catch {socket -server dodo 0x10000} msg]} {
	close $msg
	return {port resolution problem, should be disallowed}
    }
    return {couldn't open socket: port number too high}
} -constraints [list socket supported_$af] -result {couldn't open socket: port number too high}
test socket_$af-5.3 {byte order problems, socket numbers, htons} -body {
    if {![catch {socket -server dodo 21} msg]} {
	close $msg
	return {htons problem, should be disallowed, are you running as SU?}
    }
    return {couldn't open socket: not owner}
} -constraints [list socket supported_$af unix notRoot notOSX] -result {couldn't open socket: not owner}

test socket_$af-6.1 {accept callback error} -constraints [list socket supported_$af stdio] -setup {
    proc myHandler {msg options} {
	variable x $msg
    }
    set handler [interp bgerror {}]
    interp bgerror {} [namespace which myHandler]

typedef struct ThreadSpecificData {
    char nabuf[16];
} ThreadSpecificData;

static Tcl_ThreadDataKey dataKey;

/*
 * masterLock is used to serialize creation of mutexes, condition variables,
 * and thread local storage. This is the only place that can count on the
 * ability to statically initialize the mutex.
 */

static pthread_mutex_t masterLock = PTHREAD_MUTEX_INITIALIZER;

/*
 * initLock is used to serialize initialization and finalization of Tcl. It
 * cannot use any dyamically allocated storage.
 */

static pthread_mutex_t initLock = PTHREAD_MUTEX_INITIALIZER;

/*
 * allocLock is used by Tcl's version of malloc for synchronization. For
 * obvious reasons, cannot use any dyamically allocated storage.
 */

static pthread_mutex_t allocLock = PTHREAD_MUTEX_INITIALIZER;
static pthread_mutex_t *allocLockPtr = &allocLock;

/*
 * These are for the critical sections inside this file.
 */

#define MASTER_LOCK	pthread_mutex_lock(&masterLock)
#define MASTER_UNLOCK	pthread_mutex_unlock(&masterLock)

#endif /* TCL_THREADS */
 
/*
 *----------------------------------------------------------------------
 *
 * TclpThreadCreate --
................................................................................
void
TclFinalizeLock(void)
{
#ifdef TCL_THREADS
    /*
     * You do not need to destroy mutexes that were created with the
     * PTHREAD_MUTEX_INITIALIZER macro. These mutexes do not need any
     * destruction: masterLock, allocLock, and initLock.
     */

    pthread_mutex_unlock(&initLock);
#endif
}
 
/*
................................................................................
    pthread_mutex_unlock(&initLock);
#endif
}
 
/*
 *----------------------------------------------------------------------
 *
 * TclpMasterLock
 *
 *	This procedure is used to grab a lock that serializes creation and
 *	finalization of serialization objects. This interface is only needed
 *	in finalization; it is hidden during creation of the objects.
 *
 *	This lock must be different than the initLock because the initLock is
 *	held during creation of synchronization objects.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	Acquire the master mutex.
 *
 *----------------------------------------------------------------------
 */

void
TclpMasterLock(void)
{
#ifdef TCL_THREADS
    pthread_mutex_lock(&masterLock);
#endif
}

 
/*
 *----------------------------------------------------------------------
 *
 * TclpMasterUnlock
 *
 *	This procedure is used to release a lock that serializes creation and
 *	finalization of synchronization objects.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	Release the master mutex.
 *
 *----------------------------------------------------------------------
 */

void
TclpMasterUnlock(void)
{
#ifdef TCL_THREADS
    pthread_mutex_unlock(&masterLock);
#endif
}
 
/*
 *----------------------------------------------------------------------
 *
 * Tcl_GetAllocMutex
 *
 *	This procedure returns a pointer to a statically initialized mutex for
 *	use by the memory allocator. The alloctor must use this lock, because
 *	all other locks are allocated...
 *
 * Results:
 *	A pointer to a mutex that is suitable for passing to Tcl_MutexLock and
 *	Tcl_MutexUnlock.
 *
 * Side effects:
................................................................................
void
Tcl_MutexLock(
    Tcl_Mutex *mutexPtr)	/* Really (pthread_mutex_t **) */
{
    pthread_mutex_t *pmutexPtr;

    if (*mutexPtr == NULL) {
	MASTER_LOCK;
	if (*mutexPtr == NULL) {
	    /*
	     * Double inside master lock check to avoid a race condition.
	     */

	    pmutexPtr = ckalloc(sizeof(pthread_mutex_t));
	    pthread_mutex_init(pmutexPtr, NULL);
	    *mutexPtr = (Tcl_Mutex)pmutexPtr;
	    TclRememberMutex(mutexPtr);
	}
	MASTER_UNLOCK;
    }
    pmutexPtr = *((pthread_mutex_t **)mutexPtr);
    pthread_mutex_lock(pmutexPtr);
}
 
/*
 *----------------------------------------------------------------------
................................................................................
 *----------------------------------------------------------------------
 *
 * TclpFinalizeMutex --
 *
 *	This procedure is invoked to clean up one mutex. This is only safe to
 *	call at the end of time.
 *
 *	This assumes the Master Lock is held.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	The mutex list is deallocated.
 *
................................................................................
    pthread_mutex_t *pmutexPtr;
    struct timespec ptime;
#if defined(HAVE_CLOCK_GETTIME) && defined(HAVE_PTHREAD_CONDATTR_SETCLOCK)
    int *monoFlagPtr;
#endif

    if (*condPtr == NULL) {
	MASTER_LOCK;

	/*
	 * Double check inside mutex to avoid race, then initialize condition
	 * variable if necessary.
	 */

	if (*condPtr == NULL) {
................................................................................
#else
	    pcondPtr = ckalloc(sizeof(pthread_cond_t));
	    pthread_cond_init(pcondPtr, NULL);
#endif
	    *condPtr = (Tcl_Condition) pcondPtr;
	    TclRememberCondition(condPtr);
	}
	MASTER_UNLOCK;
    }
    pmutexPtr = *((pthread_mutex_t **)mutexPtr);
    pcondPtr = *((pthread_cond_t **)condPtr);
    if (timePtr == NULL) {
	pthread_cond_wait(pcondPtr, pmutexPtr);
    } else {
#if defined(HAVE_CLOCK_GETTIME) && defined(HAVE_PTHREAD_CONDATTR_SETCLOCK)
................................................................................
 *----------------------------------------------------------------------
 *
 * TclpFinalizeCondition --
 *
 *	This procedure is invoked to clean up a condition variable. This is
 *	only safe to call at the end of time.
 *
 *	This assumes the Master Lock is held.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	The condition variable is deallocated.
 *
................................................................................
	Tcl_Panic("unable to delete key!");
    }

    TclpSysFree(keyPtr);
}

void
TclpThreadSetMasterTSD(
    void *tsdKeyPtr,
    void *ptr)
{
    pthread_key_t *ptkeyPtr = tsdKeyPtr;

    if (pthread_setspecific(*ptkeyPtr, ptr)) {
	Tcl_Panic("unable to set master TSD value");
    }
}

void *
TclpThreadGetMasterTSD(
    void *tsdKeyPtr)
{
    pthread_key_t *ptkeyPtr = tsdKeyPtr;

    return pthread_getspecific(*ptkeyPtr);
}

typedef struct ThreadSpecificData {
    char nabuf[16];
} ThreadSpecificData;

static Tcl_ThreadDataKey dataKey;

/*
 * globalLock is used to serialize creation of mutexes, condition variables,
 * and thread local storage. This is the only place that can count on the
 * ability to statically initialize the mutex.
 */

static pthread_mutex_t globalLock = PTHREAD_MUTEX_INITIALIZER;

/*
 * initLock is used to serialize initialization and finalization of Tcl. It
 * cannot use any dynamically allocated storage.
 */

static pthread_mutex_t initLock = PTHREAD_MUTEX_INITIALIZER;

/*
 * allocLock is used by Tcl's version of malloc for synchronization. For
 * obvious reasons, cannot use any dynamically allocated storage.
 */

static pthread_mutex_t allocLock = PTHREAD_MUTEX_INITIALIZER;
static pthread_mutex_t *allocLockPtr = &allocLock;

/*
 * These are for the critical sections inside this file.
 */

#define GLOBAL_LOCK	pthread_mutex_lock(&globalLock)
#define GLOBAL_UNLOCK	pthread_mutex_unlock(&globalLock)

#endif /* TCL_THREADS */
 
/*
 *----------------------------------------------------------------------
 *
 * TclpThreadCreate --
................................................................................
void
TclFinalizeLock(void)
{
#ifdef TCL_THREADS
    /*
     * You do not need to destroy mutexes that were created with the
     * PTHREAD_MUTEX_INITIALIZER macro. These mutexes do not need any
     * destruction: globalLock, allocLock, and initLock.
     */

    pthread_mutex_unlock(&initLock);
#endif
}
 
/*
................................................................................
    pthread_mutex_unlock(&initLock);
#endif
}
 
/*
 *----------------------------------------------------------------------
 *
 * TclpGlobalLock
 *
 *	This procedure is used to grab a lock that serializes creation and
 *	finalization of serialization objects. This interface is only needed
 *	in finalization; it is hidden during creation of the objects.
 *
 *	This lock must be different than the initLock because the initLock is
 *	held during creation of synchronization objects.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	Acquire the global mutex.
 *
 *----------------------------------------------------------------------
 */

void
TclpGlobalLock(void)
{
#ifdef TCL_THREADS
    pthread_mutex_lock(&globalLock);
#endif
}

 
/*
 *----------------------------------------------------------------------
 *
 * TclpGlobalUnlock
 *
 *	This procedure is used to release a lock that serializes creation and
 *	finalization of synchronization objects.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	Release the global mutex.
 *
 *----------------------------------------------------------------------
 */

void
TclpGlobalUnlock(void)
{
#ifdef TCL_THREADS
    pthread_mutex_unlock(&globalLock);
#endif
}
 
/*
 *----------------------------------------------------------------------
 *
 * Tcl_GetAllocMutex
 *
 *	This procedure returns a pointer to a statically initialized mutex for
 *	use by the memory allocator. The allocator must use this lock, because
 *	all other locks are allocated...
 *
 * Results:
 *	A pointer to a mutex that is suitable for passing to Tcl_MutexLock and
 *	Tcl_MutexUnlock.
 *
 * Side effects:
................................................................................
void
Tcl_MutexLock(
    Tcl_Mutex *mutexPtr)	/* Really (pthread_mutex_t **) */
{
    pthread_mutex_t *pmutexPtr;

    if (*mutexPtr == NULL) {
	GLOBAL_LOCK;
	if (*mutexPtr == NULL) {
	    /*
	     * Double inside global lock check to avoid a race condition.
	     */

	    pmutexPtr = ckalloc(sizeof(pthread_mutex_t));
	    pthread_mutex_init(pmutexPtr, NULL);
	    *mutexPtr = (Tcl_Mutex)pmutexPtr;
	    TclRememberMutex(mutexPtr);
	}
	GLOBAL_UNLOCK;
    }
    pmutexPtr = *((pthread_mutex_t **)mutexPtr);
    pthread_mutex_lock(pmutexPtr);
}
 
/*
 *----------------------------------------------------------------------
................................................................................
 *----------------------------------------------------------------------
 *
 * TclpFinalizeMutex --
 *
 *	This procedure is invoked to clean up one mutex. This is only safe to
 *	call at the end of time.
 *
 *	This assumes the Global Lock is held.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	The mutex list is deallocated.
 *
................................................................................
    pthread_mutex_t *pmutexPtr;
    struct timespec ptime;
#if defined(HAVE_CLOCK_GETTIME) && defined(HAVE_PTHREAD_CONDATTR_SETCLOCK)
    int *monoFlagPtr;
#endif

    if (*condPtr == NULL) {
	GLOBAL_LOCK;

	/*
	 * Double check inside mutex to avoid race, then initialize condition
	 * variable if necessary.
	 */

	if (*condPtr == NULL) {
................................................................................
#else
	    pcondPtr = ckalloc(sizeof(pthread_cond_t));
	    pthread_cond_init(pcondPtr, NULL);
#endif
	    *condPtr = (Tcl_Condition) pcondPtr;
	    TclRememberCondition(condPtr);
	}
	GLOBAL_UNLOCK;
    }
    pmutexPtr = *((pthread_mutex_t **)mutexPtr);
    pcondPtr = *((pthread_cond_t **)condPtr);
    if (timePtr == NULL) {
	pthread_cond_wait(pcondPtr, pmutexPtr);
    } else {
#if defined(HAVE_CLOCK_GETTIME) && defined(HAVE_PTHREAD_CONDATTR_SETCLOCK)
................................................................................
 *----------------------------------------------------------------------
 *
 * TclpFinalizeCondition --
 *
 *	This procedure is invoked to clean up a condition variable. This is
 *	only safe to call at the end of time.
 *
 *	This assumes the Global Lock is held.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	The condition variable is deallocated.
 *
................................................................................
	Tcl_Panic("unable to delete key!");
    }

    TclpSysFree(keyPtr);
}

void
TclpThreadSetGlobalTSD(
    void *tsdKeyPtr,
    void *ptr)
{
    pthread_key_t *ptkeyPtr = tsdKeyPtr;

    if (pthread_setspecific(*ptkeyPtr, ptr)) {
	Tcl_Panic("unable to set global TSD value");
    }
}

void *
TclpThreadGetGlobalTSD(
    void *tsdKeyPtr)
{
    pthread_key_t *ptkeyPtr = tsdKeyPtr;

    return pthread_getspecific(*ptkeyPtr);
}

#   define	_MCW_EM		0x0008001F	/* Error masks */
#   define	_MCW_RC		0x00000300	/* Rounding */
#   define	_MCW_PC		0x00030000	/* Precision */
_CRTIMP unsigned int __cdecl _controlfp (unsigned int unNew, unsigned int unMask);
#endif

/*
 * This is the master lock used to serialize access to other serialization
 * data structures.
 */

static CRITICAL_SECTION masterLock;
static int init = 0;
#define MASTER_LOCK TclpMasterLock()
#define MASTER_UNLOCK TclpMasterUnlock()


/*
 * This is the master lock used to serialize initialization and finalization
 * of Tcl as a whole.
 */

static CRITICAL_SECTION initLock;

/*
 * allocLock is used by Tcl's version of malloc for synchronization. For
 * obvious reasons, cannot use any dyamically allocated storage.
 */

#ifdef TCL_THREADS

static struct Tcl_Mutex_ {
    CRITICAL_SECTION crit;
} allocLock;
................................................................................
	 * interpreter has been created, it is safe to create more threads
	 * that create interpreters in parallel.
	 */

	init = 1;
	InitializeCriticalSection(&joinLock);
	InitializeCriticalSection(&initLock);
	InitializeCriticalSection(&masterLock);
    }
    EnterCriticalSection(&initLock);
}
 
/*
 *----------------------------------------------------------------------
 *
................................................................................
{
    LeaveCriticalSection(&initLock);
}
 
/*
 *----------------------------------------------------------------------
 *
 * TclpMasterLock
 *
 *	This procedure is used to grab a lock that serializes creation of
 *	mutexes, condition variables, and thread local storage keys.
 *
 *	This lock must be different than the initLock because the initLock is
 *	held during creation of synchronization objects.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	Acquire the master mutex.
 *
 *----------------------------------------------------------------------
 */

void
TclpMasterLock(void)
{
    if (!init) {
	/*
	 * There is a fundamental race here that is solved by creating the
	 * first Tcl interpreter in a single threaded environment. Once the
	 * interpreter has been created, it is safe to create more threads
	 * that create interpreters in parallel.
	 */

	init = 1;
	InitializeCriticalSection(&joinLock);
	InitializeCriticalSection(&initLock);
	InitializeCriticalSection(&masterLock);
    }
    EnterCriticalSection(&masterLock);
}
 
/*
 *----------------------------------------------------------------------
 *
 * TclpMasterUnlock
 *
 *	This procedure is used to release a lock that serializes creation and
 *	deletion of synchronization objects.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	Release the master mutex.
 *
 *----------------------------------------------------------------------
 */

void
TclpMasterUnlock(void)
{
    LeaveCriticalSection(&masterLock);
}
 
/*
 *----------------------------------------------------------------------
 *
 * Tcl_GetAllocMutex
 *
 *	This procedure returns a pointer to a statically initialized mutex for
 *	use by the memory allocator. The alloctor must use this lock, because
 *	all other locks are allocated...
 *
 * Results:
 *	A pointer to a mutex that is suitable for passing to Tcl_MutexLock and
 *	Tcl_MutexUnlock.
 *
 * Side effects:
................................................................................
 *
 *----------------------------------------------------------------------
 */

void
TclFinalizeLock(void)
{
    MASTER_LOCK;
    DeleteCriticalSection(&joinLock);

    /*
     * Destroy the critical section that we are holding!
     */

    DeleteCriticalSection(&masterLock);
    init = 0;

#ifdef TCL_THREADS
    if (allocOnce) {
	DeleteCriticalSection(&allocLock.crit);
	allocOnce = 0;
    }
................................................................................
void
Tcl_MutexLock(
    Tcl_Mutex *mutexPtr)	/* The lock */
{
    CRITICAL_SECTION *csPtr;

    if (*mutexPtr == NULL) {
	MASTER_LOCK;

	/*
	 * Double inside master lock check to avoid a race.
	 */

	if (*mutexPtr == NULL) {
	    csPtr = ckalloc(sizeof(CRITICAL_SECTION));
	    InitializeCriticalSection(csPtr);
	    *mutexPtr = (Tcl_Mutex)csPtr;
	    TclRememberMutex(mutexPtr);
	}
	MASTER_UNLOCK;
    }
    csPtr = *((CRITICAL_SECTION **)mutexPtr);
    EnterCriticalSection(csPtr);
}
 
/*
 *----------------------------------------------------------------------
................................................................................

    /*
     * Self initialize the two parts of the condition. The per-condition and
     * per-thread parts need to be handled independently.
     */

    if (tsdPtr->flags == WIN_THREAD_UNINIT) {
	MASTER_LOCK;

	/*
	 * Create the per-thread event and queue pointers.
	 */

	if (tsdPtr->flags == WIN_THREAD_UNINIT) {
	    tsdPtr->condEvent = CreateEventW(NULL, TRUE /* manual reset */,
		    FALSE /* non signaled */, NULL);
	    tsdPtr->nextPtr = NULL;
	    tsdPtr->prevPtr = NULL;
	    tsdPtr->flags = WIN_THREAD_RUNNING;
	    doExit = 1;
	}
	MASTER_UNLOCK;

	if (doExit) {
	    /*
	     * Create a per-thread exit handler to clean up the condEvent. We
	     * must be careful to do this outside the Master Lock because
	     * Tcl_CreateThreadExitHandler uses its own ThreadSpecificData,
	     * and initializing that may drop back into the Master Lock.
	     */

	    Tcl_CreateThreadExitHandler(FinalizeConditionEvent, tsdPtr);
	}
    }

    if (*condPtr == NULL) {
	MASTER_LOCK;

	/*
	 * Initialize the per-condition queue pointers and Mutex.
	 */

	if (*condPtr == NULL) {
	    winCondPtr = ckalloc(sizeof(WinCondition));
	    InitializeCriticalSection(&winCondPtr->condLock);
	    winCondPtr->firstPtr = NULL;
	    winCondPtr->lastPtr = NULL;
	    *condPtr = (Tcl_Condition) winCondPtr;
	    TclRememberCondition(condPtr);
	}
	MASTER_UNLOCK;
    }
    csPtr = *((CRITICAL_SECTION **)mutexPtr);
    winCondPtr = *((WinCondition **)condPtr);
    if (timePtr == NULL) {
	wtime = INFINITE;
    } else {
	wtime = timePtr->sec * 1000 + timePtr->usec / 1000;
................................................................................
 *----------------------------------------------------------------------
 *
 * TclpFinalizeCondition --
 *
 *	This procedure is invoked to clean up a condition variable. This is
 *	only safe to call at the end of time.
 *
 *	This assumes the Master Lock is held.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	The condition variable is deallocated.
 *
................................................................................
	Tcl_Panic("unable to delete key");
    }

    TclpSysFree(keyPtr);
}

void
TclpThreadSetMasterTSD(
    void *tsdKeyPtr,
    void *ptr)
{
    DWORD *key = tsdKeyPtr;

    if (!TlsSetValue(*key, ptr)) {
	Tcl_Panic("unable to set master TSD value");
    }
}

void *
TclpThreadGetMasterTSD(
    void *tsdKeyPtr)
{
    DWORD *key = tsdKeyPtr;

    return TlsGetValue(*key);
}

#   define	_MCW_EM		0x0008001F	/* Error masks */
#   define	_MCW_RC		0x00000300	/* Rounding */
#   define	_MCW_PC		0x00030000	/* Precision */
_CRTIMP unsigned int __cdecl _controlfp (unsigned int unNew, unsigned int unMask);
#endif

/*
 * This is the global lock used to serialize access to other serialization
 * data structures.
 */

static CRITICAL_SECTION globalLock;
static int init = 0;
#define GLOBAL_LOCK TclpGlobalLock()
#define GLOBAL_UNLOCK TclpGlobalUnlock()


/*
 * This is the global lock used to serialize initialization and finalization
 * of Tcl as a whole.
 */

static CRITICAL_SECTION initLock;

/*
 * allocLock is used by Tcl's version of malloc for synchronization. For
 * obvious reasons, cannot use any dynamically allocated storage.
 */

#ifdef TCL_THREADS

static struct Tcl_Mutex_ {
    CRITICAL_SECTION crit;
} allocLock;
................................................................................
	 * interpreter has been created, it is safe to create more threads
	 * that create interpreters in parallel.
	 */

	init = 1;
	InitializeCriticalSection(&joinLock);
	InitializeCriticalSection(&initLock);
	InitializeCriticalSection(&globalLock);
    }
    EnterCriticalSection(&initLock);
}
 
/*
 *----------------------------------------------------------------------
 *
................................................................................
{
    LeaveCriticalSection(&initLock);
}
 
/*
 *----------------------------------------------------------------------
 *
 * TclpGlobalLock
 *
 *	This procedure is used to grab a lock that serializes creation of
 *	mutexes, condition variables, and thread local storage keys.
 *
 *	This lock must be different than the initLock because the initLock is
 *	held during creation of synchronization objects.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	Acquire the global mutex.
 *
 *----------------------------------------------------------------------
 */

void
TclpGlobalLock(void)
{
    if (!init) {
	/*
	 * There is a fundamental race here that is solved by creating the
	 * first Tcl interpreter in a single threaded environment. Once the
	 * interpreter has been created, it is safe to create more threads
	 * that create interpreters in parallel.
	 */

	init = 1;
	InitializeCriticalSection(&joinLock);
	InitializeCriticalSection(&initLock);
	InitializeCriticalSection(&globalLock);
    }
    EnterCriticalSection(&globalLock);
}
 
/*
 *----------------------------------------------------------------------
 *
 * TclpGlobalUnlock
 *
 *	This procedure is used to release a lock that serializes creation and
 *	deletion of synchronization objects.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	Release the global mutex.
 *
 *----------------------------------------------------------------------
 */

void
TclpGlobalUnlock(void)
{
    LeaveCriticalSection(&globalLock);
}
 
/*
 *----------------------------------------------------------------------
 *
 * Tcl_GetAllocMutex
 *
 *	This procedure returns a pointer to a statically initialized mutex for
 *	use by the memory allocator. The allocator must use this lock, because
 *	all other locks are allocated...
 *
 * Results:
 *	A pointer to a mutex that is suitable for passing to Tcl_MutexLock and
 *	Tcl_MutexUnlock.
 *
 * Side effects:
................................................................................
 *
 *----------------------------------------------------------------------
 */

void
TclFinalizeLock(void)
{
    GLOBAL_LOCK;
    DeleteCriticalSection(&joinLock);

    /*
     * Destroy the critical section that we are holding!
     */

    DeleteCriticalSection(&globalLock);
    init = 0;

#ifdef TCL_THREADS
    if (allocOnce) {
	DeleteCriticalSection(&allocLock.crit);
	allocOnce = 0;
    }
................................................................................
void
Tcl_MutexLock(
    Tcl_Mutex *mutexPtr)	/* The lock */
{
    CRITICAL_SECTION *csPtr;

    if (*mutexPtr == NULL) {
	GLOBAL_LOCK;

	/*
	 * Double inside global lock check to avoid a race.
	 */

	if (*mutexPtr == NULL) {
	    csPtr = ckalloc(sizeof(CRITICAL_SECTION));
	    InitializeCriticalSection(csPtr);
	    *mutexPtr = (Tcl_Mutex)csPtr;
	    TclRememberMutex(mutexPtr);
	}
	GLOBAL_UNLOCK;
    }
    csPtr = *((CRITICAL_SECTION **)mutexPtr);
    EnterCriticalSection(csPtr);
}
 
/*
 *----------------------------------------------------------------------
................................................................................

    /*
     * Self initialize the two parts of the condition. The per-condition and
     * per-thread parts need to be handled independently.
     */

    if (tsdPtr->flags == WIN_THREAD_UNINIT) {
	GLOBAL_LOCK;

	/*
	 * Create the per-thread event and queue pointers.
	 */

	if (tsdPtr->flags == WIN_THREAD_UNINIT) {
	    tsdPtr->condEvent = CreateEventW(NULL, TRUE /* manual reset */,
		    FALSE /* non signaled */, NULL);
	    tsdPtr->nextPtr = NULL;
	    tsdPtr->prevPtr = NULL;
	    tsdPtr->flags = WIN_THREAD_RUNNING;
	    doExit = 1;
	}
	GLOBAL_UNLOCK;

	if (doExit) {
	    /*
	     * Create a per-thread exit handler to clean up the condEvent. We
	     * must be careful to do this outside the Global Lock because
	     * Tcl_CreateThreadExitHandler uses its own ThreadSpecificData,
	     * and initializing that may drop back into the Global Lock.
	     */

	    Tcl_CreateThreadExitHandler(FinalizeConditionEvent, tsdPtr);
	}
    }

    if (*condPtr == NULL) {
	GLOBAL_LOCK;

	/*
	 * Initialize the per-condition queue pointers and Mutex.
	 */

	if (*condPtr == NULL) {
	    winCondPtr = ckalloc(sizeof(WinCondition));
	    InitializeCriticalSection(&winCondPtr->condLock);
	    winCondPtr->firstPtr = NULL;
	    winCondPtr->lastPtr = NULL;
	    *condPtr = (Tcl_Condition) winCondPtr;
	    TclRememberCondition(condPtr);
	}
	GLOBAL_UNLOCK;
    }
    csPtr = *((CRITICAL_SECTION **)mutexPtr);
    winCondPtr = *((WinCondition **)condPtr);
    if (timePtr == NULL) {
	wtime = INFINITE;
    } else {
	wtime = timePtr->sec * 1000 + timePtr->usec / 1000;
................................................................................
 *----------------------------------------------------------------------
 *
 * TclpFinalizeCondition --
 *
 *	This procedure is invoked to clean up a condition variable. This is
 *	only safe to call at the end of time.
 *
 *	This assumes the Global Lock is held.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	The condition variable is deallocated.
 *
................................................................................
	Tcl_Panic("unable to delete key");
    }

    TclpSysFree(keyPtr);
}

void
TclpThreadSetGlobalTSD(
    void *tsdKeyPtr,
    void *ptr)
{
    DWORD *key = tsdKeyPtr;

    if (!TlsSetValue(*key, ptr)) {
	Tcl_Panic("unable to set global TSD value");
    }
}

void *
TclpThreadGetGlobalTSD(
    void *tsdKeyPtr)
{
    DWORD *key = tsdKeyPtr;

    return TlsGetValue(*key);
}