Tcl Source Code

2011-04-16  Donal K. Fellows  <[email protected]>

	* generic/tclFCmd.c (TclFileAttrsCmd): Add comments to make this code
	easier to understand. Added a panic to handle the case where the VFS
	layer does something odd.

2011-04-13  Don Porter  <[email protected]>

	* generic/tclUtil.c:	[Bug 3285375]: Rewrite of Tcl_Concat*()
	routines to prevent segfaults on buffer overflow.  Build them out of
	existing primitives already coded to handle overflow properly.  Uses
	the new TclTrim*() routines.

	* generic/tclCmdMZ.c:	New internal utility routines TclTrimLeft()
	* generic/tclInt.h:	and TclTrimRight().  Refactor the
	* generic/tclUtil.c:	[string trim*] implementations to use them.

2011-04-13  Miguel Sofer  <[email protected]>

	* generic/tclVar.c: [Bug 2662380]: Fix crash caused by appending to a
	variable with a write trace that unsets it.

2011-04-13  Donal K. Fellows  <[email protected]>

	* generic/tclUtil.c (Tcl_ConcatObj): [Bug 3285375]: Make the crash
	less mysterious through the judicious use of a panic. Not yet properly
	fixed, but at least now clearer what the failure mode is.

2011-04-12  Don Porter  <[email protected]>

	* tests/string.test:	Test for [Bug 3285472]. Not buggy in trunk.

2011-04-12  Venkat Iyer <[email protected]>

	* library/tzdata/Atlantic/Stanley: Update to Olson tzdata2011f

2011-04-12  Miguel Sofer  <[email protected]>

	* generic/tclBasic.c: Fix for [Bug 2440625], kbk's patch

2011-04-11  Miguel Sofer  <[email protected]>

	* generic/tclBasic.c:
	* tests/coroutine.test: [Bug 3282869]: Ensure that 'coroutine eval'
	runs the initial command in the proper context.

2011-04-11  Jan Nijtmans  <[email protected]>

	* generic/tcl.h:    Fix for [Bug 3281728]: Tcl sources from 2011-04-06
	* unix/tcl.m4:      do not build on GCC9 (RH9)
	* unix/configure:

2011-04-08  Jan Nijtmans  <[email protected]>

	* win/tclWinPort.h: Fix for [Bug 3280043]: win2k: unresolved DLL
	* win/configure.in: imports.
	* win/configure

2011-04-06  Miguel Sofer  <[email protected]>

	* generic/tclExecute.c (TclCompileObj): Earlier return if Tip280
	gymnastics not needed.

	* generic/tclExecute.c: Fix for [Bug 3274728]: making *catchTop an
	unsigned long.

2011-04-06  Jan Nijtmans  <[email protected]>

	* unix/tclAppInit.c:  Make symbols "main" and "Tcl_AppInit"
	MODULE_SCOPE: there is absolutely no reason for exporting them.
	* unix/tcl.m4:        Don't use -fvisibility=hidden with static

#   else
#       define DLLIMPORT __declspec(dllimport)
#       define DLLEXPORT __declspec(dllexport)
#       define CRTIMPORT __declspec(dllimport)
#   endif
#else
#   define DLLIMPORT
#   if defined(__GNUC__) && __GNUC__ > 3
#       define DLLEXPORT __attribute__ ((visibility("default")))
#   else
#       define DLLEXPORT
#   endif
#   define CRTIMPORT
#endif

    cmdPtr->refCount++;

    /*
     * Find the objProc to call: nreProc if available, objProc otherwise. Push
     * a callback to do the actual running.
     */














    if (cmdPtr->nreProc) {
        TclNRAddCallback(interp, NRRunObjProc, cmdPtr,
                INT2PTR(objc), (ClientData) objv, NULL);
        return TCL_OK;
    } else {
	return cmdPtr->objProc(cmdPtr->objClientData, interp, objc, objv);
    }        

}

void
TclPushTailcallPoint(
    Tcl_Interp *interp)
{
    TclNRAddCallback(interp, NRCommand, NULL, NULL, NULL, NULL);

NRRunObjProc(
    ClientData data[],
    Tcl_Interp *interp,
    int result)
{
    /* OPT: do not call? */


    Command* cmdPtr = data[0];
    int objc = PTR2INT(data[1]);
    Tcl_Obj **objv = data[2];


    return cmdPtr->nreProc(cmdPtr->objClientData, interp, objc, objv);


}


/*
 *----------------------------------------------------------------------
 *
 * TEOV_Exception	 -

    Tcl_Obj *const objv[])	/* Argument objects. */
{
    Command *cmdPtr;
    CoroutineData *corPtr;
    const char *fullName, *procName;
    Namespace *nsPtr, *altNsPtr, *cxtNsPtr;
    Tcl_DString ds;
    Namespace *lookupNsPtr = iPtr->varFramePtr->nsPtr;
    
    if (objc < 3) {
	Tcl_WrongNumArgs(interp, 1, objv, "name cmd ?arg ...?");
	return TCL_ERROR;
    }

    /*

		    &isNew);

	    Tcl_SetHashValue(newPtr, Tcl_GetHashValue(hePtr));
	}
    }

    /*
     * Create the base context.
     */

    corPtr->running.framePtr = iPtr->rootFramePtr;
    corPtr->running.varFramePtr = iPtr->rootFramePtr;
    corPtr->running.cmdFramePtr = NULL;
    corPtr->running.lineLABCPtr = corPtr->lineLABCPtr;
    corPtr->stackLevel = NULL;
    corPtr->auxNumLevels = 0;
    iPtr->numLevels--;
    
    /*
     * Create the coro's execEnv, switch to it to push the exit and coro
     * command callbacks, then switch back. 
     */

    corPtr->eePtr = TclCreateExecEnv(interp, CORO_STACK_INITIAL_SIZE);
    corPtr->callerEEPtr = iPtr->execEnvPtr;
    corPtr->eePtr->corPtr = corPtr;
    
    SAVE_CONTEXT(corPtr->caller);
    corPtr->callerEEPtr = iPtr->execEnvPtr;
    RESTORE_CONTEXT(corPtr->running);
    iPtr->execEnvPtr = corPtr->eePtr;

    TclNRAddCallback(interp, NRCoroutineExitCallback, corPtr,
	    NULL, NULL, NULL);

    iPtr->lookupNsPtr = lookupNsPtr;
    Tcl_NREvalObj(interp, Tcl_NewListObj(objc-2, objv+2), 0);

    SAVE_CONTEXT(corPtr->running);
    RESTORE_CONTEXT(corPtr->caller);
    iPtr->execEnvPtr = corPtr->callerEEPtr;
    
    /*
     * Now just resume the coroutine. Take care to insure that the command is
     * looked up in the correct namespace.
     */

static int
StringTrimCmd(
    ClientData dummy,		/* Not used. */
    Tcl_Interp *interp,		/* Current interpreter. */
    int objc,			/* Number of arguments. */
    Tcl_Obj *const objv[])	/* Argument objects. */
{


    const char *string1, *string2;
    int triml, trimr, length1, length2;

    if (objc == 3) {
	string2 = TclGetStringFromObj(objv[2], &length2);
    } else if (objc == 2) {
	string2 = DEFAULT_TRIM_SET;
	length2 = strlen(DEFAULT_TRIM_SET);
    } else {
	Tcl_WrongNumArgs(interp, 1, objv, "string ?chars?");
	return TCL_ERROR;
    }
    string1 = TclGetStringFromObj(objv[1], &length1);








    triml = TclTrimLeft(string1, length1, string2, length2);



    trimr = TclTrimRight(string1 + triml, length1 - triml, string2, length2);






































    Tcl_SetObjResult(interp,
	    Tcl_NewStringObj(string1 + triml, length1 - triml - trimr));
    return TCL_OK;
}

/*
 *----------------------------------------------------------------------
 *
 * StringTrimLCmd --

static int
StringTrimLCmd(
    ClientData dummy,		/* Not used. */
    Tcl_Interp *interp,		/* Current interpreter. */
    int objc,			/* Number of arguments. */
    Tcl_Obj *const objv[])	/* Argument objects. */
{


    const char *string1, *string2;
    int trim, length1, length2;

    if (objc == 3) {
	string2 = TclGetStringFromObj(objv[2], &length2);
    } else if (objc == 2) {
	string2 = DEFAULT_TRIM_SET;
	length2 = strlen(DEFAULT_TRIM_SET);
    } else {
	Tcl_WrongNumArgs(interp, 1, objv, "string ?chars?");
	return TCL_ERROR;
    }
    string1 = TclGetStringFromObj(objv[1], &length1);








    trim = TclTrimLeft(string1, length1, string2, length2);


















    Tcl_SetObjResult(interp, Tcl_NewStringObj(string1+trim, length1-trim));
    return TCL_OK;
}

/*
 *----------------------------------------------------------------------
 *
 * StringTrimRCmd --

static int
StringTrimRCmd(
    ClientData dummy,		/* Not used. */
    Tcl_Interp *interp,		/* Current interpreter. */
    int objc,			/* Number of arguments. */
    Tcl_Obj *const objv[])	/* Argument objects. */
{


    const char *string1, *string2;
    int trim, length1, length2;

    if (objc == 3) {
	string2 = TclGetStringFromObj(objv[2], &length2);
    } else if (objc == 2) {
	string2 = DEFAULT_TRIM_SET;
	length2 = strlen(DEFAULT_TRIM_SET);
    } else {
	Tcl_WrongNumArgs(interp, 1, objv, "string ?chars?");
	return TCL_ERROR;
    }
    string1 = TclGetStringFromObj(objv[1], &length1);







    trim = TclTrimRight(string1, length1, string2, length2);


















    Tcl_SetObjResult(interp, Tcl_NewStringObj(string1, length1-trim));
    return TCL_OK;
}

/*
 *----------------------------------------------------------------------
 *
 * TclInitStringCmd --

    }

    objc -= 2;
    objv += 2;
    result = TCL_ERROR;
    Tcl_SetErrno(0);

    /*
     * Get the set of attribute names from the filesystem.
     */

    attributeStrings = Tcl_FSFileAttrStrings(filePtr, &objStrings);
    if (attributeStrings == NULL) {
	int index;
	Tcl_Obj *objPtr;

	if (objStrings == NULL) {
	    if (Tcl_GetErrno() != 0) {
		/*
		 * There was an error, probably that the filePtr is not
		 * accepted by any filesystem
		 */
		Tcl_AppendResult(interp, "could not read \"",
			TclGetString(filePtr), "\": ", Tcl_PosixError(interp),
			NULL);

	    }

	    return TCL_ERROR;
	}

	/*
	 * We own the object now.
	 */

	Tcl_IncrRefCount(objStrings);

		TclStackAlloc(interp, (1+numObjStrings) * sizeof(char *));
	for (index = 0; index < numObjStrings; index++) {
	    Tcl_ListObjIndex(interp, objStrings, index, &objPtr);
	    attributeStringsAllocated[index] = TclGetString(objPtr);
	}
	attributeStringsAllocated[index] = NULL;
	attributeStrings = attributeStringsAllocated;
    } else if (objStrings != NULL) {
	Tcl_Panic("must not update objPtrRef's variable and return non-NULL");
    }

    /*
     * Process the attributes to produce a list of all of them, the value of a
     * particular attribute, or to set one or more attributes (depending on
     * the number of arguments).
     */

    if (objc == 0) {
	/*
	 * Get all attributes.
	 */

	int index, res = TCL_OK, nbAtts = 0;
	Tcl_Obj *listPtr;

		    objv[i + 1]) != TCL_OK) {
		goto end;
	    }
	}
    }
    result = TCL_OK;



    /*
     * Free up the array we allocated and drop our reference to any list of
     * attribute names issued by the filesystem.
     */

  end:
    if (attributeStringsAllocated != NULL) {
	TclStackFree(interp, (void *) attributeStringsAllocated);
    }




    if (objStrings != NULL) {
	Tcl_DecrRefCount(objStrings);

    }
    return result;
}

/*
 *----------------------------------------------------------------------
 *

			    Tcl_Obj *const opts[], int *flagPtr);
MODULE_SCOPE void	TclSubstParse(Tcl_Interp *interp, const char *bytes,
			    int numBytes, int flags, Tcl_Parse *parsePtr,
			    Tcl_InterpState *statePtr);
MODULE_SCOPE int	TclSubstTokens(Tcl_Interp *interp, Tcl_Token *tokenPtr,
			    int count, int *tokensLeftPtr, int line,
			    int *clNextOuter, const char *outerScript);
MODULE_SCOPE int	TclTrimLeft(const char *bytes, int numBytes,
			    const char *trim, int numTrim);
MODULE_SCOPE int	TclTrimRight(const char *bytes, int numBytes,
			    const char *trim, int numTrim);
MODULE_SCOPE Tcl_Obj *	TclpNativeToNormalized(ClientData clientData);
MODULE_SCOPE Tcl_Obj *	TclpFilesystemPathType(Tcl_Obj *pathPtr);
MODULE_SCOPE int	TclpDlopen(Tcl_Interp *interp, Tcl_Obj *pathPtr,
			    Tcl_LoadHandle *loadHandle,
			    Tcl_FSUnloadFileProc **unloadProcPtr);
MODULE_SCOPE int	TclpUtime(Tcl_Obj *pathPtr, struct utimbuf *tval);
#ifdef TCL_LOAD_FROM_MEMORY

    TclUtfToUniChar(buf, &ch);
    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);

    return p - bytes;
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_Concat --
 *
 *	Concatenate a set of strings into a single large string.
 *
 * Results:
 *	The return value is dynamically-allocated string containing a
 *	concatenation of all the strings in argv, with spaces between the
 *	original argv elements.
 *
 * Side effects:
 *	Memory is allocated for the result; the caller is responsible for
 *	freeing the memory.
 *
 *----------------------------------------------------------------------
 */

/* The whitespace characters trimmed during [concat] operations */
#define CONCAT_WS " \f\v\r\t\n"
#define CONCAT_WS_SIZE (int) (sizeof(CONCAT_WS "") - 1)

char *
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 = (char *) 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;
    }
    *p = '\0';
    return result;
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_ConcatObj --

 */

Tcl_Obj *
Tcl_ConcatObj(
    int objc,			/* Number of objects to concatenate. */
    Tcl_Obj *const objv[])	/* Array of objects to concatenate. */
{
    int i, elemLength, needSpace = 0, bytesNeeded = 0;

    const char *element;

    Tcl_Obj *objPtr, *resPtr;

    /*
     * Check first to see if all the items are of list type or empty. If so,
     * we will concat them together as lists, and return a list object. This
     * is only valid when the lists are in canonical form.



     */

    for (i = 0;  i < objc;  i++) {
	List *listRepPtr;

	objPtr = objv[i];
	if (objPtr->typePtr != &tclListType) {

    }

    /*
     * 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;
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_StringMatch --
 *

	if (varPtr == NULL) {
	    return TCL_ERROR;
	}
	for (i=2 ; i<objc ; i++) {
	    /*
	     * Note that we do not need to increase the refCount of the Var
	     * pointers: should a trace delete the variable, the return value
	     * of TclPtrSetVar will be NULL or emptyObjPtr, and we will not
	     * access the variable again.
	     */

	    varValuePtr = TclPtrSetVar(interp, varPtr, arrayPtr, objv[1],
		    NULL, objv[i], TCL_APPEND_VALUE|TCL_LEAVE_ERR_MSG, -1);
	    if ((varValuePtr == NULL) ||
		    (varValuePtr == ((Interp *) interp)->emptyObjPtr)) {
		return TCL_ERROR;
	    }
	}
    }
    Tcl_SetObjResult(interp, varValuePtr);
    return TCL_OK;
}

    {1188712800 -10800 1 FKST}
    {1208667600 -14400 0 FKT}
    {1220767200 -10800 1 FKST}
    {1240117200 -14400 0 FKT}
    {1252216800 -10800 1 FKST}
    {1271566800 -14400 0 FKT}
    {1283666400 -10800 1 FKST}

    {1315112400 -10800 1 FKST}
    {1334466000 -14400 0 FKT}
    {1346565600 -10800 1 FKST}
    {1366520400 -14400 0 FKT}
    {1378015200 -10800 1 FKST}
    {1397970000 -14400 0 FKT}
    {1410069600 -10800 1 FKST}
    {1429419600 -14400 0 FKT}

	set end [getbytes]
    }
    set leakedBytes [expr {$end - $start}]
} -cleanup {
    rename getbytes {}
    unset i ns start end
} -result 0

test coroutine-4.6 {compile context, bug #3282869} -setup {
    unset ::x
    proc f x {
	coroutine D eval {yield X$x;yield Y}
    }
} -body {
    f 12
} -cleanup {
    rename f {}
} -returnCodes error -match glob -result {can't read *}

test coroutine-4.7 {compile context, bug #3282869} -setup {
    proc f x {
	coroutine D eval {yield X$x;yield Y$x}
    }
} -body {
    set ::x 15
    set ::x [f 12]
    D
} -cleanup {
    unset ::x
    rename f {}
} -result YX15

test coroutine-5.1 {right numLevels on coro return} -constraints {testnrelevels} \
-setup {
    proc nestedYield {{val {}}} {
	yield $val
    }
    proc getNumLevel {} {

    list [catch {load [file join $testDir pkgc$ext] foo} msg] $msg $errorCode
} -match glob \
    -result [list 1 {cannot find symbol "Foo_Init"*} \
		 {TCL LOOKUP LOAD_SYMBOL *Foo_Init}]
test load-2.4 {loading with no _SafeInit procedure} [list $dll $loaded] {
    list [catch {load [file join $testDir pkga$ext] {} child} msg] $msg
} {1 {can't use package in a safe interpreter: no Pkga_SafeInit procedure}}





test load-3.1 {error in _Init procedure, same interpreter} \
	[list $dll $loaded] {
    list [catch {load [file join $testDir pkge$ext] pkge} msg] \
	    $msg $::errorInfo $::errorCode
} {1 {couldn't open "non_existent": no such file or directory} {couldn't open "non_existent": no such file or directory
    while executing

    string reverse $x
} \udead\ubeef
test string-24.11 {string reverse command - corner case} {
    set x \ubeef
    set y \udead
    string reverse $x$y
} \udead\ubeef
test string-24.12 {string reverse command - corner case} {
    set x \ubeef
    set y \udead
    string is ascii [string reverse $x$y]
} 0

test string-25.1 {string is list} {
    string is list {a b c}
} 1
test string-25.2 {string is list} {
    string is list "a \{b c"
} 0

    { echo "$as_me:$LINENO: checking if compiler supports visibility \"hidden\"" >&5
echo $ECHO_N "checking if compiler supports visibility \"hidden\"... $ECHO_C" >&6; }
if test "${tcl_cv_cc_visibility_hidden+set}" = set; then
  echo $ECHO_N "(cached) $ECHO_C" >&6
else

	    if test "$SHARED_BUILD" = 1; then

		hold_cflags=$CFLAGS; CFLAGS="$CFLAGS -fvisibility=hidden -Werror"
		cat >conftest.$ac_ext <<_ACEOF
/* confdefs.h.  */
_ACEOF
cat confdefs.h >>conftest.$ac_ext
cat >>conftest.$ac_ext <<_ACEOF
/* end confdefs.h.  */

int
main ()
{
#if !defined(__GNUC__) || __GNUC__ < 4
#error visibility hidden is not supported for this compiler
#endif

  ;
  return 0;
}
_ACEOF
rm -f conftest.$ac_objext
if { (ac_try="$ac_compile"

 * Prototypes for procedures defined later in this file:
 */

static int    Pkga_EqObjCmd(ClientData clientData,
		Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]);
static int    Pkga_QuoteObjCmd(ClientData clientData,
		Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]);












/*
 *----------------------------------------------------------------------
 *
 * Pkga_EqObjCmd --
 *
 *	This procedure is invoked to process the "pkga_eq" Tcl command. It

static int
Pkga_QuoteObjCmd(
    ClientData dummy,		/* Not used. */
    Tcl_Interp *interp,		/* Current interpreter. */
    int objc,			/* Number of arguments. */
    Tcl_Obj *const objv[])	/* Argument strings. */
{
    if (objc != 2) {
	Tcl_WrongNumArgs(interp, 1, objv, "value");
	return TCL_ERROR;
    }



    Tcl_SetObjResult(interp, objv[1]);

    return TCL_OK;
}

/*
 *----------------------------------------------------------------------
 *
 * Pkga_Init --

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

#undef STATIC_BUILD
#include "tcl.h"


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

static int
PkguaQuoteObjCmd(
    ClientData dummy,		/* Not used. */
    Tcl_Interp *interp,		/* Current interpreter. */
    int objc,			/* Number of arguments. */
    Tcl_Obj *const objv[])	/* Argument strings. */
{
    if (objc != 2) {
	Tcl_WrongNumArgs(interp, 1, objv, "value");
	return TCL_ERROR;
    }









    Tcl_SetObjResult(interp, objv[1]);

    return TCL_OK;
}

/*
 *----------------------------------------------------------------------
 *
 * Pkgua_Init --

		fi
		done
	    fi
	])

	if test x"${ac_cv_c_tclconfig}" = x ; then
	    TCL_BIN_DIR="# no Tcl configs found"
	    AC_MSG_ERROR([Can't find Tcl configuration definitions. Use --with-tcl to specify a directory containing tclConfig.sh])

	else
	    no_tcl=
	    TCL_BIN_DIR="${ac_cv_c_tclconfig}"
	    AC_MSG_RESULT([found ${TCL_BIN_DIR}/tclConfig.sh])
	fi
    fi
])

		    fi
		done
	    fi
	])

	if test x"${ac_cv_c_tkconfig}" = x ; then
	    TK_BIN_DIR="# no Tk configs found"
	    AC_MSG_ERROR([Can't find Tk configuration definitions. Use --with-tk to specify a directory containing tkConfig.sh])

	else
	    no_tk=
	    TK_BIN_DIR="${ac_cv_c_tkconfig}"
	    AC_MSG_RESULT([found ${TK_BIN_DIR}/tkConfig.sh])
	fi
    fi
])

    if test -f "${TCL_BIN_DIR}/Makefile" ; then
        TCL_LIB_SPEC="${TCL_BUILD_LIB_SPEC}"
        TCL_STUB_LIB_SPEC="${TCL_BUILD_STUB_LIB_SPEC}"
        TCL_STUB_LIB_PATH="${TCL_BUILD_STUB_LIB_PATH}"
    elif test "`uname -s`" = "Darwin"; then
	# If Tcl was built as a framework, attempt to use the libraries
	# from the framework at the given location so that linking works
	# against Tcl.framework installed in an arbitrary location.
	case ${TCL_DEFS} in
	    *TCL_FRAMEWORK*)
		if test -f "${TCL_BIN_DIR}/${TCL_LIB_FILE}"; then
		    for i in "`cd "${TCL_BIN_DIR}"; pwd`" \
			     "`cd "${TCL_BIN_DIR}"/../..; pwd`"; do
			if test "`basename "$i"`" = "${TCL_LIB_FILE}.framework"; then
			    TCL_LIB_SPEC="-F`dirname "$i" | sed -e 's/ /\\\\ /g'` -framework ${TCL_LIB_FILE}"

    if test -f "${TK_BIN_DIR}/Makefile" ; then
        TK_LIB_SPEC="${TK_BUILD_LIB_SPEC}"
        TK_STUB_LIB_SPEC="${TK_BUILD_STUB_LIB_SPEC}"
        TK_STUB_LIB_PATH="${TK_BUILD_STUB_LIB_PATH}"
    elif test "`uname -s`" = "Darwin"; then
	# If Tk was built as a framework, attempt to use the libraries
	# from the framework at the given location so that linking works
	# against Tk.framework installed in an arbitrary location.
	case ${TK_DEFS} in
	    *TK_FRAMEWORK*)
		if test -f "${TK_BIN_DIR}/${TK_LIB_FILE}"; then
		    for i in "`cd "${TK_BIN_DIR}"; pwd`" \
			     "`cd "${TK_BIN_DIR}"/../..; pwd`"; do
			if test "`basename "$i"`" = "${TK_LIB_FILE}.framework"; then
			    TK_LIB_SPEC="-F`dirname "$i" | sed -e 's/ /\\\\ /g'` -framework ${TK_LIB_FILE}"

    AS_IF([test "$do64bitVIS" = "yes"], [do64bit=yes])

    # Step 0.c: Check if visibility support is available. Do this here so
    # that platform specific alternatives can be used below if this fails.

    AC_CACHE_CHECK([if compiler supports visibility "hidden"],
	tcl_cv_cc_visibility_hidden, [
	    AS_IF([test "$SHARED_BUILD" = 1], [
		hold_cflags=$CFLAGS; CFLAGS="$CFLAGS -fvisibility=hidden -Werror"
		AC_TRY_COMPILE(,[#if !defined(__GNUC__) || __GNUC__ < 4
#error visibility hidden is not supported for this compiler
#endif
		], tcl_cv_cc_visibility_hidden=yes,
		    tcl_cv_cc_visibility_hidden=no)
		CFLAGS=$hold_cflags
	    ], [
		tcl_cv_cc_visibility_hidden=no
	    ])
    ])
    AS_IF([test $tcl_cv_cc_visibility_hidden = yes], [

#	no include files, so double-check its result just to be safe.
#
# Arguments:
#	none
#
# Results:
#
#	Sets the following vars:
#		XINCLUDES
#		XLIBSW
#
#--------------------------------------------------------------------

AC_DEFUN([SC_PATH_X], [
    AC_PATH_X

    (Tcl_SetVar)(interp, "tcl_rcFileName", "~/tclsh.rc", TCL_GLOBAL_ONLY);
#else
    (Tcl_SetVar)(interp, "tcl_rcFileName", "~/.tclshrc", TCL_GLOBAL_ONLY);
#endif

    return TCL_OK;
}








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