Tcl Source Code

 *
 *	Display the global memory management statistics.
 *
 *----------------------------------------------------------------------
 */

int
TclDumpMemoryInfo(
    ClientData clientData,
    int flags)
{
    char buf[1024];

    if (clientData == NULL) {
        return 0;
    }
    sprintf(buf,
	    "total mallocs             %10d\n"
	    "total frees               %10d\n"
	    "current packets allocated %10d\n"
	    "current bytes allocated   %10lu\n"
	    "maximum packets allocated %10d\n"
	    "maximum bytes allocated   %10lu\n",

Tcl_ValidateAllMemory(
    const char *file,
    int line)
{
}

int
TclDumpMemoryInfo(
    ClientData clientData,
    int flags)
{
    return 1;
}

#endif	/* TCL_MEM_DEBUG */

/*

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

static void
ReflectThread(
    ClientData clientData,
    int action)
{
    ReflectedChannel *rcPtr = clientData;

    switch (action) {
    case TCL_CHANNEL_THREAD_INSERT:
        rcPtr->owner = Tcl_GetCurrentThread();
        break;

TclFSEpochOk(
    int filesystemEpoch)
{
    return (filesystemEpoch == 0 || filesystemEpoch == theFilesystemEpoch);
}

static void
Claim(void)
{
    ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&fsDataKey);

    tsdPtr->claims++;
}

static void
Disclaim(void)
{
    ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&fsDataKey);

    tsdPtr->claims--;
}

int
TclFSEpoch(void)
{
    ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&fsDataKey);

    return tsdPtr->filesystemEpoch;
}


/*
 * If non-NULL, clientData is owned by us and must be freed later.
 */

 * Copyright (c) 1994-1997 Sun Microsystems, Inc.
 * Copyright (c) 2000 Ajuba Solutions.
 *
 * See the file "license.terms" for information on usage and redistribution of
 * this file, and for a DISCLAIMER OF ALL WARRANTIES.
 */

/*
 * On Windows, this file needs to be compiled twice, once with TCL_ASCII_MAIN
 * defined. This way both Tcl_Main and Tcl_MainExW can be implemented, sharing
 * the same source code.
 */

#if defined(TCL_ASCII_MAIN)
#   ifdef UNICODE
#	undef UNICODE
#	undef _UNICODE
#   else
#	define UNICODE
#	define _UNICODE
#   endif
#endif

#include "tclInt.h"

/*
 * The default prompt used when the user has not overridden it.
 */

#define DEFAULT_PRIMARY_PROMPT	"% "

/*
 * This file can be compiled on Windows in UNICODE mode, as well as on all
 * other platforms using the native encoding. This is done by using the normal
 * Windows functions like _tcscmp, but on platforms which don't have <tchar.h>
 * we have to translate that to strcmp here.

 */

#ifndef __WIN32__
#   define TCHAR char
#   define TEXT(arg) arg
#   define _tcscmp strcmp
#endif

/*

/*
 * Forward declarations for functions defined later in this file.
 */

MODULE_SCOPE Tcl_MainLoopProc *TclGetMainLoop(void);
static void		Prompt(Tcl_Interp *interp, InteractiveState *isPtr);
static void		StdinProc(ClientData clientData, int mask);
static void		FreeMainInterp(ClientData clientData);

#ifndef TCL_ASCII_MAIN
static Tcl_ThreadDataKey dataKey;

/*
 *----------------------------------------------------------------------
 *
 * Tcl_SetStartupScript --
 *
 *	Sets the path and encoding of the startup script to be evaluated by
 *	Tcl_Main, used to override the command line processing.

	 *  -encoding ENCODING FILENAME
	 * or like
	 *  FILENAME
	 */

	if ((argc > 3) && (0 == _tcscmp(TEXT("-encoding"), argv[1]))
		&& (TEXT('-') != argv[3][0])) {
	    Tcl_Obj *value = NewNativeObj(argv[2], -1);
	    Tcl_SetStartupScript(NewNativeObj(argv[3], -1),
		    Tcl_GetString(value));
	    Tcl_DecrRefCount(value);
	    argc -= 3;
	    argv += 3;
	} else if ((argc > 1) && (TEXT('-') != argv[1][0])) {
	    Tcl_SetStartupScript(NewNativeObj(argv[1], -1), NULL);
	    argc--;
	    argv++;

    if (Tcl_LimitExceeded(interp)) {
	goto done;
    }
    if (TclFullFinalizationRequested()) {
	/*
	 * Arrange for final deletion of the main interp
	 */

	/* ARGH Munchhausen effect */
	Tcl_CreateExitHandler(FreeMainInterp, interp);
    }

    /*
     * Invoke the script specified on the command line, if any. Must fetch it
     * again, as the appInitProc might have reset it.
     */

    Tcl_LinkVar(interp, "tcl_interactive", (char *) &is.tty, TCL_LINK_BOOLEAN);
    is.input = Tcl_GetStdChannel(TCL_STDIN);
    while ((is.input != NULL) && !Tcl_InterpDeleted(interp)) {
	mainLoopProc = TclGetMainLoop();
	if (mainLoopProc == NULL) {
	    int length;

	    if (is.tty) {
		Prompt(interp, &is);
		if (Tcl_InterpDeleted(interp)) {
		    break;
		}
		if (Tcl_LimitExceeded(interp)) {
		    break;

	    /*
	     * The final newline is syntactically redundant, and causes some
	     * error messages troubles deeper in, so lop it back off.
	     */

	    Tcl_GetStringFromObj(is.commandPtr, &length);
	    Tcl_SetObjLength(is.commandPtr, --length);
	    code = Tcl_RecordAndEvalObj(interp, is.commandPtr,
		    TCL_EVAL_GLOBAL);
	    is.input = Tcl_GetStdChannel(TCL_STDIN);
	    Tcl_DecrRefCount(is.commandPtr);
	    is.commandPtr = Tcl_NewObj();
	    Tcl_IncrRefCount(is.commandPtr);
	    if (code != TCL_OK) {
		chan = Tcl_GetStdChannel(TCL_STDERR);
		if (chan) {

	     */

	    if (is.input) {
		if (is.tty) {
		    Prompt(interp, &is);
		}

		Tcl_CreateChannelHandler(is.input, TCL_READABLE,
			StdinProc, &is);
	    }

	    mainLoopProc();
	    Tcl_SetMainLoop(NULL);

	    if (is.input) {
		Tcl_DeleteChannelHandler(is.input, StdinProc, &is);
	    }
	    is.input = Tcl_GetStdChannel(TCL_STDIN);
	}


	/*
	 * This code here only for the (unsupported and deprecated) [checkmem]
	 * command.
	 */

#ifdef TCL_MEM_DEBUG
	if (tclMemDumpFileName != NULL) {
	    Tcl_SetMainLoop(NULL);
	    Tcl_DeleteInterp(interp);
	}
#endif /* TCL_MEM_DEBUG */
    }

  done:
    mainLoopProc = TclGetMainLoop();
    if ((exitCode == 0) && mainLoopProc && !Tcl_LimitExceeded(interp)) {

	/*
	 * If everything has gone OK so far, call the main loop proc, if it
	 * exists. Packages (like Tk) can set it to start processing events at
	 * this point.
	 */

	mainLoopProc();
	Tcl_SetMainLoop(NULL);
    }
    if (is.commandPtr != NULL) {
	Tcl_DecrRefCount(is.commandPtr);
    }

    /*
     * Rather than calling exit, invoke the "exit" command so that users can
     * replace "exit" with some other command to do additional cleanup on
     * exit. The Tcl_EvalObjEx call should never return.
     */

    if (!Tcl_InterpDeleted(interp) && !Tcl_LimitExceeded(interp)) {

	Tcl_Obj *cmd = Tcl_ObjPrintf("exit %d", exitCode);
	    
	Tcl_IncrRefCount(cmd);
	Tcl_EvalObjEx(interp, cmd, TCL_EVAL_GLOBAL);
	Tcl_DecrRefCount(cmd);
    }

    /*
     * If Tcl_EvalObjEx returns, trying to eval [exit], something unusual is
     * happening. Maybe interp has been deleted; maybe [exit] was redefined,
     * maybe we've blown up because of an exceeded limit. We still want to
     * cleanup and exit.
     */

    Tcl_Exit(exitCode);
}

#if (TCL_MAJOR_VERSION == 8) && !defined(UNICODE)
#undef Tcl_Main
extern DLLEXPORT void
Tcl_Main(
    int argc,			/* Number of arguments. */
    char **argv,		/* Array of argument strings. */
    Tcl_AppInitProc *appInitProc)
				/* Application-specific initialization
				 * function to call after most initialization
				 * but before starting to execute commands. */
{
    Tcl_FindExecutable(argv[0]);
    Tcl_MainEx(argc, argv, appInitProc, Tcl_CreateInterp());
}
#endif /* TCL_MAJOR_VERSION == 8 && !UNICODE */

#ifndef TCL_ASCII_MAIN

/*
 *---------------------------------------------------------------
 *
 * Tcl_SetMainLoop --

 *	hunting etc).
 *
 * Results:
 *	A boolean.
 *
 *----------------------------------------------------------------------
 */

MODULE_SCOPE int
TclFullFinalizationRequested(void)
{
#ifdef PURIFY
    return 1;
#else
    const char *fin;
    Tcl_DString ds;
    int finalize = 0;
    
    fin = TclGetEnv("TCL_FINALIZE_ON_EXIT", &ds);
    finalize = ((fin != NULL) && strcmp(fin, "0"));
    if (fin != NULL) {
	Tcl_DStringFree(&ds);
    }
    return finalize;
#endif /* PURIFY */
}
#endif /* !TCL_ASCII_MAIN */

/*
 *----------------------------------------------------------------------
 *
 * StdinProc --

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

static void
Prompt(
    Tcl_Interp *interp,		/* Interpreter to use for prompting. */
    InteractiveState *isPtr)	/* InteractiveState. Filled with PROMPT_NONE
				 * after a prompt is printed. */

{
    Tcl_Obj *promptCmdPtr;
    int code;
    Tcl_Channel chan;

    if (isPtr->prompt == PROMPT_NONE) {
	return;
    }

    promptCmdPtr = Tcl_GetVar2Ex(interp,
	    (isPtr->prompt==PROMPT_CONTINUE ? "tcl_prompt2" : "tcl_prompt1"),
	    NULL, TCL_GLOBAL_ONLY);

    if (Tcl_InterpDeleted(interp)) {
	return;
    }
    if (promptCmdPtr == NULL) {
    defaultPrompt:

}

/*
 *----------------------------------------------------------------------
 *
 * FreeMainInterp --
 *
 *	Exit handler used to cleanup the main interpreter and ancillary
 *	startup script storage at exit.
 *
 *----------------------------------------------------------------------
 */

static void
FreeMainInterp(
    ClientData clientData)
{
    Tcl_Interp *interp = clientData;

    /*if (TclInExit()) return;*/

    if (!Tcl_InterpDeleted(interp)) {
	Tcl_DeleteInterp(interp);
    }
    Tcl_SetStartupScript(NULL, NULL);
    Tcl_Release(interp);
}

/*
 * Local Variables:
 * mode: c
 * c-basic-offset: 4
 * fill-column: 78
 * End:
 */

Tcl_DiscardResult(
    Tcl_SavedResult *statePtr)	/* State returned by Tcl_SaveResult. */
{
    TclDecrRefCount(statePtr->objResultPtr);

    if (statePtr->result == statePtr->appendResult) {
	ckfree(statePtr->appendResult);
    } else if (statePtr->freeProc == TCL_DYNAMIC) {

        ckfree(statePtr->result);
    } else if (statePtr->freeProc) {
        statePtr->freeProc(statePtr->result);

    }
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_SetResult --

    int length;

    /*
     * If the string result is non-empty, move the string result to the object
     * result, then reset the string result.
     */

    if (iPtr->result[0] != 0) {
	ResetObjResult(iPtr);

	objResultPtr = iPtr->objResultPtr;
	length = strlen(iPtr->result);
	TclInitStringRep(objResultPtr, iPtr->result, length);

	if (iPtr->freeProc != NULL) {
	    if (iPtr->freeProc == TCL_DYNAMIC) {
		ckfree(iPtr->result);
	    } else {
		iPtr->freeProc(iPtr->result);
	    }
	    iPtr->freeProc = 0;
	}
	iPtr->result = iPtr->resultSpace;
	iPtr->result[0] = 0;
    }
    return iPtr->objResultPtr;
}

/*
 *----------------------------------------------------------------------
 *

}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_GetErrorLine --
 *
 *      Returns the line number associated with the current error.


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

int
Tcl_GetErrorLine(
    Tcl_Interp *interp)
{
    return ((Interp *) interp)->errorLine;
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_SetErrorLine --
 *
 *      Sets the line number associated with the current error.


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

void
Tcl_SetErrorLine(
    Tcl_Interp *interp,

    }

    if (code == TCL_ERROR) {
	if (iPtr->errorInfo) {
	    Tcl_DecrRefCount(iPtr->errorInfo);
	    iPtr->errorInfo = NULL;
	}
	Tcl_DictObjGet(NULL, iPtr->returnOpts, keys[KEY_ERRORINFO],
                &valuePtr);
	if (valuePtr != NULL) {
	    int infoLen;

	    (void) TclGetStringFromObj(valuePtr, &infoLen);
	    if (infoLen) {
		iPtr->errorInfo = valuePtr;
		Tcl_IncrRefCount(iPtr->errorInfo);
		iPtr->flags |= ERR_ALREADY_LOGGED;
	    }
	}
	Tcl_DictObjGet(NULL, iPtr->returnOpts, keys[KEY_ERRORSTACK],
                &valuePtr);
	if (valuePtr != NULL) {
            int len, valueObjc;
            Tcl_Obj **valueObjv;

            if (Tcl_IsShared(iPtr->errorStack)) {
                Tcl_Obj *newObj;
                
                newObj = Tcl_DuplicateObj(iPtr->errorStack);
                Tcl_DecrRefCount(iPtr->errorStack);
                Tcl_IncrRefCount(newObj);
                iPtr->errorStack = newObj;
            }

            /*
             * List extraction done after duplication to avoid moving the rug
             * if someone does [return -errorstack [info errorstack]]
             */

            if (Tcl_ListObjGetElements(interp, valuePtr, &valueObjc,
                    &valueObjv) == TCL_ERROR) {
                return TCL_ERROR;
            }
            iPtr->resetErrorStack = 0;
            Tcl_ListObjLength(interp, iPtr->errorStack, &len);

            /*
             * Reset while keeping the list intrep as much as possible.
             */

            Tcl_ListObjReplace(interp, iPtr->errorStack, 0, len, valueObjc,
                    valueObjv);
 	}
	Tcl_DictObjGet(NULL, iPtr->returnOpts, keys[KEY_ERRORCODE],
                &valuePtr);
	if (valuePtr != NULL) {
	    Tcl_SetObjErrorCode(interp, valuePtr);
	} else {
	    Tcl_SetErrorCode(interp, "NONE", NULL);
	}

	Tcl_DictObjGet(NULL, iPtr->returnOpts, keys[KEY_ERRORLINE],
                &valuePtr);
	if (valuePtr != NULL) {
	    TclGetIntFromObj(NULL, valuePtr, &iPtr->errorLine);
	}
    }
    if (level != 0) {
	iPtr->returnLevel = level;
	iPtr->returnCode = code;

    /*
     * Check for bogus -code value.
     */

    Tcl_DictObjGet(NULL, returnOpts, keys[KEY_CODE], &valuePtr);
    if (valuePtr != NULL) {
	if (TclGetCompletionCodeFromObj(interp, valuePtr,
                &code) == TCL_ERROR) {
	    goto error;
	}
	Tcl_DictObjRemove(NULL, returnOpts, keys[KEY_CODE]);
    }

    /*
     * Check for bogus -level value.

}

/*
 *-------------------------------------------------------------------------
 *
 * TclNoErrorStack --
 *
 *	Removes the -errorstack entry from an options dict to avoid reference
 *	cycles.
 *
 * Results:
 *	The (unshared) argument options dict, modified in -place.
 *
 *-------------------------------------------------------------------------
 */

Tcl_Obj *
TclNoErrorStack(
    Tcl_Interp *interp,
    Tcl_Obj *options)
{
    Tcl_Obj **keys = GetKeys();
    
    Tcl_DictObjRemove(interp, options, keys[KEY_ERRORSTACK]);

    return options;
}

/*
 *-------------------------------------------------------------------------
 *
 * Tcl_SetReturnOptions --

 */

static ProcessGlobalValue executableName = {
    0, 0, NULL, NULL, NULL, NULL, NULL
};

/*
 * The following values are used in the flags arguments of Tcl*Scan*Element
 * and Tcl*Convert*Element.  The values TCL_DONT_USE_BRACES and
 * TCL_DONT_QUOTE_HASH are defined in tcl.h, like so:
 *
#define TCL_DONT_USE_BRACES     1
#define TCL_DONT_QUOTE_HASH     8
 *
 * Those are public flag bits which callers of the public routines
 * Tcl_Convert*Element() can use to indicate:
 *

 * are for internal use only.  Make sure they do not overlap with the public
 * values above.
 *
 * The Tcl*Scan*Element() routines make a determination which of 4 modes of
 * conversion is most appropriate for Tcl*Convert*Element() to perform, and
 * sets two bits of the flags value to indicate the mode selected.
 *
 * CONVERT_NONE		The element needs no quoting. Its literal string is
 *			suitable as is.
 * CONVERT_BRACE	The conversion should be enclosing the literal string
 *			in braces.
 * CONVERT_ESCAPE	The conversion should be using backslashes to escape
 *			any characters in the string that require it.
 * CONVERT_MASK		A mask value used to extract the conversion mode from
 *			the flags argument.
 *			Also indicates a strange conversion mode where all
 *			special characters are escaped with backslashes
 *			*except for braces*. This is a strange and unnecessary
 *			case, but it's part of the historical way in which
 *			lists have been formatted in Tcl. To experiment with
 *			removing this case, set the value of COMPAT to 0.
 *
 * One last flag value is used only by callers of TclScanElement(). The flag
 * value produced by a call to Tcl*Scan*Element() will never leave this bit
 * set.
 *
 * CONVERT_ANY		The caller of TclScanElement() declares it can make no
 *			promise about what public flags will be passed to the
 *			matching call of TclConvertElement(). As such,
 *			TclScanElement() has to determine the worst case
 *			destination buffer length over all possibilities, and
 *			in other cases this means an overestimate of the
 *			required size.
 *
 * For more details, see the comments on the Tcl*Scan*Element and 
 * Tcl*Convert*Element routines.

    UpdateStringOfEndOffset,		/* updateStringProc */
    SetEndOffsetFromAny
};

/*
 *	*	STRING REPRESENTATION OF LISTS	*	*	*
 *
 * The next several routines implement the conversions of strings to and from
 * Tcl lists. To understand their operation, the rules of parsing and
 * generating the string representation of lists must be known.  Here we
 * describe them in one place.
 *
 * A list is made up of zero or more elements. Any string is a list if it is
 * made up of alternating substrings of element-separating ASCII whitespace
 * and properly formatted elements.
 *
 * The ASCII characters which can make up the whitespace between list elements
 * are:
 *
 *	\u0009	\t	TAB
 *	\u000A	\n	NEWLINE
 *	\u000B	\v	VERTICAL TAB
 *	\u000C	\f	FORM FEED
 * 	\u000D	\r	CARRIAGE RETURN
 *	\u0020		SPACE
 *
 * NOTE: differences between this and other places where Tcl defines a role
 * for "whitespace".
 *
 *	* Unlike command parsing, here NEWLINE is just another whitespace
 *	  character; its role as a command terminator in a script has no
 *	  importance here.
 *
 *	* Unlike command parsing, the BACKSLASH NEWLINE sequence is not
 *	  considered to be a whitespace character.
 *
 *	* Other Unicode whitespace characters (recognized by [string is space]
 *	  or Tcl_UniCharIsSpace()) do not play any role as element separators
 *	  in Tcl lists.
 *
 *	* The NUL byte ought not appear, as it is not in strings properly
 *	  encoded for Tcl, but if it is present, it is not treated as
 *	  separating whitespace, or a string terminator. It is just another
 *	  character in a list element.
 *
 * The interpretaton of a formatted substring as a list element follows rules
 * similar to the parsing of the words of a command in a Tcl script. Backslash
 * substitution plays a key role, and is defined exactly as it is in command
 * parsing. The same routine, TclParseBackslash() is used in both command
 * parsing and list parsing.
 *
 * NOTE: This means that if and when backslash substitution rules ever change
 * for command parsing, the interpretation of strings as lists also changes.

 * 
 * Backslash substitution replaces an "escape sequence" of one or more
 * characters starting with
 *		\u005c	\	BACKSLASH
 * with a single character. The one character escape sequent case happens only
 * when BACKSLASH is the last character in the string. In all other cases, the
 * escape sequence is at least two characters long.
 *
 * The formatted substrings are interpreted as element values according to the
 * following cases:
 *
 * * If the first character of a formatted substring is
 *		\u007b	{	OPEN BRACE
 *   then the end of the substring is the matching 
 *		\u007d	}	CLOSE BRACE
 *   character, where matching is determined by counting nesting levels, and
 *   not including any brace characters that are contained within a backslash
 *   escape sequence in the nesting count. Having found the matching brace,
 *   all characters between the braces are the string value of the element.
 *   If no matching close brace is found before the end of the string, the
 *   string is not a Tcl list. If the character following the close brace is
 *   not an element separating whitespace character, or the end of the string,
 *   then the string is not a Tcl list.
 *
 *   NOTE: this differs from a brace-quoted word in the parsing of a Tcl
 *   command only in its treatment of the backslash-newline sequence. In a
 *   list element, the literal characters in the backslash-newline sequence
 *   become part of the element value. In a script word, conversion to a
 *   single SPACE character is done.
 *
 *   NOTE: Most list element values can be represented by a formatted
 *   substring using brace quoting. The exceptions are any element value that
 *   includes an unbalanced brace not in a backslash escape sequence, and any
 *   value that ends with a backslash not itself in a backslash escape
 *   sequence.
 * 
 * * If the first character of a formatted substring is
 *		\u0022	"	QUOTE
 *   then the end of the substring is the next QUOTE character, not counting
 *   any QUOTE characters that are contained within a backslash escape
 *   sequence. If no next QUOTE is found before the end of the string, the
 *   string is not a Tcl list. If the character following the closing QUOTE is
 *   not an element separating whitespace character, or the end of the string,
 *   then the string is not a Tcl list. Having found the limits of the
 *   substring, the element value is produced by performing backslash
 *   substitution on the character sequence between the open and close QUOTEs.
 *
 *   NOTE: Any element value can be represented by this style of formatting,
 *   given suitable choice of backslash escape sequences.
 *
 * * All other formatted substrings are terminated by the next element
 *   separating whitespace character in the string.  Having found the limits
 *   of the substring, the element value is produced by performing backslash
 *   substitution on it.
 *
 *   NOTE: Any element value can be represented by this style of formatting,
 *   given suitable choice of backslash escape sequences, with one exception.
 *   The empty string cannot be represented as a list element without the use
 *   of either braces or quotes to delimit it.
 *
 * This collection of parsing rules is implemented in the routine
 * TclFindElement().
 *
 * In order to produce lists that can be parsed by these rules, we need the
 * ability to distinguish between characters that are part of a list element
 * value from characters providing syntax that define the structure of the
 * list. This means that our code that generates lists must at a minimum be
 * able to produce escape sequences for the 10 characters identified above
 * that have significance to a list parser.
 *
 *	*	*	CANONICAL LISTS	*	*	*	*	*
 *
 * In addition to the basic rules for parsing strings into Tcl lists, there
 * are additional properties to be met by the set of list values that are
 * generated by Tcl.  Such list values are often said to be in "canonical
 * form":
 *
 * * When any canonical list is evaluated as a Tcl script, it is a script of
 *   either zero commands (an empty list) or exactly one command. The command
 *   word is exactly the first element of the list, and each argument word is
 *   exactly one of the following elements of the list. This means that any
 *   characters that have special meaning during script evaluation need
 *   special treatment when canonical lists are produced:
 *
 *	* Whitespace between elements may not include NEWLINE.
 *	* The command terminating character,
 *		\u003b	;	SEMICOLON
 *	  must be BRACEd, QUOTEd, or escaped so that it does not terminate the
 * 	  command prematurely.
 *	* Any of the characters that begin substitutions in scripts,
 *		\u0024	$	DOLLAR
 *		\u005b	[	OPEN BRACKET
 *		\u005c	\	BACKSLASH
 *	  need to be BRACEd or escaped.
 *	* In any list where the first character of the first element is
 *		\u0023	#	HASH
 *	  that HASH character must be BRACEd, QUOTEd, or escaped so that it
 *	  does not convert the command into a comment.
 *	* Any list element that contains the character sequence BACKSLASH
 *	  NEWLINE cannot be formatted with BRACEs. The BACKSLASH character
 *	  must be represented by an escape sequence, and unless QUOTEs are
 *	  used, the NEWLINE must be as well.

 *
 * * It is also guaranteed that one can use a canonical list as a building
 *   block of a larger script within command substitution, as in this example:
 *	set script "puts \[[list $cmd $arg]]"; eval $script
 *   To support this usage, any appearance of the character
 *		\u005d	]	CLOSE BRACKET
 *   in a list element must be BRACEd, QUOTEd, or escaped.
 *
 * * Finally it is guaranteed that enclosing a canonical list in braces
 *   produces a new value that is also a canonical list.  This new list has
 *   length 1, and its only element is the original canonical list.  This same
 *   guarantee also makes it possible to construct scripts where an argument
 *   word is given a list value by enclosing the canonical form of that list
 *   in braces:
 *	set script "puts {[list $one $two $three]}"; eval $script
 *   This sort of coding was once fairly common, though it's become more
 *   idiomatic to see the following instead:
 *	set script [list puts [list $one $two $three]]; eval $script
 *   In order to support this guarantee, every canonical list must have
 *   balance when counting those braces that are not in escape sequences.
 *
 * Within these constraints, the canonical list generation routines
 * TclScanElement() and TclConvertElement() attempt to generate the string for
 * any list that is easiest to read. When an element value is itself
 * acceptable as the formatted substring, it is usually used (CONVERT_NONE).
 * When some quoting or escaping is required, use of BRACEs (CONVERT_BRACE) is
 * usually preferred over the use of escape sequences (CONVERT_ESCAPE). There
 * are some exceptions to both of these preferences for reasons of code
 * simplicity, efficiency, and continuation of historical habits. Canonical
 * lists never use the QUOTE formatting to delimit their elements because that
 * form of quoting does not nest, which makes construction of nested lists far
 * too much trouble.  Canonical lists always use only a single SPACE character
 * for element-separating whitespace.
 *
 *	*	*	FUTURE CONSIDERATIONS	*	*	*
 *
 * When a list element requires quoting or escaping due to a CLOSE BRACKET
 * character or an internal QUOTE character, a strange formatting mode is
 * recommended. For example, if the value "a{b]c}d" is converted by the usual
 * modes:
 *
 *	CONVERT_BRACE:	a{b]c}d		=> {a{b]c}d}
 *	CONVERT_ESCAPE:	a{b]c}d		=> a\{b\]c\}d
 *
 * we get perfectly usable formatted list elements. However, this is not what
 * Tcl releases have been producing. Instead, we have:
 *
 *	CONVERT_MASK:	a{b]c}d		=> a{b\]c}d
 *
 * where the CLOSE BRACKET is escaped, but the BRACEs are not. The same effect
 * can be seen replacing ] with " in this example. There does not appear to be
 * any functional or aesthetic purpose for this strange additional mode. The
 * sole purpose I can see for preserving it is to keep generating the same
 * formatted lists programmers have become accustomed to, and perhaps written
 * tests to expect. That is, compatibility only. The additional code
 * complexity required to support this mode is significant. The lines of code
 * supporting it are delimited in the routines below with #if COMPAT
 * directives. This makes it easy to experiment with eliminating this
 * formatting mode simply with "#define COMPAT 0" above. I believe this is
 * worth considering.
 * 
 * Another consideration is the treatment of QUOTE characters in list
 * elements. TclConvertElement() must have the ability to produce the escape
 * sequence \" so that when a list element begins with a QUOTE we do not
 * confuse that first character with a QUOTE used as list syntax to define
 * list structure. However, that is the only place where QUOTE characters need
 * quoting. In this way, handling QUOTE could really be much more like the way
 * we handle HASH which also needs quoting and escaping only in particular
 * situations. Following up this could increase the set of list elements that
 * can use the CONVERT_NONE formatting mode.
 *
 * More speculative is that the demands of canonical list form require brace
 * balance for the list as a whole, while the current implementation achieves
 * this by establishing brace balance for every element.
 *
 * Finally, a reminder that the rules for parsing and formatting lists are
 * closely tied together with the rules for parsing and evaluating scripts,
 * and will need to evolve in sync.
 */

/*
 *----------------------------------------------------------------------
 *
 * TclMaxListLength --
 *
 *	Given 'bytes' pointing to 'numBytes' bytes, scan through them and
 *	count the number of whitespace runs that could be list element
 *	separators. If 'numBytes' is -1, scan to the terminating '\0'. Not a
 *	full list parser. Typically used to get a quick and dirty overestimate
 *	of length size in order to allocate space for an actual list parser to
 *	operate with.
 *
 * Results:
 *	Returns the largest number of list elements that could possibly be in
 *	this string, interpreted as a Tcl list. If 'endPtr' is not NULL,
 *	writes a pointer to the end of the string scanned there.
 *
 * Side effects:
 *	None.
 *
 *----------------------------------------------------------------------
 */

int
TclMaxListLength(
    const char *bytes,
    int numBytes,
    const char **endPtr)
{
    int count = 0;

    if ((numBytes == 0) || ((numBytes == -1) && (*bytes == '\0'))) {
	/* Empty string case - quick exit */
	goto done;
    }

    /*
     * No list element before leading white space.
     */

    count += 1 - TclIsSpaceProc(*bytes); 

    /*
     * Count white space runs as potential element separators.
     */

    while (numBytes) {
	if ((numBytes == -1) && (*bytes == '\0')) {
	    break;
	}
	if (TclIsSpaceProc(*bytes)) {
	    /*
	     * Space run started; bump count.
	     */

	    count++;
	    do {
		bytes++;
		numBytes -= (numBytes != -1);
	    } while (numBytes && TclIsSpaceProc(*bytes));
	    if ((numBytes == 0) || ((numBytes == -1) && (*bytes == '\0'))) {
		break;
	    }

	    /*
	     * (*bytes) is non-space; return to counting state.
	     */
	}
	bytes++;
	numBytes -= (numBytes != -1);
    }

    /*
     * No list element following trailing white space.
     */

    count -= TclIsSpaceProc(bytes[-1]); 

  done:
    if (endPtr) {
	*endPtr = bytes;
    }
    return count;
}

/*

 *
 *	If TCL_OK is returned, then *elementPtr will be set to point to the
 *	first element of list, and *nextPtr will be set to point to the
 *	character just after any white space following the last character
 *	that's part of the element. If this is the last argument in the list,
 *	then *nextPtr will point just after the last character in the list
 *	(i.e., at the character at list+listLength). If sizePtr is non-NULL,
 *	*sizePtr is filled in with the number of bytes in the element. If the
 *	element is in braces, then *elementPtr will point to the character
 *	after the opening brace and *sizePtr will not include either of the
 *	braces. If there isn't an element in the list, *sizePtr will be zero,
 *	and both *elementPtr and *nextPtr will point just after the last
 *	character in the list. If literalPtr is non-NULL, *literalPtr is set
 *	to a boolean value indicating whether the substring returned as the
 *	values of **elementPtr and *sizePtr is the literal value of a list
 *	element. If not, a call to TclCopyAndCollapse() is needed to produce
 *	the actual value of the list element. Note: this function does NOT
 *	collapse backslash sequences, but uses *literalPtr to tell callers
 *	when it is required for them to do so.
 *
 * Side effects:
 *	None.
 *
 *----------------------------------------------------------------------
 */

	     */

	case '\\':
	    if (openBraces == 0) {
		/*
		 * A backslash sequence not within a brace quoted element
		 * means the value of the element is different from the
		 * substring we are parsing. A call to TclCopyAndCollapse() is
		 * needed to produce the element value. Inform the caller.
		 */

		literal = 0;
	    }
	    TclParseBackslash(p, limit - p, &numChars, NULL);
	    p += (numChars - 1);
	    break;

	    /*

 *
 * TclCopyAndCollapse --
 *
 *	Copy a string and substitute all backslash escape sequences
 *
 * Results:
 *	Count bytes get copied from src to dst. Along the way, backslash
 *	sequences are substituted in the copy. After scanning count bytes from
 *	src, a null character is placed at the end of dst. Returns the number
 *	of bytes that got written to dst.
 *
 * Side effects:
 *	None.
 *
 *----------------------------------------------------------------------
 */

int
TclCopyAndCollapse(
    int count,			/* Number of byte to copy from src. */
    const char *src,		/* Copy from here... */
    char *dst)			/* ... to here. */
{
    int newCount = 0;

    while (count > 0) {
	char c = *src;

	if (c == '\\') {
	    int numRead;
	    int backslashCount = TclParseBackslash(src, count, &numRead, dst);

	    dst += backslashCount;
	    newCount += backslashCount;
	    src += numRead;

				 * of pointers to list elements. */
{
    const char **argv, *end, *element;
    char *p;
    int length, size, i, result, elSize;

    /*
     * Allocate enough space to work in. A (const char *) for each (possible)
     * list element plus one more for terminating NULL, plus as many bytes as
     * in the original string value, plus one more for a terminating '\0'.
     * Space used to hold element separating white space in the original

     * string gets re-purposed to hold '\0' characters in the argv array.
     */

    size = TclMaxListLength(list, -1, &end) + 1;
    length = end - list;
    argv = ckalloc((size * sizeof(char *)) + length + 1);

    for (i = 0, p = ((char *) argv) + size*sizeof(char *);

 * Tcl_ScanElement --
 *
 *	This function is a companion function to Tcl_ConvertElement. It scans
 *	a string to see what needs to be done to it (e.g. add backslashes or
 *	enclosing braces) to make the string into a valid Tcl list element.
 *
 * Results:
 *	The return value is an overestimate of the number of bytes that will
 *	be needed by Tcl_ConvertElement to produce a valid list element from
 *	src. The word at *flagPtr is filled in with a value needed by
 *	Tcl_ConvertElement when doing the actual conversion.
 *
 * Side effects:
 *	None.
 *
 *----------------------------------------------------------------------
 */

 *	This function is a companion function to Tcl_ConvertCountedElement. It
 *	scans a string to see what needs to be done to it (e.g. add
 *	backslashes or enclosing braces) to make the string into a valid Tcl
 *	list element. If length is -1, then the string is scanned from src up
 *	to the first null byte.
 *
 * Results:
 *	The return value is an overestimate of the number of bytes that will
 *	be needed by Tcl_ConvertCountedElement to produce a valid list element
 *	from src. The word at *flagPtr is filled in with a value needed by
 *	Tcl_ConvertCountedElement when doing the actual conversion.
 *
 * Side effects:
 *	None.
 *
 *----------------------------------------------------------------------
 */

}

/*
 *----------------------------------------------------------------------
 *
 * TclScanElement --
 *
 *	This function is a companion function to TclConvertElement. It scans a
 *	string to see what needs to be done to it (e.g. add backslashes or
 *	enclosing braces) to make the string into a valid Tcl list element. If
 *	length is -1, then the string is scanned from src up to the first null
 *	byte. A NULL value for src is treated as an empty string. The incoming
 *	value of *flagPtr is a report from the caller what additional flags it
 *	will pass to TclConvertElement().
 *
 * Results:
 *	The recommended formatting mode for the element is determined and a
 *	value is written to *flagPtr indicating that recommendation. This
 *	recommendation is combined with the incoming flag values in *flagPtr
 *	set by the caller to determine how many bytes will be needed by
 *	TclConvertElement() in which to write the formatted element following
 *	the recommendation modified by the flag values. This number of bytes
 *	is the return value of the routine.  In some situations it may be an
 *	overestimate, but so long as the caller passes the same flags to
 *	TclConvertElement(), it will be large enough.
 *
 * Side effects:
 *	None.
 *
 *----------------------------------------------------------------------
 */

int
TclScanElement(
    const char *src,		/* String to convert to Tcl list element. */
    int length,			/* Number of bytes in src, or -1. */
    int *flagPtr)		/* Where to store information to guide
				 * Tcl_ConvertElement. */
{
    const char *p = src;
    int nestingLevel = 0;	/* Brace nesting count */
    int forbidNone = 0;		/* Do not permit CONVERT_NONE mode. Something
				 * needs protection or escape. */
    int requireEscape = 0;	/* Force use of CONVERT_ESCAPE mode.  For some
				 * reason bare or brace-quoted form fails. */
    int extra = 0;		/* Count of number of extra bytes needed for
				 * formatted element, assuming we use escape
				 * sequences in formatting. */
    int bytesNeeded;		/* Buffer length computed to complete the
				 * element formatting in the selected mode. */
#if COMPAT
    int preferEscape = 0;	/* Use preferences to track whether to use */
    int preferBrace = 0;	/* CONVERT_MASK mode. */
    int braceCount = 0;		/* Count of all braces '{' '}' seen. */
#endif /* COMPAT */
    
    if ((p == NULL) || (length == 0) || ((*p == '\0') && (length == -1))) {
	/*
	 * Empty string element must be brace quoted.
	 */

	*flagPtr = CONVERT_BRACE;
	return 2;
    }

    if ((*p == '{') || (*p == '"')) {
	/*
	 * Must escape or protect so leading character of value is not
	 * misinterpreted as list element delimiting syntax.
	 */

	forbidNone = 1;
#if COMPAT
	preferBrace = 1;
#endif /* COMPAT */
    }

    while (length) {
      if (CHAR_TYPE(*p) != TYPE_NORMAL) {
	switch (*p) {
	case '{':	/* TYPE_BRACE */
#if COMPAT
	    braceCount++;
#endif /* COMPAT */
	    extra++;				/* Escape '{' => '\{' */
	    nestingLevel++;
	    break;
	case '}':	/* TYPE_BRACE */
#if COMPAT
	    braceCount++;
#endif /* COMPAT */
	    extra++;				/* Escape '}' => '\}' */
	    nestingLevel--;
	    if (nestingLevel < 0) {
		/*
		 * Unbalanced braces!  Cannot format with brace quoting.
		 */

		requireEscape = 1;
	    }
	    break;
	case ']':	/* TYPE_CLOSE_BRACK */
	case '"':	/* TYPE_SPACE */
#if COMPAT
	    forbidNone = 1;
	    extra++;		/* Escapes all just prepend a backslash */
	    preferEscape = 1;
	    break;
#else
	    /* FLOW THROUGH */
#endif /* COMPAT */
	case '[':	/* TYPE_SUBS */
	case '$':	/* TYPE_SUBS */
	case ';':	/* TYPE_COMMAND_END */
	case ' ':	/* TYPE_SPACE */
	case '\f':	/* TYPE_SPACE */
	case '\n':	/* TYPE_COMMAND_END */
	case '\r':	/* TYPE_SPACE */
	case '\t':	/* TYPE_SPACE */
	case '\v':	/* TYPE_SPACE */
	    forbidNone = 1;
	    extra++;		/* Escape sequences all one byte longer. */
#if COMPAT
	    preferBrace = 1;
#endif /* COMPAT */
	    break;
	case '\\':	/* TYPE_SUBS */
	    extra++;				/* Escape '\' => '\\' */
	    if ((length == 1) || ((length == -1) && (p[1] == '\0'))) {
		/*
		 * Final backslash. Cannot format with brace quoting.
		 */

		requireEscape = 1;		
		break;
	    }
	    if (p[1] == '\n') {
		extra++;	/* Escape newline => '\n', one byte longer */

		/*
		 * Backslash newline sequence.  Brace quoting not permitted.
		 */

		requireEscape = 1;
		length -= (length > 0);
		p++;
		break;
	    }
	    if ((p[1] == '{') || (p[1] == '}') || (p[1] == '\\')) {
		extra++;	/* Escape sequences all one byte longer. */
		length -= (length > 0);
		p++;
	    }
	    forbidNone = 1;
#if COMPAT
	    preferBrace = 1;
#endif /* COMPAT */
	    break;
	case '\0':	/* TYPE_SUBS */
	    if (length == -1) {
		goto endOfString;
	    }
	    /* TODO: Panic on improper encoding? */
	    break;
	}
      }
	length -= (length > 0);
	p++;
    }

  endOfString:
    if (nestingLevel != 0) {
	/*
	 * Unbalanced braces!  Cannot format with brace quoting.
	 */

	requireEscape = 1;
    }

    /*
     * We need at least as many bytes as are in the element value...
     */

    bytesNeeded = p - src;

    if (requireEscape) {
	/*
	 * We must use escape sequences.  Add all the extra bytes needed to
	 * have room to create them.
	 */

	bytesNeeded += extra;

	/*
	 * Make room to escape leading #, if needed.
	 */

	if ((*src == '#') && !(*flagPtr & TCL_DONT_QUOTE_HASH)) {
	    bytesNeeded++;
	}
	*flagPtr = CONVERT_ESCAPE;
	goto overflowCheck;
    }
    if (*flagPtr & CONVERT_ANY) {
	/*
	 * The caller has not let us know what flags it will pass to
	 * TclConvertElement() so compute the max size we might need for any
	 * possible choice.  Normally the formatting using escape sequences is
	 * the longer one, and a minimum "extra" value of 2 makes sure we
	 * don't request too small a buffer in those edge cases where that's
	 * not true.
	 */

	if (extra < 2) {
	    extra = 2;
	}
	*flagPtr &= ~CONVERT_ANY;
	*flagPtr |= TCL_DONT_USE_BRACES;
    }
    if (forbidNone) {
	/*
	 * We must request some form of quoting of escaping...
	 */

#if COMPAT
	if (preferEscape && !preferBrace) {
	    /*
	     * If we are quoting solely due to ] or internal " characters use
	     * the CONVERT_MASK mode where we escape all special characters
	     * except for braces. "extra" counted space needed to escape
	     * braces too, so substract "braceCount" to get our actual needs.

	     */

	    bytesNeeded += (extra - braceCount);
	    /* Make room to escape leading #, if needed. */
	    if ((*src == '#') && !(*flagPtr & TCL_DONT_QUOTE_HASH)) {
		bytesNeeded++;
	    }

	    /*
	     * If the caller reports it will direct TclConvertElement() to
	     * use full escapes on the element, add back the bytes needed to
	     * escape the braces.
	     */

	    if (*flagPtr & TCL_DONT_USE_BRACES) {
		bytesNeeded += braceCount;
	    }
	    *flagPtr = CONVERT_MASK;
	    goto overflowCheck;
	}
#endif /* COMPAT */
	if (*flagPtr & TCL_DONT_USE_BRACES) {
	    /*
	     * If the caller reports it will direct TclConvertElement() to
	     * use escapes, add the extra bytes needed to have room for them.
	     */

	    bytesNeeded += extra;

	    /*
	     * Make room to escape leading #, if needed.
	     */

	    if ((*src == '#') && !(*flagPtr & TCL_DONT_QUOTE_HASH)) {
		bytesNeeded++;
	    }
	} else {
	    /*
	     * Add 2 bytes for room for the enclosing braces.
	     */

	    bytesNeeded += 2;
	}
	*flagPtr = CONVERT_BRACE;
	goto overflowCheck;
    }

    /*
     * So far, no need to quote or escape anything.
     */

    if ((*src == '#') && !(*flagPtr & TCL_DONT_QUOTE_HASH)) {
	/*
	 * If we need to quote a leading #, make room to enclose in braces.
	 */

	bytesNeeded += 2;
    }
    *flagPtr = CONVERT_NONE;

  overflowCheck:
    if (bytesNeeded < 0) {
	Tcl_Panic("TclScanElement: string length overflow");
    }
    return bytesNeeded;
}

/*

}

/*
 *----------------------------------------------------------------------
 *
 * TclConvertElement --
 *
 *	This is a companion function to TclScanElement. Given the information
 *	produced by TclScanElement, this function converts a string to a list
 *	element equal to that string.
 *
 * Results:
 *	Information is copied to *dst in the form of a list element identical
 *	to src (i.e. if Tcl_SplitList is applied to dst it will produce a
 *	string identical to src). The return value is a count of the number of
 *	characters copied (not including the terminating NULL character).
 *
 * Side effects:
 *	None.
 *
 *----------------------------------------------------------------------
 */

int
TclConvertElement(
    register const char *src,	/* Source information for list element. */
    int length,			/* Number of bytes in src, or -1. */
    char *dst,			/* Place to put list-ified element. */
    int flags)			/* Flags produced by Tcl_ScanElement. */
{
    int conversion = flags & CONVERT_MASK;
    char *p = dst;

    /*
     * Let the caller demand we use escape sequences rather than braces.
     */

    if ((flags & TCL_DONT_USE_BRACES) && (conversion & CONVERT_BRACE)) {
	conversion = CONVERT_ESCAPE;
    }

    /*
     * No matter what the caller demands, empty string must be braced!
     */

    if ((src == NULL) || (length == 0) || (*src == '\0' && length == -1)) {
	src = tclEmptyStringRep;
	length = 0;
	conversion = CONVERT_BRACE;
    }

    /*
     * Escape leading hash as needed and requested.
     */

    if ((*src == '#') && !(flags & TCL_DONT_QUOTE_HASH)) {
	if (conversion == CONVERT_ESCAPE) {
	    p[0] = '\\';
	    p[1] = '#';
	    p += 2;
	    src++;
	    length -= (length > 0);
	} else {
	    conversion = CONVERT_BRACE;
	}
    }

    /*
     * No escape or quoting needed.  Copy the literal string value.
     */

    if (conversion == CONVERT_NONE) {
	if (length == -1) {
	    /* TODO: INT_MAX overflow? */
	    while (*src) {
		*p++ = *src++;
	    }
	    return p - dst;
	} else {
	    memcpy(dst, src, length);
	    return length;
	}
    }

    /*
     * Formatted string is original string enclosed in braces.
     */

    if (conversion == CONVERT_BRACE) {
	*p = '{';
	p++;
	if (length == -1) {
	    /* TODO: INT_MAX overflow? */
	    while (*src) {
		*p++ = *src++;
	    }
	} else {
	    memcpy(p, src, length);
	    p += length;
	}
	*p = '}';
	p++;
	return p - dst;
    }

    /* conversion == CONVERT_ESCAPE or CONVERT_MASK */

    /*
     * Formatted string is original string converted to escape sequences.
     */

    for ( ; length; src++, length -= (length > 0)) {
	switch (*src) {
	case ']':
	case '[':
	case '$':
	case ';':
	case ' ':
	case '\\':
	case '"':
	    *p = '\\';
	    p++;
	    break;
	case '{':
	case '}':
#if COMPAT
	    if (conversion == CONVERT_ESCAPE)
#endif /* COMPAT */
	    {
		*p = '\\';
		p++;

	    }

	    break;
	case '\f':
	    *p = '\\';
	    p++;
	    *p = 'f';
	    p++;
	    continue;

	    *p = 'v';
	    p++;
	    continue;
	case '\0':
	    if (length == -1) {
		return p - dst;
	    }

	    /* 
	     * If we reach this point, there's an embedded NULL in the string
	     * range being processed, which should not happen when the
	     * encoding rules for Tcl strings are properly followed.  If the
	     * day ever comes when we stop tolerating such things, this is
	     * where to put the Tcl_Panic().
	     */

	    break;
	}
	*p = *src;
	p++;
    }
    return p - dst;
}

 */

char *
Tcl_Merge(
    int argc,			/* How many strings to merge. */
    const char *const *argv)	/* Array of string values. */
{
#define LOCAL_SIZE 20
    int localFlags[LOCAL_SIZE], *flagPtr = NULL;
    int i, bytesNeeded = 0;
    char *result, *dst;
    const int maxFlags = UINT_MAX / sizeof(int);


    /*
     * Handle empty list case first, so logic of the general case can be
     * simpler.
     */

    if (argc == 0) {
	result = ckalloc(1);
	result[0] = '\0';
	return result;
    }

    /*
     * Pass 1: estimate space, gather flags.
     */

    if (argc <= LOCAL_SIZE) {
	flagPtr = localFlags;
    } else if (argc > maxFlags) {
	/*
	 * We cannot allocate a large enough flag array to format this list in
	 * one pass.  We could imagine converting this routine to a multi-pass
	 * implementation, but for sizeof(int) == 4, the limit is a max of
	 * 2^30 list elements and since each element is at least one byte
	 * formatted, and requires one byte space between it and the next one,
	 * that a minimum space requirement of 2^31 bytes, which is already

	 * INT_MAX. If we tried to format a list of > maxFlags elements, we're
	 * just going to overflow the size limits on the formatted string
	 * anyway, so just issue that same panic early.
	 */

	Tcl_Panic("max size for a Tcl value (%d bytes) exceeded", INT_MAX);
    } else {
	flagPtr = ckalloc(argc * sizeof(int));
    }
    for (i = 0; i < argc; i++) {
	flagPtr[i] = ( i ? TCL_DONT_QUOTE_HASH : 0 );
	bytesNeeded += TclScanElement(argv[i], -1, &flagPtr[i]);

    return (char) ch;
}

/*
 *----------------------------------------------------------------------
 *
 * TclTrimRight --
 *
 *	Takes two counted strings in the Tcl encoding which must both be null
 *	terminated. Conceptually trims from the right side of the first string
 *	all characters found in the second string.
 *
 * Results:
 *	The number of bytes to be removed from the end of the string.
 *
 * Side effects:
 *	None.
 *
 *----------------------------------------------------------------------
 */

int
TclTrimRight(
    const char *bytes,		/* String to be trimmed... */
    int numBytes,		/* ...and its length in bytes */
    const char *trim,		/* String of trim characters... */
    int numTrim)		/* ...and its length in bytes */
{
    const char *p = bytes + numBytes;
    int pInc;

    if ((bytes[numBytes] != '\0') || (trim[numTrim] != '\0')) {
	Tcl_Panic("TclTrimRight works only on null-terminated strings");
    }

    /*
     * Empty strings -> nothing to do.
     */

    if ((numBytes == 0) || (numTrim == 0)) {
	return 0;
    }

    /*
     * Outer loop: iterate over string to be trimmed.
     */

    do {
	Tcl_UniChar ch1;
	const char *q = trim;
	int bytesLeft = numTrim;

	p = Tcl_UtfPrev(p, bytes);
 	pInc = TclUtfToUniChar(p, &ch1);

	/*
	 * Inner loop: scan trim string for match to current character.
	 */

	do {
	    Tcl_UniChar ch2;
	    int qInc = TclUtfToUniChar(q, &ch2);

	    if (ch1 == ch2) {
		break;
	    }

	    q += qInc;
	    bytesLeft -= qInc;
	} while (bytesLeft);

	if (bytesLeft == 0) {
	    /*
	     * No match; trim task done; *p is last non-trimmed char.
	     */

	    p += pInc;
	    break;
	}
    } while (p > bytes);

    return numBytes - (p - bytes);
}

/*
 *----------------------------------------------------------------------
 *
 * TclTrimLeft --
 *
 *	Takes two counted strings in the Tcl encoding which must both be null
 *	terminated. Conceptually trims from the left side of the first string
 *	all characters found in the second string.
 *
 * Results:
 *	The number of bytes to be removed from the start of the string.
 *
 * Side effects:
 *	None.
 *
 *----------------------------------------------------------------------
 */

int
TclTrimLeft(
    const char *bytes,		/* String to be trimmed... */
    int numBytes,		/* ...and its length in bytes */
    const char *trim,		/* String of trim characters... */
    int numTrim)		/* ...and its length in bytes */
{
    const char *p = bytes;

    if ((bytes[numBytes] != '\0') || (trim[numTrim] != '\0')) {
	Tcl_Panic("TclTrimLeft works only on null-terminated strings");
    }

    /*
     * Empty strings -> nothing to do.
     */

    if ((numBytes == 0) || (numTrim == 0)) {
	return 0;
    }

    /*
     * Outer loop: iterate over string to be trimmed.
     */

    do {
	Tcl_UniChar ch1;
	int pInc = TclUtfToUniChar(p, &ch1);
	const char *q = trim;
	int bytesLeft = numTrim;

	/*
	 * Inner loop: scan trim string for match to current character.
	 */

	do {
	    Tcl_UniChar ch2;
	    int qInc = TclUtfToUniChar(q, &ch2);

	    if (ch1 == ch2) {
		break;
	    }

	    q += qInc;
	    bytesLeft -= qInc;
	} while (bytesLeft);

	if (bytesLeft == 0) {
	    /*
	     * No match; trim task done; *p is first non-trimmed char.
	     */

	    break;
	}

	p += pInc;
	numBytes -= pInc;
    } while (numBytes);

Tcl_Concat(
    int argc,			/* Number of strings to concatenate. */
    const char *const *argv)	/* Array of strings to concatenate. */
{
    int i, needSpace = 0, bytesNeeded = 0;
    char *result, *p;

    /*
     * Dispose of the empty result corner case first to simplify later code.
     */

    if (argc == 0) {
	result = (char *) ckalloc(1);
	result[0] = '\0';
	return result;
    }

    /*
     * First allocate the result buffer at the size required.
     */

    for (i = 0;  i < argc;  i++) {
	bytesNeeded += strlen(argv[i]);
	if (bytesNeeded < 0) {
	    Tcl_Panic("Tcl_Concat: max size of Tcl value exceeded");
	}
    }
    if (bytesNeeded + argc - 1 < 0) {
	/*
	 * Panic test could be tighter, but not going to bother for this
	 * legacy routine.
	 */

	Tcl_Panic("Tcl_Concat: max size of Tcl value exceeded");
    }

    /*
     * All element bytes + (argc - 1) spaces + 1 terminating NULL.
     */

    result = ckalloc((unsigned) (bytesNeeded + argc));

    for (p = result, i = 0;  i < argc;  i++) {
	int trim, elemLength;
	const char *element;
	
	element = argv[i];
	elemLength = strlen(argv[i]);

	/*
	 * Trim away the leading whitespace.
	 */

	trim = TclTrimLeft(element, elemLength, CONCAT_WS, CONCAT_WS_SIZE);
	element += trim;
	elemLength -= trim;

	/*
	 * Trim away the trailing whitespace. Do not permit trimming to expose
	 * a final backslash character.
	 */

	trim = TclTrimRight(element, elemLength, CONCAT_WS, CONCAT_WS_SIZE);
	trim -= trim && (element[elemLength - trim - 1] == '\\');
	elemLength -= trim;

	/*
	 * If we're left with empty element after trimming, do nothing.
	 */

	if (elemLength == 0) {
	    continue;
	}

	/*
	 * Append to the result with space if needed.
	 */

	if (needSpace) {
	    *p++ = ' ';
	}
	memcpy(p, element, (size_t) elemLength);
	p += elemLength;
	needSpace = 1;
    }

	}
	return resPtr;
    }

    /*
     * Something cannot be determined to be safe, so build the concatenation
     * the slow way, using the string representations.
     *
     * First try to pre-allocate the size required.
     */


    for (i = 0;  i < objc;  i++) {
	element = TclGetStringFromObj(objv[i], &elemLength);
	bytesNeeded += elemLength;
	if (bytesNeeded < 0) {
	    break;
	}
    }

    /*
     * Does not matter if this fails, will simply try later to build up the
     * string with each Append reallocating as needed with the usual string
     * append algorithm.  When that fails it will report the error.
     */

    TclNewObj(resPtr);
    Tcl_AttemptSetObjLength(resPtr, bytesNeeded + objc - 1);
    Tcl_SetObjLength(resPtr, 0);

    for (i = 0;  i < objc;  i++) {
	int trim;
	
	element = TclGetStringFromObj(objv[i], &elemLength);

	/*
	 * Trim away the leading whitespace.
	 */

	trim = TclTrimLeft(element, elemLength, CONCAT_WS, CONCAT_WS_SIZE);
	element += trim;
	elemLength -= trim;

	/*
	 * Trim away the trailing whitespace. Do not permit trimming to expose
	 * a final backslash character.
	 */

	trim = TclTrimRight(element, elemLength, CONCAT_WS, CONCAT_WS_SIZE);
	trim -= trim && (element[elemLength - trim - 1] == '\\');
	elemLength -= trim;

	/*
	 * If we're left with empty element after trimming, do nothing.
	 */

	if (elemLength == 0) {
	    continue;
	}

	/*
	 * Append to the result with space if needed.
	 */

	if (needSpace) {
	    Tcl_AppendToObj(resPtr, " ", 1);
	}
	Tcl_AppendToObj(resPtr, element, elemLength);
	needSpace = 1;
    }
    return resPtr;

		    endChar = *pattern;
		    pattern++;
		    if (((startChar <= ch1) && (ch1 <= endChar))
			    || ((endChar <= ch1) && (ch1 <= startChar))) {
			/*
			 * Matches ranges of form [a-z] or [z-a].
			 */

			break;
		    }
		} else if (startChar == ch1) {
		    break;
		}
	    }
	    while (*pattern != ']') {

}

/*
 *----------------------------------------------------------------------
 *
 * TclStringMatchObj --
 *
 *	See if a particular string matches a particular pattern. Allows case
 *	insensitivity. This is the generic multi-type handler for the various
 *	matching algorithms.
 *
 * Results:
 *	The return value is 1 if string matches pattern, and 0 otherwise. The
 *	matching operation permits the following special characters in the
 *	pattern: *?\[] (see the manual entry for details on what these mean).
 *
 * Side effects:

void
Tcl_DStringResult(
    Tcl_Interp *interp,		/* Interpreter whose result is to be reset. */
    Tcl_DString *dsPtr)		/* Dynamic string that is to become the
				 * result of interp. */
{


    Tcl_ResetResult(interp);
    Tcl_SetObjResult(interp, TclDStringToObj(dsPtr));














}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_DStringGetResult --
 *

				 * of interp. */
{
    Interp *iPtr = (Interp *) interp;

    if (dsPtr->string != dsPtr->staticSpace) {
	ckfree(dsPtr->string);
    }

    /*
     * Do more efficient transfer when we know the result is a Tcl_Obj. When
     * there's no st`ring result, we only have to deal with two cases:
     *
     *  1. When the string rep is the empty string, when we don't copy but
     *     instead use the staticSpace in the DString to hold an empty string.

     *  2. When the string rep is not there or there's a real string rep, when
     *     we use Tcl_GetString to fetch (or generate) the string rep - which
     *     we know to have been allocated with ckalloc() - and use it to
     *     populate the DString space. Then, we free the internal rep. and set
     *     the object's string representation back to the canonical empty
     *     string.
     */

    if (!iPtr->result[0] && iPtr->objResultPtr
	    && !Tcl_IsShared(iPtr->objResultPtr)) {
	if (iPtr->objResultPtr->bytes == tclEmptyStringRep) {
	    dsPtr->string = dsPtr->staticSpace;
	    dsPtr->string[0] = 0;
	    dsPtr->length = 0;
	    dsPtr->spaceAvl = TCL_DSTRING_STATIC_SIZE;
	} else {
	    dsPtr->string = Tcl_GetString(iPtr->objResultPtr);
	    dsPtr->length = iPtr->objResultPtr->length;
	    dsPtr->spaceAvl = dsPtr->length + 1;
	    TclFreeIntRep(iPtr->objResultPtr);
	    iPtr->objResultPtr->bytes = tclEmptyStringRep;
	    iPtr->objResultPtr->length = 0;
	}
	return;
    }

    /*
     * If the string result is empty, move the object result to the string
     * result, then reset the object result.
     */

    (void) Tcl_GetStringResult(interp);

	 * the given number, choose the shortest, breaking ties in favour of
	 * the nearest, breaking remaining ties in favour of the one ending in
	 * an even digit."
	 *
	 * Tcl 8.4 implements the first of these, which gives rise to
	 * anomalies in formatting:
	 *
	 *	% expr 0.1
	 *	0.10000000000000001
	 *	% expr 0.01
	 *	0.01
	 *	% expr 1e-7
	 *	9.9999999999999995e-08
	 *
	 * For human readability, it appears better to choose the second rule,
	 * and let [expr 0.1] return 0.1. But for 8.4 compatibility, we prefer
	 * the first (the recommended zero value for tcl_precision avoids the
	 * problem entirely).
	 *
	 * Uncomment TCL_DD_SHORTEN_FLAG in the next call to prefer the method
	 * that allows floating point values to be shortened if it can be done
	 * without loss of precision.
	 */

	digits = TclDoubleDigits(value, *precisionPtr,
		TCL_DD_E_FORMAT /* | TCL_DD_SHORTEN_FLAG */, 
		&exponent, &signum, &end);
    }
    if (signum) {
	*dst++ = '-';
    }
    p = digits;
    if (exponent < -4 || exponent > 16) {
	/*

 *	The formatted characters are written into the storage pointer to by
 *	the "buffer" argument.
 *
 *----------------------------------------------------------------------
 */

int
TclFormatInt(
    char *buffer,		/* Points to the storage into which the
				 * formatted characters are written. */
    long n)			/* The integer to format. */
{
    long intVal;
    int i;
    int numFormatted, j;
    const char *digits = "0123456789";

    /*
     * Check first whether "n" is zero.
     */

    if (n == 0) {
	buffer[0] = '0';
	buffer[1] = 0;
	return 1;
    }

    /*
     * Check whether "n" is the maximum negative value. This is -2^(m-1) for
     * an m-bit word, and has no positive equivalent; negating it produces the
     * same value.
     */

    intVal = -n;			/* [Bug 3390638] Workaround for*/
    if (n == -n || intVal == n) {	/* broken compiler optimizers. */
	return sprintf(buffer, "%ld", n);
    }

    /*
     * Now reverse the characters.
     */

    for (j = 0;  j < i;  j++, i--) {
	char tmp = buffer[i];

	buffer[i] = buffer[j];
	buffer[j] = tmp;
    }
    return numFormatted;
}

/*

     * Fill the global string value.
     */

    pgvPtr->epoch++;
    if (NULL != pgvPtr->value) {
	ckfree(pgvPtr->value);
    } else {
	Tcl_CreateExitHandler(FreeProcessGlobalValue, pgvPtr);
    }
    bytes = Tcl_GetStringFromObj(newValue, &pgvPtr->numBytes);
    pgvPtr->value = ckalloc(pgvPtr->numBytes + 1);
    memcpy(pgvPtr->value, bytes, (unsigned) pgvPtr->numBytes + 1);
    if (pgvPtr->encoding) {
	Tcl_FreeEncoding(pgvPtr->encoding);
    }

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

#include "tclInt.h"
#include <sys/types.h>
#include <loader.h>

/*
 * Static functions defined within this file.
 */

static void *		FindSymbol(Tcl_Interp *interp,
			    Tcl_LoadHandle loadHandle, const char* symbol);
static void		UnloadFile(Tcl_LoadHandle handle);

/*
 *----------------------------------------------------------------------
 *
 * TclpDlopen --
 *
 *	Dynamically loads a binary code file into memory and returns a handle

	lm = (Tcl_PackageInitProc *) load(native, LDR_NOFLAGS);
	Tcl_DStringFree(&ds);
    }

    if (lm == LDR_NULL_MODULE) {
	Tcl_SetObjResult(interp, Tcl_ObjPrintf(
		"couldn't load file \"%s\": %s",
		fileName, Tcl_PosixError(interp)));
	return TCL_ERROR;
    }

    *clientDataPtr = NULL;

    /*
     * My convention is to use a [OSF loader] package name the same as shlib,

 */

#ifdef EXTERN
#   undef EXTERN
#endif

#include "tclInt.h"

/*
 * Static functions defined within this file.
 */

static void *		FindSymbol(Tcl_Interp *interp,
			    Tcl_LoadHandle loadHandle, const char *symbol);

static void		UnloadFile(Tcl_LoadHandle handle);


/*
 *----------------------------------------------------------------------
 *
 * TclpDlopen --
 *
 *	Dynamically loads a binary code file into memory and returns a handle

FindSymbol(
    Tcl_Interp *interp,
    Tcl_LoadHandle loadHandle,
    const char *symbol)
{
    Tcl_DString newName;
    Tcl_PackageInitProc *proc = NULL;
    shl_t handle = (shl_t) loadHandle->clientData;

    /*
     * Some versions of the HP system software still use "_" at the beginning
     * of exported symbols while others don't; try both forms of each name.
     */

    if (shl_findsym(&handle, symbol, (short) TYPE_PROCEDURE,

static void
UnloadFile(
    Tcl_LoadHandle loadHandle)	/* loadHandle returned by a previous call to
				 * TclpDlopen(). The loadHandle is a token
				 * that represents the loaded file. */
{
    shl_t handle = (shl_t) loadHandle->clientData;


    shl_unload(handle);
    ckfree(loadHandle);
}

/*
 *----------------------------------------------------------------------
 *

	    ((types->perm & TCL_GLOB_PERM_W) &&
		(access(nativeEntry, W_OK) != 0)) ||
	    ((types->perm & TCL_GLOB_PERM_X) &&
		(access(nativeEntry, X_OK) != 0))
#ifndef MAC_OSX_TCL
	    || ((types->perm & TCL_GLOB_PERM_HIDDEN) &&
		(*nativeName != '.'))
#endif /* MAC_OSX_TCL */
		) {
	    return 0;
	}
    }
    if (types->type != 0) {
	if (types->perm == 0) {
	    /*
	     * We haven't yet done a stat on the file.
	     */

	    if (TclOSstat(nativeEntry, &buf) != 0) {
		/*
		 * Posix error occurred. The only ok case is if this is a link
		 * to a nonexistent file, and the user did 'glob -l'. So we
		 * check that here:
		 */

		if ((types->type & TCL_GLOB_TYPE_LINK)
			&& (TclOSlstat(nativeEntry, &buf) == 0)
			&& S_ISLNK(buf.st_mode)) {
		    return 1;


		}
		return 0;
	    }
	}

	/*
	 * In order bcdpsfl as in 'find -t'

#endif /* S_ISSOCK */
		((types->type & TCL_GLOB_TYPE_FILE) && S_ISREG(buf.st_mode))) {
	    /*
	     * Do nothing - this file is ok.
	     */
	} else {
#ifdef S_ISLNK
	    if ((types->type & TCL_GLOB_TYPE_LINK)
		    && (TclOSlstat(nativeEntry, &buf) == 0)
		    && S_ISLNK(buf.st_mode)) {
		goto filetypeOK;


	    }
#endif /* S_ISLNK */
	    return 0;
	}
    }
  filetypeOK:

    if (getwd(buffer) == NULL) {			/* INTL: Native. */
	return NULL;
    }
#else
    if (getcwd(buffer, MAXPATHLEN+1) == NULL) {		/* INTL: Native. */
	return NULL;
    }
#endif /* USEGETWD */

    if ((clientData == NULL) || strcmp(buffer, (const char *) clientData)) {
	char *newCd = ckalloc(strlen(buffer) + 1);

	strcpy(newCd, buffer);
	return newCd;
    }

    /*

{
    char buffer[MAXPATHLEN+1];

#ifdef USEGETWD
    if (getwd(buffer) == NULL)				/* INTL: Native. */
#else
    if (getcwd(buffer, MAXPATHLEN+1) == NULL)		/* INTL: Native. */
#endif /* USEGETWD */
    {
	if (interp != NULL) {
	    Tcl_SetObjResult(interp, Tcl_ObjPrintf(
		    "error getting working directory name: %s",
		    Tcl_PosixError(interp)));
	}
	return NULL;

	return NULL;
    }

    Tcl_ExternalToUtfDString(NULL, link, length, linkPtr);
    return Tcl_DStringValue(linkPtr);
#else
    return NULL;
#endif /* !DJGPP */
}

/*
 *----------------------------------------------------------------------
 *
 * TclpObjStat --
 *

	return -1;
    }
    return TclOSstat(path, bufPtr);
}

#ifdef S_IFLNK

Tcl_Obj *
TclpObjLink(
    Tcl_Obj *pathPtr,
    Tcl_Obj *toPtr,
    int linkAction)
{
    if (toPtr != NULL) {
	const char *src = Tcl_FSGetNativePath(pathPtr);

int
TclpUtime(
    Tcl_Obj *pathPtr,		/* File to modify */
    struct utimbuf *tval)	/* New modification date structure */
{
    return utime(Tcl_FSGetNativePath(pathPtr), tval);
}

#ifdef __CYGWIN__

int
TclOSstat(
    const char *name,
    Tcl_StatBuf *statBuf)
{
    struct stat buf;
    int result = stat(name, &buf);

    statBuf->st_mode = buf.st_mode;
    statBuf->st_ino = buf.st_ino;
    statBuf->st_dev = buf.st_dev;
    statBuf->st_rdev = buf.st_rdev;
    statBuf->st_nlink = buf.st_nlink;
    statBuf->st_uid = buf.st_uid;
    statBuf->st_gid = buf.st_gid;
    statBuf->st_size = buf.st_size;
    statBuf->st_atime = buf.st_atime;
    statBuf->st_mtime = buf.st_mtime;
    statBuf->st_ctime = buf.st_ctime;
    return result;
}

int
TclOSlstat(
    const char *name,
    Tcl_StatBuf *statBuf)
{
    struct stat buf;
    int result = lstat(name, &buf);

    statBuf->st_mode = buf.st_mode;
    statBuf->st_ino = buf.st_ino;
    statBuf->st_dev = buf.st_dev;
    statBuf->st_rdev = buf.st_rdev;
    statBuf->st_nlink = buf.st_nlink;
    statBuf->st_uid = buf.st_uid;
    statBuf->st_gid = buf.st_gid;
    statBuf->st_size = buf.st_size;
    statBuf->st_atime = buf.st_atime;
    statBuf->st_mtime = buf.st_mtime;
    statBuf->st_ctime = buf.st_ctime;
    return result;
}
#endif /* CYGWIN */

/*
 * Local Variables:
 * mode: c
 * c-basic-offset: 4
 * fill-column: 78
 * End:
 */

				 * notifierMutex lock before accessing these
				 * fields. */
#ifdef __CYGWIN__
    void *event;     /* Any other thread alerts a notifier
	 * that an event is ready to be processed
	 * by sending this event. */
    void *hwnd;			/* Messaging window. */
#else
    Tcl_Condition waitCV;	/* Any other thread alerts a notifier that an
				 * event is ready to be processed by signaling
				 * this condition variable. */
#endif /* __CYGWIN__ */
    int eventReady;		/* True if an event is ready to be processed.
				 * Used as condition flag together with waitCV
				 * above. */
#endif /* TCL_THREADS */
} ThreadSpecificData;

static Tcl_ThreadDataKey dataKey;

#ifdef TCL_THREADS
/*
 * The following static indicates the number of threads that have initialized

 * Static routines defined in this file.
 */

#ifdef TCL_THREADS
static void		NotifierThreadProc(ClientData clientData);
#endif
static int		FileHandlerEventProc(Tcl_Event *evPtr, int flags);

/*
 * Import of Windows API when building threaded with Cygwin.
 */

#if defined(TCL_THREADS) && defined(__CYGWIN__)
typedef struct {
    void *hwnd;
    unsigned int *message;
    int wParam;
    int lParam;
    int time;
    int x;
    int y;
} MSG;

typedef struct {
    unsigned int style;
    void *lpfnWndProc;
    int cbClsExtra;
    int cbWndExtra;
    void *hInstance;
    void *hIcon;
    void *hCursor;
    void *hbrBackground;
    void *lpszMenuName;
    void *lpszClassName;
} WNDCLASS;

extern void __stdcall	CloseHandle(void *);
extern void *__stdcall	CreateEventW(void *, unsigned char, unsigned char,
			    void *);
extern void * __stdcall	CreateWindowExW(void *, void *, void *, DWORD, int,
			    int, int, int, void *, void *, void *, void *);
extern DWORD __stdcall	DefWindowProcW(void *, int, void *, void *);
extern unsigned char __stdcall	DestroyWindow(void *);
extern int __stdcall	DispatchMessageW(const MSG *);
extern unsigned char __stdcall	GetMessageW(MSG *, void *, int, int);
extern void __stdcall	MsgWaitForMultipleObjects(DWORD, void *,
			    unsigned char, DWORD, DWORD);
extern unsigned char __stdcall	PeekMessageW(MSG *, void *, int, int, int);
extern unsigned char __stdcall	PostMessageW(void *, unsigned int, void *,
				    void *);
extern void __stdcall	PostQuitMessage(int);
extern void *__stdcall	RegisterClassW(const WNDCLASS *);
extern unsigned char __stdcall	ResetEvent(void *);
extern unsigned char __stdcall	TranslateMessage(const MSG *);

/*
 * Threaded-cygwin specific functions in this file:
 */

static DWORD __stdcall	NotifierProc(void *hwnd, unsigned int message,
			    void *wParam, void *lParam);
#endif /* TCL_THREADS && __CYGWIN__ */

/*
 *----------------------------------------------------------------------
 *
 * Tcl_InitNotifier --
 *
 *	Initializes the platform specific notifier state.
 *
 * Results:
 *	Returns a handle to the notifier state for this thread.
 *
 * Side effects:
 *	None.
 *
 *----------------------------------------------------------------------
 */











































ClientData
Tcl_InitNotifier(void)
{
    if (tclNotifierHooks.initNotifierProc) {
	return tclNotifierHooks.initNotifierProc();
    } else {
	ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);

	return;
    } else {
#ifdef TCL_THREADS
	ThreadSpecificData *tsdPtr = clientData;

	Tcl_MutexLock(&notifierMutex);
	tsdPtr->eventReady = 1;
#   ifdef __CYGWIN__
	PostMessageW(tsdPtr->hwnd, 1024, 0, 0);
#   else
	Tcl_ConditionNotify(&tsdPtr->waitCV);
#   endif /* __CYGWIN__ */
	Tcl_MutexUnlock(&notifierMutex);
#endif /* TCL_THREADS */
    }
}

/*
 *----------------------------------------------------------------------

	return DefWindowProcW(hwnd, message, wParam, lParam);
    }

    /*
     * Process all of the runnable events.
     */

    tsdPtr->eventReady = 1;
    Tcl_ServiceAll();
    return 0;
}
#endif /* TCL_THREADS && __CYGWIN__ */

/*
 *----------------------------------------------------------------------
 *
 * Tcl_WaitForEvent --
 *
 *	This function is called by Tcl_DoOneEvent to wait for new events on
 *	the message queue. If the block time is 0, then Tcl_WaitForEvent just

	return tclNotifierHooks.waitForEventProc(timePtr);
    } else {
	FileHandler *filePtr;
	int mask;
	Tcl_Time vTime;
#ifdef TCL_THREADS
	int waitForFiles;
#   ifdef __CYGWIN__
	MSG msg;
#   endif /* __CYGWIN__ */
#else
	/*
	 * Impl. notes: timeout & timeoutPtr are used if, and only if threads
	 * are not enabled. They are the arguments for the regular select()
	 * used when the core is not thread-enabled.
	 */

	 * check for, we return with a negative result rather than blocking
	 * forever.
	 */

	if (timePtr != NULL) {
	    /*
	     * TIP #233 (Virtualized Time). Is virtual time in effect? And do
	     * we actually have something to scale? If yes to both then we
	     * call the handler to do this scaling.
	     */

	    if (timePtr->sec != 0 || timePtr->usec != 0) {
		vTime = *timePtr;
		tclScaleTimeProcPtr(&vTime, tclTimeClientData);
		timePtr = &vTime;
	    }
#ifndef TCL_THREADS
	    timeout.tv_sec = timePtr->sec;
	    timeout.tv_usec = timePtr->usec;
	    timeoutPtr = &timeout;
	} else if (tsdPtr->numFdBits == 0) {
	    /*
	     * If there are no threads, no timeout, and no fds registered,
	     * then there are no events possible and we must avoid deadlock.
	     * Note that this is not entirely correct because there might be a
	     * signal that could interrupt the select call, but we don't
	     * handle that case if we aren't using threads.
	     */

	    return -1;
	} else {
	    timeoutPtr = NULL;
#endif /* !TCL_THREADS */
	}

#ifdef TCL_THREADS
	/*
	 * Place this thread on the list of interested threads, signal the
	 * notifier thread, and wait for a response or a timeout.
	 */

#ifdef __CYGWIN__
	if (!tsdPtr->hwnd) {
	    WNDCLASS class;

	    class.style = 0;
	    class.cbClsExtra = 0;
	    class.cbWndExtra = 0;
	    class.hInstance = TclWinGetTclInstance();
	    class.hbrBackground = NULL;
	    class.lpszMenuName = NULL;
	    class.lpszClassName = L"TclNotifier";
	    class.lpfnWndProc = NotifierProc;
	    class.hIcon = NULL;
	    class.hCursor = NULL;

	    RegisterClassW(&class);
	    tsdPtr->hwnd = CreateWindowExW(NULL, class.lpszClassName,
		    class.lpszClassName, 0, 0, 0, 0, 0, NULL, NULL,
		    TclWinGetTclInstance(), NULL);
	    tsdPtr->event = CreateEventW(NULL, 1 /* manual */,
		    0 /* !signaled */, NULL);
	}

#endif /* __CYGWIN */

	Tcl_MutexLock(&notifierMutex);

	if (timePtr != NULL && timePtr->sec == 0 && (timePtr->usec == 0
#if defined(__APPLE__) && defined(__LP64__)
		/*
		 * On 64-bit Darwin, pthread_cond_timedwait() appears to have
		 * a bug that causes it to wait forever when passed an
		 * absolute time which has already been exceeded by the system
		 * time; as a workaround, when given a very brief timeout,
		 * just do a poll. [Bug 1457797]
		 */
		|| timePtr->usec < 10
#endif /* __APPLE__ && __LP64__ */
		)) {
	    /*
	     * Cannot emulate a polling select with a polling condition
	     * variable. Instead, pretend to wait for files and tell the

	    waitForFiles = (tsdPtr->numFdBits > 0);
	    tsdPtr->pollState = 0;
	}

	if (waitForFiles) {
	    /*
	     * Add the ThreadSpecificData structure of this thread to the list
	     * of ThreadSpecificData structures of all threads that are
	     * waiting on file events.
	     */

	    tsdPtr->nextPtr = waitingListPtr;
	    if (waitingListPtr) {
		waitingListPtr->prevPtr = tsdPtr;
	    }
	    tsdPtr->prevPtr = 0;

	FD_ZERO(&tsdPtr->readyMasks.writable);
	FD_ZERO(&tsdPtr->readyMasks.exception);

	if (!tsdPtr->eventReady) {
#ifdef __CYGWIN__
	    if (!PeekMessageW(&msg, NULL, 0, 0, 0)) {
		DWORD timeout;

		if (timePtr) {
		    timeout = timePtr->sec * 1000 + timePtr->usec / 1000;
		} else {
		    timeout = 0xFFFFFFFF;
		}
		Tcl_MutexUnlock(&notifierMutex);
		MsgWaitForMultipleObjects(1, &tsdPtr->event, 0, timeout, 1279);
		Tcl_MutexLock(&notifierMutex);
	    }
#else
	    Tcl_ConditionWait(&tsdPtr->waitCV, &notifierMutex, timePtr);
#endif /* __CYGWIN__ */
	}
	tsdPtr->eventReady = 0;

#ifdef __CYGWIN__
	while (PeekMessageW(&msg, NULL, 0, 0, 0)) {
	    /*
	     * Retrieve and dispatch the message.
	     */

	    DWORD result = GetMessageW(&msg, NULL, 0, 0);

	    if (result == 0) {
		PostQuitMessage(msg.wParam);
		/* What to do here? */
	    } else if (result != (DWORD) -1) {
		TranslateMessage(&msg);
		DispatchMessageW(&msg);
	    }
	}
	ResetEvent(tsdPtr->event);
#endif /* __CYGWIN__ */

	if (waitForFiles && tsdPtr->onList) {
	    /*
	     * Remove the ThreadSpecificData structure of this thread from the
	     * waiting list. Alert the notifier thread to recompute its select
	     * masks - skipping this caused a hang when trying to close a pipe
	     * which the notifier thread was still doing a select on.
	     */

			tsdPtr->nextPtr->prevPtr = tsdPtr->prevPtr;
		    }
		    tsdPtr->nextPtr = tsdPtr->prevPtr = NULL;
		    tsdPtr->onList = 0;
		    tsdPtr->pollState = 0;
		}
#ifdef __CYGWIN__
		PostMessageW(tsdPtr->hwnd, 1024, 0, 0);
#else
		Tcl_ConditionNotify(&tsdPtr->waitCV);
#endif /* __CYGWIN__ */
	    }
	}
	Tcl_MutexUnlock(&notifierMutex);

	/*
	 * Consume the next byte from the notifier pipe if the pipe was

    Tcl_ConditionNotify(&notifierCV);
    Tcl_MutexUnlock(&notifierMutex);

    TclpThreadExit(0);
}
#endif /* TCL_THREADS */

#endif /* !HAVE_COREFOUNDATION */

/*
 * Local Variables:
 * mode: c
 * c-basic-offset: 4
 * fill-column: 78
 * End:
 */

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

#undef STATIC_BUILD
#undef USE_TCL_STUBS
#define USE_TCL_STUBS

#include "tclInt.h"
#ifdef _MSC_VER
#   pragma comment (lib, "advapi32.lib")
#endif
#include <stdlib.h>

#ifndef UNICODE
#   undef Tcl_WinTCharToUtf
#   define Tcl_WinTCharToUtf(a,b,c)	Tcl_ExternalToUtfDString(NULL,a,b,c)
#   undef Tcl_WinUtfToTChar
#   define Tcl_WinUtfToTChar(a,b,c)	Tcl_UtfToExternalDString(NULL,a,b,c)
#endif /* !UNICODE */

/*
 * Ensure that we can say which registry is being accessed.
 */

#ifndef KEY_WOW64_64KEY
#   define KEY_WOW64_64KEY	(0x0100)
#endif
#ifndef KEY_WOW64_32KEY
#   define KEY_WOW64_32KEY	(0x0200)
#endif

/*
 * The maximum length of a sub-key name.
 */

#ifndef MAX_KEY_LENGTH
#   define MAX_KEY_LENGTH	256
#endif

/*
 * TCL_STORAGE_CLASS is set unconditionally to DLLEXPORT because the
 * Registry_Init declaration is in the source file itself, which is only
 * accessed when we are building a library.
 */

#undef TCL_STORAGE_CLASS
#define TCL_STORAGE_CLASS DLLEXPORT









/*
 * The following macros convert between different endian ints.
 */

#define SWAPWORD(x)	MAKEWORD(HIBYTE(x), LOBYTE(x))
#define SWAPLONG(x)	MAKELONG(SWAPWORD(HIWORD(x)), SWAPWORD(LOWORD(x)))

	/*
	 * Multistrings are stored as an array of null-terminated strings,
	 * terminated by two null characters. Also do a bounds check in case
	 * we get bogus data.
	 */

	while ((p < end) && *((Tcl_UniChar *) p) != 0) {

	    Tcl_UniChar *up;

	    Tcl_WinTCharToUtf((TCHAR *) p, -1, &buf);
	    Tcl_ListObjAppendElement(interp, resultPtr,
		    Tcl_NewStringObj(Tcl_DStringValue(&buf),
			    Tcl_DStringLength(&buf)));
	    up = (Tcl_UniChar *) p;

	    while (*up++ != 0) {/* empty body */}
	    p = (char *) up;
	    Tcl_DStringFree(&buf);
	}
	Tcl_SetObjResult(interp, resultPtr);
    } else if ((type == REG_SZ) || (type == REG_EXPAND_SZ)) {
	Tcl_WinTCharToUtf((TCHAR *) Tcl_DStringValue(&data), -1, &buf);
	Tcl_DStringResult(interp, &buf);

	    if (mode && regDeleteKeyExProc) {
		result = regDeleteKeyExProc(startKey, keyName, mode, 0);
	    } else {
		result = RegDeleteKey(startKey, keyName);
	    }
	    break;
	} else if (result == ERROR_SUCCESS) {
	    result = RecursiveDeleteKey(hKey,
		    (const TCHAR *) Tcl_DStringValue(&subkey), mode);
	}
    }
    Tcl_DStringFree(&subkey);
    RegCloseKey(hKey);
    return result;
}


	if (Tcl_GetIntFromObj(interp, dataObj, &value) != TCL_OK) {
	    RegCloseKey(key);
	    Tcl_DStringFree(&nameBuf);
	    return TCL_ERROR;
	}

	value = ConvertDWORD((DWORD) type, (DWORD) value);
	result = RegSetValueEx(key, (TCHAR *) valueName, 0,
		(DWORD) type, (BYTE *) &value, sizeof(DWORD));
    } else if (type == REG_MULTI_SZ) {
	Tcl_DString data, buf;
	int objc, i;
	Tcl_Obj **objv;

	if (Tcl_ListObjGetElements(interp, dataObj, &objc, &objv) != TCL_OK) {

	     */

	    Tcl_DStringAppend(&data, "", 1);	/* NUL-terminated string */
	}

	Tcl_WinUtfToTChar(Tcl_DStringValue(&data), Tcl_DStringLength(&data)+1,
		&buf);
	result = RegSetValueEx(key, (TCHAR *) valueName, 0,
		(DWORD) type, (BYTE *) Tcl_DStringValue(&buf),
		(DWORD) Tcl_DStringLength(&buf));
	Tcl_DStringFree(&data);
	Tcl_DStringFree(&buf);
    } else if (type == REG_SZ || type == REG_EXPAND_SZ) {
	Tcl_DString buf;
	const char *data = Tcl_GetStringFromObj(dataObj, &length);

	data = (char *) Tcl_WinUtfToTChar(data, length, &buf);

	/*
	 * Include the null in the length, padding if needed for Unicode.
	 */

	Tcl_DStringSetLength(&buf, Tcl_DStringLength(&buf)+1);
	length = Tcl_DStringLength(&buf) + 1;

	result = RegSetValueEx(key, (TCHAR *) valueName, 0,
		(DWORD) type, (BYTE *) data, (DWORD) length);
	Tcl_DStringFree(&buf);
    } else {
	BYTE *data;

	/*
	 * Store binary data in the registry.
	 */

	data = (BYTE *) Tcl_GetByteArrayFromObj(dataObj, &length);
	result = RegSetValueEx(key, (TCHAR *) valueName, 0,
		(DWORD) type, data, (DWORD) length);
    }

    Tcl_DStringFree(&nameBuf);
    RegCloseKey(key);

    if (result != ERROR_SUCCESS) {

 */

static DWORD
ConvertDWORD(
    DWORD type,			/* Either REG_DWORD or REG_DWORD_BIG_ENDIAN */
    DWORD value)		/* The value to be converted. */
{
    const DWORD order = 1;
    DWORD localType;

    /*
     * Check to see if the low bit is in the first byte.
     */

    localType = (*((const char *) &order) == 1)
	    ? REG_DWORD : REG_DWORD_BIG_ENDIAN;
    return (type != localType) ? (DWORD) SWAPLONG(value) : value;
}

/*
 * Local Variables:
 * mode: c
 * c-basic-offset: 4
 * fill-column: 78
 * End:
 */