summaryrefslogtreecommitdiffstats
path: root/generic
diff options
context:
space:
mode:
Diffstat (limited to 'generic')
-rw-r--r--generic/tclBasic.c31
-rw-r--r--generic/tclCmdAH.c41
-rw-r--r--generic/tclCompile.c8
-rw-r--r--generic/tclEncoding.c233
-rw-r--r--generic/tclExecute.c13
-rw-r--r--generic/tclFileName.c4
-rw-r--r--generic/tclGet.c244
-rw-r--r--generic/tclIO.c8
-rw-r--r--generic/tclIOUtil.c17
-rw-r--r--generic/tclInt.h7
-rw-r--r--generic/tclInterp.c152
-rw-r--r--generic/tclLiteral.c8
-rw-r--r--generic/tclObj.c441
-rwxr-xr-xgeneric/tclThreadAlloc.c4
-rw-r--r--generic/tclUtil.c16
-rw-r--r--generic/tclVar.c4
16 files changed, 506 insertions, 725 deletions
diff --git a/generic/tclBasic.c b/generic/tclBasic.c
index 66631a1..b7c1a1b 100644
--- a/generic/tclBasic.c
+++ b/generic/tclBasic.c
@@ -13,7 +13,7 @@
* See the file "license.terms" for information on usage and redistribution
* of this file, and for a DISCLAIMER OF ALL WARRANTIES.
*
- * RCS: @(#) $Id: tclBasic.c,v 1.136.2.6 2005/04/10 23:14:45 kennykb Exp $
+ * RCS: @(#) $Id: tclBasic.c,v 1.136.2.7 2005/04/25 21:37:19 kennykb Exp $
*/
#include "tclInt.h"
@@ -573,6 +573,10 @@ Tcl_CreateInterp()
TclDefaultBgErrorHandlerObjCmd, (ClientData) NULL,
(Tcl_CmdDeleteProc*) NULL );
+ /* Register the unsupported encoding search path command */
+ Tcl_CreateObjCommand (interp, "::tcl::unsupported::EncodingDirs",
+ TclEncodingDirsObjCmd, NULL, NULL);
+
/*
* Register the builtin math functions.
*/
@@ -4348,20 +4352,7 @@ Tcl_ExprBoolean(interp, string, ptr)
/*
* Store a boolean based on the expression result.
*/
-
- if (resultPtr->typePtr == &tclIntType) {
- *ptr = (resultPtr->internalRep.longValue != 0);
- } else if (resultPtr->typePtr == &tclDoubleType) {
- *ptr = (resultPtr->internalRep.doubleValue != 0.0);
- } else if (resultPtr->typePtr == &tclWideIntType) {
-#ifndef TCL_WIDE_INT_IS_LONG
- *ptr = (resultPtr->internalRep.wideValue != 0);
-#else
- *ptr = (resultPtr->internalRep.longValue != 0);
-#endif
- } else {
- result = Tcl_GetBooleanFromObj(interp, resultPtr, ptr);
- }
+ result = Tcl_GetBooleanFromObj(interp, resultPtr, ptr);
Tcl_DecrRefCount(resultPtr); /* discard the result object */
}
if (result != TCL_OK) {
@@ -4471,13 +4462,7 @@ Tcl_ExprBooleanObj(interp, objPtr, ptr)
result = Tcl_ExprObj(interp, objPtr, &resultPtr);
if (result == TCL_OK) {
- if (resultPtr->typePtr == &tclIntType) {
- *ptr = (resultPtr->internalRep.longValue != 0);
- } else if (resultPtr->typePtr == &tclDoubleType) {
- *ptr = (resultPtr->internalRep.doubleValue != 0.0);
- } else {
- result = Tcl_GetBooleanFromObj(interp, resultPtr, ptr);
- }
+ result = Tcl_GetBooleanFromObj(interp, resultPtr, ptr);
Tcl_DecrRefCount(resultPtr); /* discard the result object */
}
return result;
@@ -4620,7 +4605,7 @@ TclObjInvoke(interp, objc, objv, flags)
Tcl_IncrRefCount( command );
cmdString = Tcl_GetStringFromObj(command, &length);
Tcl_LogCommandInfo(interp, cmdString, cmdString, length);
- Tcl_DecrRefCount( command );
+ Tcl_DecrRefCount(command);
iPtr->flags &= ~ERR_ALREADY_LOGGED;
}
return result;
diff --git a/generic/tclCmdAH.c b/generic/tclCmdAH.c
index 60893fd..b75272a 100644
--- a/generic/tclCmdAH.c
+++ b/generic/tclCmdAH.c
@@ -11,7 +11,7 @@
* See the file "license.terms" for information on usage and redistribution
* of this file, and for a DISCLAIMER OF ALL WARRANTIES.
*
- * RCS: @(#) $Id: tclCmdAH.c,v 1.57.2.2 2005/04/10 23:14:45 kennykb Exp $
+ * RCS: @(#) $Id: tclCmdAH.c,v 1.57.2.3 2005/04/25 21:37:19 kennykb Exp $
*/
#include "tclInt.h"
@@ -530,6 +530,45 @@ Tcl_EncodingObjCmd(dummy, interp, objc, objv)
/*
*----------------------------------------------------------------------
*
+ * TclEncodingDirsObjCmd --
+ *
+ * This command manipulates the encoding search path.
+ *
+ * Results:
+ * A standard Tcl result.
+ *
+ * Side effects:
+ * Can set the encoding search path.
+ *
+ *----------------------------------------------------------------------
+ */
+
+int
+TclEncodingDirsObjCmd(dummy, interp, objc, objv)
+ ClientData dummy; /* Not used. */
+ Tcl_Interp *interp; /* Current interpreter. */
+ int objc; /* Number of arguments. */
+ Tcl_Obj *CONST objv[]; /* Argument objects. */
+{
+ if (objc > 2) {
+ Tcl_WrongNumArgs(interp, 1, objv, "?dirList?");
+ }
+ if (objc == 1) {
+ Tcl_SetObjResult(interp, TclGetEncodingSearchPath());
+ return TCL_OK;
+ }
+ if (TclSetEncodingSearchPath(objv[1]) == TCL_ERROR) {
+ Tcl_AppendResult(interp, "expected directory list but got \"",
+ Tcl_GetString(objv[1]), "\"", NULL);
+ return TCL_ERROR;
+ }
+ Tcl_SetObjResult(interp, objv[1]);
+ return TCL_OK;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
* Tcl_ErrorObjCmd --
*
* This procedure is invoked to process the "error" Tcl command.
diff --git a/generic/tclCompile.c b/generic/tclCompile.c
index ccec254..f539bf2 100644
--- a/generic/tclCompile.c
+++ b/generic/tclCompile.c
@@ -11,7 +11,7 @@
* See the file "license.terms" for information on usage and redistribution
* of this file, and for a DISCLAIMER OF ALL WARRANTIES.
*
- * RCS: @(#) $Id: tclCompile.c,v 1.78.2.3 2005/03/15 20:23:39 kennykb Exp $
+ * RCS: @(#) $Id: tclCompile.c,v 1.78.2.4 2005/04/25 21:37:19 kennykb Exp $
*/
#include "tclInt.h"
@@ -3108,6 +3108,7 @@ TclPrintByteCodeObj(interp, objPtr)
}
#endif /* TCL_COMPILE_DEBUG */
+#ifdef TCL_COMPILE_DEBUG
/*
*----------------------------------------------------------------------
*
@@ -3238,7 +3239,9 @@ TclPrintInstruction(codePtr, pc)
fprintf(stdout, "\n");
return numBytes;
}
+#endif /* TCL_COMPILE_DEBUG */
+#ifdef TCL_COMPILE_DEBUG
/*
*----------------------------------------------------------------------
*
@@ -3269,7 +3272,9 @@ TclPrintObject(outFile, objPtr, maxChars)
bytes = Tcl_GetStringFromObj(objPtr, &length);
TclPrintSource(outFile, bytes, TclMin(length, maxChars));
}
+#endif /* TCL_COMPILE_DEBUG */
+#ifdef TCL_COMPILE_DEBUG
/*
*----------------------------------------------------------------------
*
@@ -3331,6 +3336,7 @@ TclPrintSource(outFile, stringPtr, maxChars)
}
fprintf(outFile, "\"");
}
+#endif /* TCL_COMPILE_DEBUG */
#ifdef TCL_COMPILE_STATS
/*
diff --git a/generic/tclEncoding.c b/generic/tclEncoding.c
index 6b32340..fb1f100 100644
--- a/generic/tclEncoding.c
+++ b/generic/tclEncoding.c
@@ -8,7 +8,7 @@
* See the file "license.terms" for information on usage and redistribution
* of this file, and for a DISCLAIMER OF ALL WARRANTIES.
*
- * RCS: @(#) $Id: tclEncoding.c,v 1.29.2.3 2005/04/10 23:14:48 kennykb Exp $
+ * RCS: @(#) $Id: tclEncoding.c,v 1.29.2.4 2005/04/25 21:37:19 kennykb Exp $
*/
#include "tclInt.h"
@@ -150,9 +150,8 @@ static ProcessGlobalValue encodingSearchPath =
* threads. Access to the shared string is governed by a mutex lock.
*/
-static TclInitProcessGlobalValueProc InitializeEncodingFileMap;
static ProcessGlobalValue encodingFileMap =
- {0, 0, NULL, NULL, InitializeEncodingFileMap, NULL, NULL};
+ {0, 0, NULL, NULL, NULL, NULL, NULL};
/*
* A list of directories making up the "library path". Historically
@@ -224,7 +223,8 @@ static Tcl_Encoding LoadTableEncoding _ANSI_ARGS_((CONST char *name,
int type, Tcl_Channel chan));
static Tcl_Encoding LoadEscapeEncoding _ANSI_ARGS_((CONST char *name,
Tcl_Channel chan));
-static Tcl_Obj * MakeFileMap ();
+static Tcl_Channel OpenEncodingFileChannel _ANSI_ARGS_((Tcl_Interp *interp,
+ CONST char *name));
static void TableFreeProc _ANSI_ARGS_((ClientData clientData));
static int TableFromUtfProc _ANSI_ARGS_((ClientData clientData,
CONST char *src, int srcLen, int flags,
@@ -388,7 +388,6 @@ TclSetEncodingSearchPath(searchPath)
return TCL_ERROR;
}
TclSetProcessGlobalValue(&encodingSearchPath, searchPath, NULL);
- FillEncodingFileMap();
return TCL_OK;
}
@@ -441,7 +440,10 @@ TclSetLibraryPath(path)
/*
*---------------------------------------------------------------------------
*
- * MakeFileMap --
+ * FillEncodingFileMap --
+ *
+ * Called to bring the encoding file map in sync with the current
+ * value of the encoding search path.
*
* Scan the directories on the encoding search path, find the
* *.enc files, and store the found pathnames in a map associated
@@ -462,8 +464,8 @@ TclSetLibraryPath(path)
*---------------------------------------------------------------------------
*/
-static Tcl_Obj *
-MakeFileMap()
+void
+FillEncodingFileMap()
{
int i, numDirs = 0;
Tcl_Obj *map, *searchPath;
@@ -505,33 +507,6 @@ MakeFileMap()
Tcl_DecrRefCount(directory);
}
Tcl_DecrRefCount(searchPath);
- return map;
-}
-
-/*
- *---------------------------------------------------------------------------
- *
- * FillEncodingFileMap --
- *
- * Called to bring the encoding file map in sync with the current
- * value of the encoding search path.
- *
- * TODO: Check the callers of this routine to see if it's called
- * too frequently.
- *
- * Results:
- * None.
- *
- * Side effects:
- * Entries are added to the encoding file map.
- *
- *---------------------------------------------------------------------------
- */
-
-void
-FillEncodingFileMap()
-{
- Tcl_Obj *map = MakeFileMap();
TclSetProcessGlobalValue(&encodingFileMap, map, NULL);
Tcl_DecrRefCount(map);
}
@@ -1395,67 +1370,134 @@ Tcl_FindExecutable(argv0)
/*
*---------------------------------------------------------------------------
*
- * LoadEncodingFile --
+ * OpenEncodingFileChannel --
*
- * Read a file that describes an encoding and create a new Encoding
- * from the data.
+ * Open the file believed to hold data for the encoding, "name".
*
* Results:
- * The return value is the newly loaded Encoding, or NULL if
- * the file didn't exist of was in the incorrect format. If NULL was
+ * Returns the readable Tcl_Channel from opening the file, or NULL
+ * if the file could not be successfully opened. If NULL was
* returned, an error message is left in interp's result object,
* unless interp was NULL.
*
* Side effects:
- * File read from disk.
+ * Channel may be opened. Information about the filesystem may be
+ * cached to speed later calls.
*
*---------------------------------------------------------------------------
*/
-static Tcl_Encoding
-LoadEncodingFile(interp, name)
+static Tcl_Channel
+OpenEncodingFileChannel(interp, name)
Tcl_Interp *interp; /* Interp for error reporting, if not NULL. */
CONST char *name; /* The name of the encoding file on disk
* and also the name for new encoding. */
{
- Tcl_Channel chan;
- Tcl_Encoding encoding;
- Tcl_Obj *map, *path, *directory = NULL;
Tcl_Obj *nameObj = Tcl_NewStringObj(name, -1);
- int ch, scanned = 0;
+ Tcl_Obj *fileNameObj = Tcl_DuplicateObj(nameObj);
+ Tcl_Obj *searchPath = Tcl_DuplicateObj(TclGetEncodingSearchPath());
+ Tcl_Obj *map = TclGetProcessGlobalValue(&encodingFileMap);
+ Tcl_Obj **dir, *path, *directory = NULL;
+ Tcl_Channel chan = NULL;
+ int i, numDirs;
+
+ Tcl_ListObjGetElements(NULL, searchPath, &numDirs, &dir);
+ Tcl_IncrRefCount(nameObj);
+ Tcl_AppendToObj(fileNameObj, ".enc", -1);
+ Tcl_IncrRefCount(fileNameObj);
+ Tcl_DictObjGet(NULL, map, nameObj, &directory);
+ /* Check that any cached directory is still on the encoding search path */
+ if (NULL != directory) {
+ int verified = 0;
- Tcl_IncrRefCount(nameObj);
- while (1) {
- map = TclGetProcessGlobalValue(&encodingFileMap);
- Tcl_DictObjGet(NULL, map, nameObj, &directory);
- if (scanned || (NULL != directory)) {
- break;
+ for (i=0; i<numDirs && !verified; i++) {
+ if (dir[i] == directory) {
+ verified = 1;
+ }
+ }
+ if (!verified) {
+ CONST char *dirString = Tcl_GetString(directory);
+ for (i=0; i<numDirs && !verified; i++) {
+ if (strcmp(dirString, Tcl_GetString(dir[i])) == 0) {
+ verified = 1;
+ }
+ }
+ }
+ if (!verified) {
+ /* Directory no longer on the search path. Remove from cache */
+ map = Tcl_DuplicateObj(map);
+ Tcl_DictObjRemove(NULL, map, nameObj);
+ TclSetProcessGlobalValue(&encodingFileMap, map, NULL);
+ directory = NULL;
}
-scan:
- FillEncodingFileMap();
- scanned = 1;
}
- if (NULL == directory) {
- Tcl_DecrRefCount(nameObj);
- goto unknown;
+
+ if (NULL != directory) {
+ /* Got a directory from the cache. Try to use it first */
+ Tcl_IncrRefCount(directory);
+ path = Tcl_FSJoinToPath(directory, 1, &fileNameObj);
+ Tcl_IncrRefCount(path);
+ Tcl_DecrRefCount(directory);
+ chan = Tcl_FSOpenFileChannel(NULL, path, "r", 0);
+ Tcl_DecrRefCount(path);
}
- /* Construct $directory/$encoding.enc path name */
- Tcl_IncrRefCount(directory);
- Tcl_AppendToObj(nameObj, ".enc", -1);
- path = Tcl_FSJoinToPath(directory, 1, &nameObj);
- Tcl_DecrRefCount(directory);
+ /* Scan the search path until we find it. */
+ for (i=0; i<numDirs && (chan == NULL); i++) {
+ path = Tcl_FSJoinToPath(dir[i], 1, &fileNameObj);
+ Tcl_IncrRefCount(path);
+ chan = Tcl_FSOpenFileChannel(NULL, path, "r", 0);
+ Tcl_DecrRefCount(path);
+ if (chan != NULL) {
+ /* Save directory in the cache */
+ map = Tcl_DuplicateObj(TclGetProcessGlobalValue(&encodingFileMap));
+ Tcl_DictObjPut(NULL, map, nameObj, dir[i]);
+ TclSetProcessGlobalValue(&encodingFileMap, map, NULL);
+ }
+ }
+ if ((NULL == chan) && (interp != NULL)) {
+ Tcl_AppendResult(interp, "unknown encoding \"", name, "\"", NULL);
+ }
+ Tcl_DecrRefCount(fileNameObj);
Tcl_DecrRefCount(nameObj);
- Tcl_IncrRefCount(path);
- chan = Tcl_FSOpenFileChannel(NULL, path, "r", 0);
- Tcl_DecrRefCount(path);
+ Tcl_DecrRefCount(searchPath);
+ return chan;
+}
+
+/*
+ *---------------------------------------------------------------------------
+ *
+ * LoadEncodingFile --
+ *
+ * Read a file that describes an encoding and create a new Encoding
+ * from the data.
+ *
+ * Results:
+ * The return value is the newly loaded Encoding, or NULL if
+ * the file didn't exist of was in the incorrect format. If NULL was
+ * returned, an error message is left in interp's result object,
+ * unless interp was NULL.
+ *
+ * Side effects:
+ * File read from disk.
+ *
+ *---------------------------------------------------------------------------
+ */
- if (NULL == chan) {
- if (!scanned) {
- goto scan;
- }
- goto unknown;
+static Tcl_Encoding
+LoadEncodingFile(interp, name)
+ Tcl_Interp *interp; /* Interp for error reporting, if not NULL. */
+ CONST char *name; /* The name of the encoding file on disk
+ * and also the name for new encoding. */
+{
+ Tcl_Channel chan = NULL;
+ Tcl_Encoding encoding = NULL;
+ int ch;
+
+ chan = OpenEncodingFileChannel(interp, name);
+ if (chan == NULL) {
+ return NULL;
}
Tcl_SetChannelOption(NULL, chan, "-encoding", "utf-8");
@@ -1472,7 +1514,6 @@ scan:
}
}
- encoding = NULL;
switch (ch) {
case 'S': {
encoding = LoadTableEncoding(name, ENCODING_SINGLEBYTE, chan);
@@ -1496,12 +1537,6 @@ scan:
}
Tcl_Close(NULL, chan);
return encoding;
-
- unknown:
- if (interp != NULL) {
- Tcl_AppendResult(interp, "unknown encoding \"", name, "\"", NULL);
- }
- return NULL;
}
/*
@@ -3185,43 +3220,3 @@ InitializeEncodingSearchPath(valuePtr, lengthPtr, encodingPtr)
memcpy((VOID *) *valuePtr, (VOID *) bytes, (size_t) numBytes + 1);
Tcl_DecrRefCount(searchPath);
}
-
-/*
- *-------------------------------------------------------------------------
- *
- * InitializeEncodingFileMap --
- *
- * This is the fallback routine that fills the encoding data
- * file map if the application has not set up an encoding
- * search path by the first time the file map is needed to
- * load encoding data.
- *
- * Results:
- * None.
- *
- * Side effects:
- * Fills the encoding data file map.
- *
- *-------------------------------------------------------------------------
- */
-
-void
-InitializeEncodingFileMap(valuePtr, lengthPtr, encodingPtr)
- char **valuePtr;
- int *lengthPtr;
- Tcl_Encoding *encodingPtr;
-{
- char *bytes;
- int numBytes;
- Tcl_Obj *map = MakeFileMap();
-
- *encodingPtr = encodingSearchPath.encoding;
- if (*encodingPtr) {
- ((Encoding *)(*encodingPtr))->refCount++;
- }
- bytes = Tcl_GetStringFromObj(map, &numBytes);
- *lengthPtr = numBytes;
- *valuePtr = ckalloc((unsigned int) numBytes + 1);
- memcpy((VOID *) *valuePtr, (VOID *) bytes, (size_t) numBytes + 1);
- Tcl_DecrRefCount(map);
-}
diff --git a/generic/tclExecute.c b/generic/tclExecute.c
index 75df800..a6d9442 100644
--- a/generic/tclExecute.c
+++ b/generic/tclExecute.c
@@ -11,7 +11,7 @@
* See the file "license.terms" for information on usage and redistribution
* of this file, and for a DISCLAIMER OF ALL WARRANTIES.
*
- * RCS: @(#) $Id: tclExecute.c,v 1.167.2.10 2005/04/10 23:14:48 kennykb Exp $
+ * RCS: @(#) $Id: tclExecute.c,v 1.167.2.11 2005/04/25 21:37:20 kennykb Exp $
*/
#include "tclInt.h"
@@ -4289,7 +4289,7 @@ TclExecuteByteCode(interp, codePtr)
*/
if ((tPtr == &tclIntType) || (tPtr == &tclBooleanType)) {
i = valuePtr->internalRep.longValue;
- TclNewLongObj(objResultPtr, -i)
+ TclNewLongObj(objResultPtr, -i);
TRACE_WITH_OBJ(("%ld => ", i), objResultPtr);
} else if (tPtr == &tclWideIntType) {
TclGetWide(w,valuePtr);
@@ -4329,7 +4329,7 @@ TclExecuteByteCode(interp, codePtr)
i = (w == W0);
TRACE_WITH_OBJ((LLD" => ", w), objResultPtr);
} else {
- i = (valuePtr->internalRep.doubleValue == 0.0)
+ i = (valuePtr->internalRep.doubleValue == 0.0);
TRACE_WITH_OBJ(("%.6g => ", d), objResultPtr);
}
objResultPtr = eePtr->constants[i];
@@ -4639,7 +4639,10 @@ TclExecuteByteCode(interp, codePtr)
* If some var in some var list still has a remaining list
* element iterate one more time. Assign to var the next
* element from its value list. We already checked above
- * that each list temp holds a valid list object.
+ * that each list temp holds a valid list object (by calling
+ * Tcl_ListObjLength), but cannot rely on that check remaining
+ * valid: one list could have been shimmered as a side effect of
+ * setting a traced variable.
*/
if (continueLoop) {
@@ -4650,7 +4653,7 @@ TclExecuteByteCode(interp, codePtr)
listVarPtr = &(compiledLocals[listTmpIndex]);
listPtr = listVarPtr->value.objPtr;
- TclListObjGetElements(listPtr, listLen, elements);
+ Tcl_ListObjGetElements(interp, listPtr, &listLen, &elements);
valIndex = (iterNum * numVars);
for (j = 0; j < numVars; j++) {
diff --git a/generic/tclFileName.c b/generic/tclFileName.c
index ab06aee..a5eca37 100644
--- a/generic/tclFileName.c
+++ b/generic/tclFileName.c
@@ -10,7 +10,7 @@
* See the file "license.terms" for information on usage and redistribution
* of this file, and for a DISCLAIMER OF ALL WARRANTIES.
*
- * RCS: @(#) $Id: tclFileName.c,v 1.60.2.5 2005/04/10 23:14:50 kennykb Exp $
+ * RCS: @(#) $Id: tclFileName.c,v 1.60.2.6 2005/04/25 21:37:20 kennykb Exp $
*/
#include "tclInt.h"
@@ -2302,7 +2302,7 @@ DoGlob(interp, matchesObj, separators, pathPtr, flags, pattern, types)
* The current prefix must end in a separator, unless
* this is a volume-relative path. In particular
* globbing in Windows shares, when not using -dir
- * or -path, e.g. 'glob [file join //machine share dir *]'
+ * or -path, e.g. 'glob [file join //machine/share/subdir *]'
* requires adding a separator here. This behaviour
* is not currently tested for in the test suite.
*/
diff --git a/generic/tclGet.c b/generic/tclGet.c
index b410ba1..0be4b7e 100644
--- a/generic/tclGet.c
+++ b/generic/tclGet.c
@@ -11,11 +11,10 @@
* See the file "license.terms" for information on usage and redistribution
* of this file, and for a DISCLAIMER OF ALL WARRANTIES.
*
- * RCS: @(#) $Id: tclGet.c,v 1.9.2.2 2005/03/04 20:43:46 kennykb Exp $
+ * RCS: @(#) $Id: tclGet.c,v 1.9.2.3 2005/04/25 21:37:20 kennykb Exp $
*/
#include "tclInt.h"
-#include <math.h>
/*
@@ -38,76 +37,25 @@
*/
int
-Tcl_GetInt(interp, string, intPtr)
+Tcl_GetInt(interp, str, intPtr)
Tcl_Interp *interp; /* Interpreter to use for error reporting. */
- CONST char *string; /* String containing a (possibly signed)
- * integer in a form acceptable to strtol. */
+ CONST char *str; /* String containing a (possibly signed)
+ * integer in a form acceptable to strtoul. */
int *intPtr; /* Place to store converted result. */
{
- char *end;
- CONST char *p = string;
- long i;
-
- /*
- * Note: use strtoul instead of strtol for integer conversions
- * to allow full-size unsigned numbers, but don't depend on strtoul
- * to handle sign characters; it won't in some implementations.
- */
-
- errno = 0;
-#ifdef TCL_STRTOUL_SIGN_CHECK
- /*
- * This special sign check actually causes bad numbers to be allowed
- * when strtoul. I can't find a strtoul that doesn't validly handle
- * signed characters, and the C standard implies that this is all
- * unnecessary. [Bug #634856]
- */
- for ( ; isspace(UCHAR(*p)); p++) { /* INTL: ISO space. */
- /* Empty loop body. */
- }
- if (*p == '-') {
- p++;
- i = -((long)strtoul(p, &end, 0)); /* INTL: Tcl source. */
- } else if (*p == '+') {
- p++;
- i = strtoul(p, &end, 0); /* INTL: Tcl source. */
- } else
-#else
- i = strtoul(p, &end, 0); /* INTL: Tcl source. */
-#endif
- if (end == p) {
- badInteger:
- if (interp != (Tcl_Interp *) NULL) {
- Tcl_AppendResult(interp, "expected integer but got \"", string,
- "\"", (char *) NULL);
- TclCheckBadOctal(interp, string);
- }
- return TCL_ERROR;
- }
-
- /*
- * The second test below is needed on platforms where "long" is
- * larger than "int" to detect values that fit in a long but not in
- * an int.
- */
-
- if ((errno == ERANGE) || (((long)(int) i) != i)) {
- if (interp != (Tcl_Interp *) NULL) {
- Tcl_SetResult(interp, "integer value too large to represent",
- TCL_STATIC);
- Tcl_SetErrorCode(interp, "ARITH", "IOVERFLOW",
- Tcl_GetStringResult(interp), (char *) NULL);
- }
- return TCL_ERROR;
- }
- while ((*end != '\0') && isspace(UCHAR(*end))) { /* INTL: ISO space. */
- end++;
- }
- if (*end != 0) {
- goto badInteger;
+ Tcl_Obj obj;
+ int code;
+
+ obj.refCount = 1;
+ obj.bytes = (char *) str;
+ obj.length = strlen(str);
+ obj.typePtr = NULL;
+
+ code = Tcl_GetIntFromObj(interp, &obj, intPtr);
+ if (obj.refCount > 1) {
+ Tcl_Panic("invalid sharing of Tcl_Obj on C stack");
}
- *intPtr = (int) i;
- return TCL_OK;
+ return code;
}
/*
@@ -133,64 +81,27 @@ Tcl_GetInt(interp, string, intPtr)
*/
int
-TclGetLong(interp, string, longPtr)
+TclGetLong(interp, str, longPtr)
Tcl_Interp *interp; /* Interpreter used for error reporting
* if not NULL. */
- CONST char *string; /* String containing a (possibly signed)
+ CONST char *str; /* String containing a (possibly signed)
* long integer in a form acceptable to
* strtoul. */
long *longPtr; /* Place to store converted long result. */
{
- char *end;
- CONST char *p = string;
- long i;
+ Tcl_Obj obj;
+ int code;
- /*
- * Note: don't depend on strtoul to handle sign characters; it won't
- * in some implementations.
- */
+ obj.refCount = 1;
+ obj.bytes = (char *) str;
+ obj.length = strlen(str);
+ obj.typePtr = NULL;
- errno = 0;
-#ifdef TCL_STRTOUL_SIGN_CHECK
- for ( ; isspace(UCHAR(*p)); p++) { /* INTL: ISO space. */
- /* Empty loop body. */
+ code = Tcl_GetLongFromObj(interp, &obj, longPtr);
+ if (obj.refCount > 1) {
+ Tcl_Panic("invalid sharing of Tcl_Obj on C stack");
}
- if (*p == '-') {
- p++;
- i = -(int)strtoul(p, &end, 0); /* INTL: Tcl source. */
- } else if (*p == '+') {
- p++;
- i = strtoul(p, &end, 0); /* INTL: Tcl source. */
- } else
-#else
- i = strtoul(p, &end, 0); /* INTL: Tcl source. */
-#endif
- if (end == p) {
- badInteger:
- if (interp != (Tcl_Interp *) NULL) {
- Tcl_AppendResult(interp, "expected integer but got \"", string,
- "\"", (char *) NULL);
- TclCheckBadOctal(interp, string);
- }
- return TCL_ERROR;
- }
- if (errno == ERANGE) {
- if (interp != (Tcl_Interp *) NULL) {
- Tcl_SetResult(interp, "integer value too large to represent",
- TCL_STATIC);
- Tcl_SetErrorCode(interp, "ARITH", "IOVERFLOW",
- Tcl_GetStringResult(interp), (char *) NULL);
- }
- return TCL_ERROR;
- }
- while ((*end != '\0') && isspace(UCHAR(*end))) { /* INTL: ISO space. */
- end++;
- }
- if (*end != 0) {
- goto badInteger;
- }
- *longPtr = i;
- return TCL_OK;
+ return code;
}
/*
@@ -214,34 +125,25 @@ TclGetLong(interp, string, longPtr)
*/
int
-Tcl_GetDouble(interp, string, doublePtr)
+Tcl_GetDouble(interp, str, doublePtr)
Tcl_Interp *interp; /* Interpreter used for error reporting. */
- CONST char *string; /* String containing a floating-point number
+ CONST char *str; /* String containing a floating-point number
* in a form acceptable to strtod. */
double *doublePtr; /* Place to store converted result. */
{
- CONST char *end;
- double d;
+ Tcl_Obj obj;
+ int code;
- errno = 0;
- d = TclStrToD(string, &end); /* INTL: Tcl source. */
- if (end == string) {
- badDouble:
- if (interp != (Tcl_Interp *) NULL) {
- Tcl_AppendResult(interp,
- "expected floating-point number but got \"",
- string, "\"", (char *) NULL);
- }
- return TCL_ERROR;
- }
- while ((*end != 0) && isspace(UCHAR(*end))) { /* INTL: ISO space. */
- end++;
- }
- if (*end != 0) {
- goto badDouble;
+ obj.refCount = 1;
+ obj.bytes = (char *) str;
+ obj.length = strlen(str);
+ obj.typePtr = NULL;
+
+ code = Tcl_GetDoubleFromObj(interp, &obj, doublePtr);
+ if (obj.refCount > 1) {
+ Tcl_Panic("invalid sharing of Tcl_Obj on C stack");
}
- *doublePtr = d;
- return TCL_OK;
+ return code;
}
/*
@@ -265,64 +167,28 @@ Tcl_GetDouble(interp, string, doublePtr)
*/
int
-Tcl_GetBoolean(interp, string, boolPtr)
+Tcl_GetBoolean(interp, str, boolPtr)
Tcl_Interp *interp; /* Interpreter used for error reporting. */
- CONST char *string; /* String containing a boolean number
+ CONST char *str; /* String containing a boolean number
* specified either as 1/0 or true/false or
* yes/no. */
int *boolPtr; /* Place to store converted result, which
* will be 0 or 1. */
{
- int i;
- char lowerCase[10], c;
- size_t length;
+ Tcl_Obj obj;
+ int code;
- /*
- * Convert the input string to all lower-case.
- * INTL: This code will work on UTF strings.
- */
+ obj.refCount = 1;
+ obj.bytes = (char *) str;
+ obj.length = strlen(str);
+ obj.typePtr = NULL;
- for (i = 0; i < 9; i++) {
- c = string[i];
- if (c == 0) {
- break;
- }
- if ((c >= 'A') && (c <= 'Z')) {
- c += (char) ('a' - 'A');
- }
- lowerCase[i] = c;
+ code = Tcl_ConvertToType(interp, &obj, &tclBooleanType);
+ if (obj.refCount > 1) {
+ Tcl_Panic("invalid sharing of Tcl_Obj on C stack");
}
- lowerCase[i] = 0;
-
- length = strlen(lowerCase);
- c = lowerCase[0];
- if ((c == '0') && (lowerCase[1] == '\0')) {
- *boolPtr = 0;
- } else if ((c == '1') && (lowerCase[1] == '\0')) {
- *boolPtr = 1;
- } else if ((c == 'y') && (strncmp(lowerCase, "yes", length) == 0)) {
- *boolPtr = 1;
- } else if ((c == 'n') && (strncmp(lowerCase, "no", length) == 0)) {
- *boolPtr = 0;
- } else if ((c == 't') && (strncmp(lowerCase, "true", length) == 0)) {
- *boolPtr = 1;
- } else if ((c == 'f') && (strncmp(lowerCase, "false", length) == 0)) {
- *boolPtr = 0;
- } else if ((c == 'o') && (length >= 2)) {
- if (strncmp(lowerCase, "on", length) == 0) {
- *boolPtr = 1;
- } else if (strncmp(lowerCase, "off", length) == 0) {
- *boolPtr = 0;
- } else {
- goto badBoolean;
- }
- } else {
- badBoolean:
- if (interp != (Tcl_Interp *) NULL) {
- Tcl_AppendResult(interp, "expected boolean value but got \"",
- string, "\"", (char *) NULL);
- }
- return TCL_ERROR;
+ if (code == TCL_OK) {
+ *boolPtr = obj.internalRep.longValue;
}
- return TCL_OK;
+ return code;
}
diff --git a/generic/tclIO.c b/generic/tclIO.c
index 8b0636c..b1a0ed7 100644
--- a/generic/tclIO.c
+++ b/generic/tclIO.c
@@ -10,7 +10,7 @@
* See the file "license.terms" for information on usage and redistribution
* of this file, and for a DISCLAIMER OF ALL WARRANTIES.
*
- * RCS: @(#) $Id: tclIO.c,v 1.81.2.2 2005/04/10 23:14:51 kennykb Exp $
+ * RCS: @(#) $Id: tclIO.c,v 1.81.2.3 2005/04/25 21:37:20 kennykb Exp $
*/
#include "tclInt.h"
@@ -6045,7 +6045,7 @@ Tcl_ChannelBuffered(chan)
* Tcl_SetChannelBufferSize --
*
* Sets the size of buffers to allocate to store input or output
- * in the channel. The size must be between 10 bytes and 1 MByte.
+ * in the channel. The size must be between 1 byte and 1 MByte.
*
* Results:
* None.
@@ -6065,11 +6065,11 @@ Tcl_SetChannelBufferSize(chan, sz)
ChannelState *statePtr; /* State of real channel structure. */
/*
- * If the buffer size is smaller than 10 bytes or larger than one MByte,
+ * If the buffer size is smaller than 1 byte or larger than one MByte,
* do not accept the requested size and leave the current buffer size.
*/
- if (sz < 10) {
+ if (sz < 1) {
return;
}
if (sz > (1024 * 1024)) {
diff --git a/generic/tclIOUtil.c b/generic/tclIOUtil.c
index 08224de..5e7863f 100644
--- a/generic/tclIOUtil.c
+++ b/generic/tclIOUtil.c
@@ -17,7 +17,7 @@
* See the file "license.terms" for information on usage and redistribution
* of this file, and for a DISCLAIMER OF ALL WARRANTIES.
*
- * RCS: @(#) $Id: tclIOUtil.c,v 1.113.2.1 2005/01/20 14:53:39 kennykb Exp $
+ * RCS: @(#) $Id: tclIOUtil.c,v 1.113.2.2 2005/04/25 21:37:21 kennykb Exp $
*/
#include "tclInt.h"
@@ -2986,7 +2986,8 @@ TclLoadFile(interp, pathPtr, symc, symbols, procPtrs,
}
/* Copy this across, since both are equal for the native fs */
*clientDataPtr = (ClientData)*handlePtr;
- return retVal;
+ Tcl_ResetResult(interp);
+ return TCL_OK;
}
if (Tcl_GetErrno() != EXDEV) {
return retVal;
@@ -3011,7 +3012,9 @@ TclLoadFile(interp, pathPtr, symc, symbols, procPtrs,
*/
copyToPtr = TclpTempFileName();
if (copyToPtr == NULL) {
- return -1;
+ Tcl_AppendResult(interp, "couldn't create temporary file: ",
+ Tcl_PosixError(interp), (char *) NULL);
+ return TCL_ERROR;
}
Tcl_IncrRefCount(copyToPtr);
@@ -3025,7 +3028,9 @@ TclLoadFile(interp, pathPtr, symc, symbols, procPtrs,
*/
Tcl_FSDeleteFile(copyToPtr);
Tcl_DecrRefCount(copyToPtr);
- return -1;
+ Tcl_AppendResult(interp, "couldn't load from current filesystem",
+ (char *) NULL);
+ return TCL_ERROR;
}
if (TclCrossFilesystemCopy(interp, pathPtr, copyToPtr) == TCL_OK) {
@@ -3090,6 +3095,7 @@ TclLoadFile(interp, pathPtr, symc, symbols, procPtrs,
(*handlePtr) = newLoadHandle;
(*clientDataPtr) = newClientData;
(*unloadProcPtr) = newUnloadProcPtr;
+ Tcl_ResetResult(interp);
return TCL_OK;
}
/*
@@ -3138,6 +3144,7 @@ TclLoadFile(interp, pathPtr, symc, symbols, procPtrs,
(*handlePtr) = newLoadHandle;
(*clientDataPtr) = (ClientData)tvdlPtr;
(*unloadProcPtr) = &FSUnloadTempFile;
+ Tcl_ResetResult(interp);
return retVal;
} else {
/* Cross-platform copy failed */
@@ -3147,7 +3154,7 @@ TclLoadFile(interp, pathPtr, symc, symbols, procPtrs,
}
}
Tcl_SetErrno(ENOENT);
- return -1;
+ return TCL_ERROR;
}
/*
* This function used to be in the platform specific directories, but it
diff --git a/generic/tclInt.h b/generic/tclInt.h
index c6b7a1b..04b80ec 100644
--- a/generic/tclInt.h
+++ b/generic/tclInt.h
@@ -12,7 +12,7 @@
* See the file "license.terms" for information on usage and redistribution
* of this file, and for a DISCLAIMER OF ALL WARRANTIES.
*
- * RCS: @(#) $Id: tclInt.h,v 1.202.2.10 2005/04/10 23:14:52 kennykb Exp $
+ * RCS: @(#) $Id: tclInt.h,v 1.202.2.11 2005/04/25 21:37:22 kennykb Exp $
*/
#ifndef _TCLINT
@@ -2143,6 +2143,9 @@ MODULE_SCOPE int Tcl_DictObjCmd _ANSI_ARGS_((ClientData clientData,
MODULE_SCOPE int Tcl_EncodingObjCmd _ANSI_ARGS_((ClientData clientData,
Tcl_Interp *interp, int objc,
Tcl_Obj *CONST objv[]));
+MODULE_SCOPE int TclEncodingDirsObjCmd _ANSI_ARGS_((
+ ClientData clientData, Tcl_Interp *interp,
+ int objc, Tcl_Obj *CONST objv[]));
MODULE_SCOPE int Tcl_EofObjCmd _ANSI_ARGS_((ClientData clientData,
Tcl_Interp *interp, int objc,
Tcl_Obj *CONST objv[]));
@@ -2504,10 +2507,12 @@ MODULE_SCOPE Tcl_Obj * TclPtrIncrWideVar _ANSI_ARGS_((Tcl_Interp *interp,
MODULE_SCOPE Tcl_Obj * TclThreadAllocObj _ANSI_ARGS_((void));
MODULE_SCOPE void TclThreadFreeObj _ANSI_ARGS_((Tcl_Obj *));
MODULE_SCOPE Tcl_Mutex *TclpNewAllocMutex _ANSI_ARGS_((void));
+MODULE_SCOPE void TclFreeAllocCache _ANSI_ARGS_((void *));
MODULE_SCOPE void * TclpGetAllocCache _ANSI_ARGS_((void));
MODULE_SCOPE void TclpSetAllocCache _ANSI_ARGS_((void *));
MODULE_SCOPE void TclFinalizeThreadAlloc _ANSI_ARGS_((void));
MODULE_SCOPE void TclpFreeAllocMutex _ANSI_ARGS_((Tcl_Mutex* mutex));
+MODULE_SCOPE void TclpFreeAllocCache _ANSI_ARGS_((void *));
# define TclAllocObjStorage(objPtr) \
(objPtr) = TclThreadAllocObj()
diff --git a/generic/tclInterp.c b/generic/tclInterp.c
index b21af73..ec78d95 100644
--- a/generic/tclInterp.c
+++ b/generic/tclInterp.c
@@ -10,7 +10,7 @@
* See the file "license.terms" for information on usage and redistribution
* of this file, and for a DISCLAIMER OF ALL WARRANTIES.
*
- * RCS: @(#) $Id: tclInterp.c,v 1.54.2.1 2004/12/29 22:47:00 kennykb Exp $
+ * RCS: @(#) $Id: tclInterp.c,v 1.54.2.2 2005/04/25 21:37:22 kennykb Exp $
*/
#include "tclInt.h"
@@ -298,10 +298,6 @@ int
Tcl_Init(interp)
Tcl_Interp *interp; /* Interpreter to initialize. */
{
- int code;
- Tcl_DString script, encodingName;
- Tcl_Obj *path;
-
if (tclPreInitScript != NULL) {
if (Tcl_Eval(interp, tclPreInitScript) == TCL_ERROR) {
return (TCL_ERROR);
@@ -347,133 +343,69 @@ Tcl_Init(interp)
* Note that this entire search mechanism can be bypassed by defining an
* alternate tclInit procedure before calling Tcl_Init().
*/
- code = Tcl_Eval(interp,
+ return Tcl_Eval(interp,
"if {[info proc tclInit]==\"\"} {\n"
" proc tclInit {} {\n"
-" global tcl_libPath tcl_library\n"
-" global env tclDefaultLibrary\n"
-" variable ::tcl::LibPath\n"
+" global tcl_libPath tcl_library env tclDefaultLibrary\n"
" rename tclInit {}\n"
-" set errors {}\n"
-" set localPath {}\n"
-" set LibPath {}\n"
" if {[info exists tcl_library]} {\n"
-" lappend localPath $tcl_library\n"
+" set scripts {{set tcl_library}}\n"
" } else {\n"
-" if {[info exists env(TCL_LIBRARY)]\n"
-" && [string length $env(TCL_LIBRARY)]} {\n"
-" lappend localPath $env(TCL_LIBRARY)\n"
-" lappend LibPath $env(TCL_LIBRARY)\n"
-" if {[regexp ^tcl(.*)$ [file tail $env(TCL_LIBRARY)] -> tail]} {\n"
-" if {$tail ne [info tclversion]} {\n"
-" lappend localPath [file join [file dirname\\\n"
-" $env(TCL_LIBRARY)] tcl[info tclversion]]\n"
-" lappend LibPath [file join [file dirname\\\n"
-" $env(TCL_LIBRARY)] tcl[info tclversion]]\n"
-" }\n"
-" }\n"
+" set scripts {}\n"
+" if {[info exists env(TCL_LIBRARY)] && ($env(TCL_LIBRARY) ne {})} {\n"
+" lappend scripts {set env(TCL_LIBRARY)}\n"
+" lappend scripts {\n"
+"if {[regexp ^tcl(.*)$ [file tail $env(TCL_LIBRARY)] -> tail] == 0} continue\n"
+"if {$tail eq [info tclversion]} continue\n"
+"file join [file dirname $env(TCL_LIBRARY)] tcl[info tclversion]}\n"
" }\n"
-" if {[catch {\n"
-" lappend localPath $tclDefaultLibrary\n"
-" unset tclDefaultLibrary\n"
-" }]} {\n"
-" lappend localPath [::tcl::pkgconfig get scriptdir,runtime]\n"
+" if {[info exists tclDefaultLibrary]} {\n"
+" lappend scripts {set tclDefaultLibrary}\n"
+" } else {\n"
+" lappend scripts {::tcl::pkgconfig get scriptdir,runtime}\n"
" }\n"
-" set parentDir [file normalize [file dirname [file dirname\\\n"
-" [info nameofexecutable]]]]\n"
-" set grandParentDir [file dirname $parentDir]\n"
-" lappend LibPath [file join $parentDir lib tcl[info tclversion]]\n"
-" lappend LibPath [file join $grandParentDir lib tcl[info tclversion]]\n"
-" lappend LibPath [file join $parentDir library]\n"
-" lappend LibPath [file join $grandParentDir library]\n"
-" lappend LibPath [file join $grandParentDir\\\n"
-" tcl[info patchlevel] library]\n"
-" lappend LibPath [file join [file dirname $grandParentDir]\\\n"
-" tcl[info patchlevel] library]\n"
-" catch {\n"
-" set LibPath [concat $LibPath $tcl_libPath]\n"
+" lappend scripts {\n"
+"set parentDir [file dirname [file dirname [info nameofexecutable]]]\n"
+"set grandParentDir [file dirname $parentDir]\n"
+"file join $parentDir lib tcl[info tclversion]} \\\n"
+" {file join $grandParentDir lib tcl[info tclversion]} \\\n"
+" {file join $parentDir library} \\\n"
+" {file join $grandParentDir library} \\\n"
+" {file join $grandParentDir tcl[info patchlevel] library} \\\n"
+" {\n"
+"file join [file dirname $grandParentDir] tcl[info patchlevel] library}\n"
+" if {[info exists tcl_libPath]\n"
+" && [catch {llength $tcl_libPath} len] == 0} {\n"
+" for {set i 0} {$i < $len} {incr i} {\n"
+" lappend scripts [list lindex \\$tcl_libPath $i]\n"
+" }\n"
" }\n"
" }\n"
-" foreach i [concat $localPath $LibPath] {\n"
-" set tcl_library $i\n"
-" set tclfile [file join $i init.tcl]\n"
+" set dirs {}\n"
+" set errors {}\n"
+" foreach script $scripts {\n"
+" lappend dirs [eval $script]\n"
+" set tcl_library [lindex $dirs end]\n"
+" set tclfile [file join $tcl_library init.tcl]\n"
" if {[file exists $tclfile]} {\n"
-" if {![catch {uplevel #0 [list source $tclfile]} msg opts]} {\n"
-" return\n"
-" } else {\n"
+" if {[catch {uplevel #0 [list source $tclfile]} msg opts]} {\n"
" append errors \"$tclfile: $msg\n\"\n"
" append errors \"[dict get $opts -errorinfo]\n\"\n"
+" continue\n"
" }\n"
+" unset -nocomplain tclDefaultLibrary\n"
+" return\n"
" }\n"
" }\n"
+" unset -nocomplain tclDefaultLibrary\n"
" set msg \"Can't find a usable init.tcl in the following directories: \n\"\n"
-" append msg \" $localPath $LibPath\n\n\"\n"
+" append msg \" $dirs\n\n\"\n"
" append msg \"$errors\n\n\"\n"
" append msg \"This probably means that Tcl wasn't installed properly.\n\"\n"
" error $msg\n"
" }\n"
"}\n"
"tclInit");
-
- if (code != TCL_OK) {
- return code;
- }
-
- /*
- * Now that [info library] is initialized, make sure that
- * [file join [info library] encoding] is on the encoding
- * search path.
- *
- * Relying on use of original built-in commands.
- * Should be a safe assumption during interp initialization.
- * More robust would be to use C-coded equivalents, but that's such
- * a pain...
- */
-
- Tcl_DStringInit(&script);
- Tcl_DStringAppend(&script, "lsearch -exact", -1);
- path = Tcl_DuplicateObj(TclGetEncodingSearchPath());
- Tcl_IncrRefCount(path);
- Tcl_DStringAppendElement(&script, Tcl_GetString(path));
- Tcl_DStringAppend(&script, " [file join [info library] encoding]", -1);
- code = Tcl_EvalEx(interp, Tcl_DStringValue(&script),
- Tcl_DStringLength(&script), TCL_EVAL_GLOBAL);
- Tcl_DStringFree(&script);
- if (code == TCL_OK) {
- int index;
- Tcl_GetIntFromObj(interp, Tcl_GetObjResult(interp), &index);
- if (index != -1) {
- /* [info library]/encoding already on the encoding search path */
- goto done;
- }
- }
- Tcl_DStringInit(&script);
- Tcl_DStringAppend(&script, "file join [info library] encoding", -1);
- code = Tcl_EvalEx(interp, Tcl_DStringValue(&script),
- Tcl_DStringLength(&script), TCL_EVAL_GLOBAL);
- Tcl_DStringFree(&script);
- if (code == TCL_OK) {
- Tcl_ListObjAppendElement(NULL, path, Tcl_GetObjResult(interp));
- TclSetEncodingSearchPath(path);
- }
-done:
- /*
- * Now that we know the distributed *.enc files are on the encoding
- * search path, check whether the [encoding system] matches that
- * specified by the environment, and if not, attempt to correct it
- */
- TclpGetEncodingNameFromEnvironment(&encodingName);
- if (strcmp(Tcl_DStringValue(&encodingName), Tcl_GetEncodingName(NULL))) {
- code = Tcl_SetSystemEncoding(NULL, Tcl_DStringValue(&encodingName));
- if (code == TCL_ERROR) {
- Tcl_Panic("system encoding \"", Tcl_DStringValue(&encodingName),
- "\" not available");
- }
- }
- Tcl_DStringFree(&encodingName);
- Tcl_DecrRefCount(path);
- Tcl_ResetResult(interp);
- return TCL_OK;
}
/*
diff --git a/generic/tclLiteral.c b/generic/tclLiteral.c
index eb0e342..9564a98 100644
--- a/generic/tclLiteral.c
+++ b/generic/tclLiteral.c
@@ -13,7 +13,7 @@
* See the file "license.terms" for information on usage and redistribution
* of this file, and for a DISCLAIMER OF ALL WARRANTIES.
*
- * RCS: @(#) $Id: tclLiteral.c,v 1.20.2.1 2004/12/29 22:47:01 kennykb Exp $
+ * RCS: @(#) $Id: tclLiteral.c,v 1.20.2.2 2005/04/25 21:37:22 kennykb Exp $
*/
#include "tclInt.h"
@@ -270,8 +270,6 @@ TclRegisterLiteral(envPtr, bytes, length, flags)
register Tcl_Obj *objPtr;
unsigned int hash;
int localHash, globalHash, objIndex;
- long n;
- char buf[TCL_INTEGER_SPACE];
Namespace *nsPtr;
if (length < 0) {
@@ -366,10 +364,13 @@ TclRegisterLiteral(envPtr, bytes, length, flags)
TclInitStringRep(objPtr, bytes, length);
}
+#if 0
if (TclLooksLikeInt(bytes, length)) {
/*
* From here we use the objPtr, because it is NULL terminated
*/
+ long n;
+ char buf[TCL_INTEGER_SPACE];
if (TclGetLong((Tcl_Interp *) NULL, objPtr->bytes, &n) == TCL_OK) {
TclFormatInt(buf, n);
if (strcmp(objPtr->bytes, buf) == 0) {
@@ -378,6 +379,7 @@ TclRegisterLiteral(envPtr, bytes, length, flags)
}
}
}
+#endif
#ifdef TCL_COMPILE_DEBUG
if (TclLookupLiteralEntry((Tcl_Interp *) iPtr, objPtr) != NULL) {
diff --git a/generic/tclObj.c b/generic/tclObj.c
index 51b84bc..1861cb3 100644
--- a/generic/tclObj.c
+++ b/generic/tclObj.c
@@ -12,7 +12,7 @@
* See the file "license.terms" for information on usage and redistribution
* of this file, and for a DISCLAIMER OF ALL WARRANTIES.
*
- * RCS: @(#) $Id: tclObj.c,v 1.72.2.10 2005/04/10 23:14:54 kennykb Exp $
+ * RCS: @(#) $Id: tclObj.c,v 1.72.2.11 2005/04/25 21:37:22 kennykb Exp $
*/
#include "tclInt.h"
@@ -1284,9 +1284,8 @@ Tcl_SetBooleanObj(objPtr, boolValue)
*
* Tcl_GetBooleanFromObj --
*
- * Attempt to return a boolean from the Tcl object "objPtr". If the
- * object is not already a boolean, an attempt will be made to convert
- * it to one.
+ * Attempt to return a boolean from the Tcl object "objPtr". This
+ * includes conversion from any of Tcl's numeric types.
*
* Results:
* The return value is a standard Tcl object result. If an error occurs
@@ -1294,8 +1293,7 @@ Tcl_SetBooleanObj(objPtr, boolValue)
* result unless "interp" is NULL.
*
* Side effects:
- * If the object is not already a boolean, the conversion will free
- * any old internal representation.
+ * The intrep of *objPtr may be changed.
*
*----------------------------------------------------------------------
*/
@@ -1306,18 +1304,54 @@ Tcl_GetBooleanFromObj(interp, objPtr, boolPtr)
register Tcl_Obj *objPtr; /* The object from which to get boolean. */
register int *boolPtr; /* Place to store resulting boolean. */
{
- register int result;
+ double d;
+ long l;
if (objPtr->typePtr == &tclBooleanType) {
- result = TCL_OK;
- } else {
- result = SetBooleanFromAny(interp, objPtr);
+ *boolPtr = (int) objPtr->internalRep.longValue;
+ return TCL_OK;
}
+ /*
+ * The following call retrieves a numeric value without shimmering
+ * away any existing numeric intrep Tcl_ObjTypes.
+ */
+ if (Tcl_GetDoubleFromObj(NULL, objPtr, &d) == TCL_OK) {
+ *boolPtr = (d != 0.0);
- if (result == TCL_OK) {
+ /* Attempt shimmer to "boolean" objType */
+ SetBooleanFromAny(NULL, objPtr);
+ return TCL_OK;
+ }
+ /*
+ * Value didn't already have a numeric intrep, but perhaps we can
+ * generate one. Try a long value first...
+ */
+ if (Tcl_GetLongFromObj(NULL, objPtr, &l) == TCL_OK) {
+ *boolPtr = (l != 0);
+ return TCL_OK;
+ }
+#ifndef TCL_WIDE_INT_IS_LONG
+ else {
+ Tcl_WideInt w;
+ /*
+ * ...then a wide. Check in that order so that we don't promote
+ * anything to wide unnecessarily.
+ */
+ if (Tcl_GetWideIntFromObj(NULL, objPtr, &w) == TCL_OK) {
+ *boolPtr = (w != 0);
+ return TCL_OK;
+ }
+ }
+#endif
+ /*
+ * Finally, check for the string values like "yes"
+ * and generate error message for non-boolean values.
+ */
+ if (SetBooleanFromAny(interp, objPtr) == TCL_OK) {
*boolPtr = (int) objPtr->internalRep.longValue;
+ return TCL_OK;
}
- return result;
+ return TCL_ERROR;
}
/*
@@ -1345,69 +1379,87 @@ SetBooleanFromAny(interp, objPtr)
Tcl_Interp *interp; /* Used for error reporting if not NULL. */
register Tcl_Obj *objPtr; /* The object to convert. */
{
- char *string, *end;
- register char c;
- char lowerCase[8];
- int newBool, length;
- register int i;
-
- /*
- * Get the string representation. Make it up-to-date if necessary.
- */
-
- string = Tcl_GetStringFromObj(objPtr, &length);
+ char *str, lowerCase[6];
+ int i, newBool, length;
/*
- * Use the obvious shortcuts for numerical values; if objPtr is not
- * of numerical type, parse its string rep.
+ * For some "pure" numeric Tcl_ObjTypes (no string rep), we can
+ * determine whether a boolean conversion is possible without
+ * generating the string rep.
*/
- if (objPtr->typePtr == &tclIntType) {
- newBool = (objPtr->internalRep.longValue != 0);
- goto goodBoolean;
- } else if (objPtr->typePtr == &tclDoubleType) {
- newBool = (objPtr->internalRep.doubleValue != 0.0);
- goto goodBoolean;
- } else if (objPtr->typePtr == &tclWideIntType) {
- newBool = (objPtr->internalRep.wideValue != 0);
- goto goodBoolean;
+ if (objPtr->bytes == NULL) {
+ if (objPtr->typePtr == &tclDoubleType) {
+ goto badBoolean;
+ }
+ if (objPtr->typePtr == &tclIntType) {
+ long l = objPtr->internalRep.longValue;
+ switch (l) {
+ case 0: case 1:
+ newBool = (int)l;
+ goto goodBoolean;
+ }
+ goto badBoolean;
+ }
+ if (objPtr->typePtr == &tclWideIntType) {
+ Tcl_WideInt w = objPtr->internalRep.wideValue;
+ switch (w) {
+ case 0: case 1:
+ newBool = (int)w;
+ goto goodBoolean;
+ }
+ goto badBoolean;
+ }
}
/*
* Parse the string as a boolean. We use an implementation here
* that doesn't report errors in interp if interp is NULL.
- *
- * First we define a macro to factor out the to-lower-case code.
- * The len parameter is the maximum number of characters to copy
- * to allow the following comparisons to proceed correctly,
- * including (properly) the trailing \0 character. This is done
- * in multiple places so the number of copying steps is minimised
- * and only performed when needed.
*/
-#define SBFA_TOLOWER(len) \
- for (i=0 ; i<(len) && i<length ; i++) { \
- c = string[i]; \
- if (c & 0x80) { \
- goto badBoolean; \
- } \
- if (Tcl_UniCharIsUpper(UCHAR(c))) { \
- c = (char) Tcl_UniCharToLower(UCHAR(c)); \
- } \
- lowerCase[i] = c; \
- } \
- lowerCase[i] = 0;
-
- switch (string[0]) {
- case 'y': case 'Y':
- /*
- * Copy the string converting its characters to lower case.
- * This also weeds out international characters so we can
- * safely operate on single bytes.
- */
+ str = Tcl_GetStringFromObj(objPtr, &length);
+ if ((length == 0) || (length > 5)) {
+ /* longest valid boolean string rep. is "false" */
+ goto badBoolean;
+ }
+
+ switch (str[0]) {
+ case '0':
+ if (length == 1) {
+ newBool = 0;
+ goto goodBoolean;
+ }
+ goto badBoolean;
+ case '1':
+ if (length == 1) {
+ newBool = 1;
+ goto goodBoolean;
+ }
+ goto badBoolean;
- SBFA_TOLOWER(4);
+ }
+
+ /*
+ * Force to lower case for case-insensitive detection.
+ * Filter out known invalid characters at the same time.
+ */
+ for (i=0; i < length; i++) {
+ char c = str[i];
+ switch (c) {
+ case 'A': case 'E': case 'F': case 'L': case 'N':
+ case 'O': case 'R': case 'S': case 'T': case 'U': case 'Y':
+ lowerCase[i] = c + (char) ('a' - 'A'); break;
+ case 'a': case 'e': case 'f': case 'l': case 'n':
+ case 'o': case 'r': case 's': case 't': case 'u': case 'y':
+ lowerCase[i] = c; break;
+ default:
+ goto badBoolean;
+ }
+ }
+ lowerCase[length] = 0;
+ switch (lowerCase[0]) {
+ case 'y':
/*
* Checking the 'y' is redundant, but makes the code clearer.
*/
@@ -1416,32 +1468,28 @@ SetBooleanFromAny(interp, objPtr)
goto goodBoolean;
}
goto badBoolean;
- case 'n': case 'N':
- SBFA_TOLOWER(3);
+ case 'n':
if (strncmp(lowerCase, "no", (size_t) length) == 0) {
newBool = 0;
goto goodBoolean;
}
goto badBoolean;
- case 't': case 'T':
- SBFA_TOLOWER(5);
+ case 't':
if (strncmp(lowerCase, "true", (size_t) length) == 0) {
newBool = 1;
goto goodBoolean;
}
goto badBoolean;
- case 'f': case 'F':
- SBFA_TOLOWER(6);
+ case 'f':
if (strncmp(lowerCase, "false", (size_t) length) == 0) {
newBool = 0;
goto goodBoolean;
}
goto badBoolean;
- case 'o': case 'O':
+ case 'o':
if (length < 2) {
goto badBoolean;
}
- SBFA_TOLOWER(4);
if (strncmp(lowerCase, "on", (size_t) length) == 0) {
newBool = 1;
goto goodBoolean;
@@ -1450,92 +1498,8 @@ SetBooleanFromAny(interp, objPtr)
goto goodBoolean;
}
goto badBoolean;
-#undef SBFA_TOLOWER
- case '0':
- if (string[1] == '\0') {
- newBool = 0;
- goto goodBoolean;
- }
- goto parseNumeric;
- case '1':
- if (string[1] == '\0') {
- newBool = 1;
- goto goodBoolean;
- }
- /* deliberate fall-through */
default:
- parseNumeric:
- {
- double dbl;
- /*
- * Boolean values can be extracted from ints or doubles.
- * Note that we don't use strtoul or strtoull here because
- * we don't care about what the value is, just whether it
- * is equal to zero or not.
- */
-#ifdef TCL_WIDE_INT_IS_LONG
- newBool = strtol(string, &end, 0);
- if (end != string) {
- /*
- * Make sure the string has no garbage after the end of
- * the int.
- */
- while ((end < (string+length))
- && isspace(UCHAR(*end))) { /* INTL: ISO only */
- end++;
- }
- if (end == (string+length)) {
- newBool = (newBool != 0);
- goto goodBoolean;
- }
- }
-#else /* !TCL_WIDE_INT_IS_LONG */
- Tcl_WideInt wide = strtoll(string, &end, 0);
- if (end != string) {
- /*
- * Make sure the string has no garbage after the end of
- * the wide int.
- */
- while ((end < (string+length))
- && isspace(UCHAR(*end))) { /* INTL: ISO only */
- end++;
- }
- if (end == (string+length)) {
- newBool = (wide != Tcl_LongAsWide(0));
- goto goodBoolean;
- }
- }
-#endif /* TCL_WIDE_INT_IS_LONG */
- /*
- * Still might be a string containing the characters
- * representing an int or double that wasn't handled
- * above. This would be a string like "27" or "1.0" that
- * is non-zero and not "1". Such a string would result in
- * the boolean value true. We try converting to double. If
- * that succeeds and the resulting double is non-zero, we
- * have a "true". Note that numbers can't have embedded
- * NULLs.
- */
-
- dbl = TclStrToD(string, (CONST char **) &end);
- if (end == string) {
- goto badBoolean;
- }
-
- /*
- * Make sure the string has no garbage after the end of
- * the double.
- */
-
- while ((end < (string+length))
- && isspace(UCHAR(*end))) { /* INTL: ISO only */
- end++;
- }
- if (end != (string+length)) {
- goto badBoolean;
- }
- newBool = (dbl != 0.0);
- }
+ goto badBoolean;
}
/*
@@ -1554,7 +1518,8 @@ SetBooleanFromAny(interp, objPtr)
if (interp != NULL) {
Tcl_Obj *msg =
Tcl_NewStringObj("expected boolean value but got \"", -1);
- TclAppendLimitedToObj(msg, string, length, 50, "");
+ str = Tcl_GetStringFromObj(objPtr, &length);
+ TclAppendLimitedToObj(msg, str, length, 50, "");
Tcl_AppendToObj(msg, "\"", -1);
Tcl_SetObjResult(interp, msg);
}
@@ -1761,21 +1726,24 @@ Tcl_GetDoubleFromObj(interp, objPtr, dblPtr)
result = TCL_OK;
} else if (objPtr->typePtr == &tclIntType) {
*dblPtr = objPtr->internalRep.longValue;
- result = TCL_OK;
- } else {
- result = SetDoubleFromAny(interp, objPtr);
- if (result == TCL_OK) {
- *dblPtr = objPtr->internalRep.doubleValue;
- }
+ return TCL_OK;
+ } else if (objPtr->typePtr == &tclWideIntType) {
+ *dblPtr = (double) objPtr->internalRep.wideValue;
+ return TCL_OK;
}
- if ( result == TCL_OK && IS_NAN( *dblPtr ) ) {
- if ( interp != NULL ) {
- Tcl_SetObjResult
- ( interp,
- Tcl_NewStringObj( "floating point value is Not a Number",
- -1 ) );
+
+ result = SetDoubleFromAny(interp, objPtr);
+ if ( result == TCL_OK ) {
+ if ( IS_NAN( *dblPtr ) ) {
+ if ( interp != NULL ) {
+ Tcl_SetObjResult
+ ( interp,
+ Tcl_NewStringObj( "floating point value is Not a Number",
+ -1 ) );
+ }
+ return TCL_ERROR;
}
- result = TCL_ERROR;
+ *dblPtr = objPtr->internalRep.doubleValue;
}
return result;
}
@@ -1847,6 +1815,13 @@ SetDoubleFromAny(interp, objPtr)
goto badDouble;
}
+ if (errno != 0) {
+ if (interp != NULL) {
+ TclExprFloatError(interp, newDouble);
+ }
+ return TCL_ERROR;
+ }
+
/*
* The conversion to double succeeded. Free the old internalRep before
* setting the new one. We do this as late as possible to allow the
@@ -2012,15 +1987,14 @@ Tcl_GetIntFromObj(interp, objPtr, intPtr)
register Tcl_Obj *objPtr; /* The object from which to get a int. */
register int *intPtr; /* Place to store resulting int. */
{
- register long l = 0;
int result;
+ Tcl_WideInt w = 0;
/* If the object isn't already an integer of any width, try to
* convert it to one.
*/
- if (objPtr->typePtr != &tclIntType
- && objPtr->typePtr != &tclWideIntType) {
+ if (objPtr->typePtr != &tclIntType && objPtr->typePtr != &tclWideIntType) {
result = SetIntOrWideFromAny(interp, objPtr);
if (result != TCL_OK) {
return result;
@@ -2029,45 +2003,26 @@ Tcl_GetIntFromObj(interp, objPtr, intPtr)
/* Object should now be either int or wide. Get its value. */
- if (objPtr->typePtr == &tclIntType) {
- l = objPtr->internalRep.longValue;
- } else if (objPtr->typePtr == &tclWideIntType) {
#ifndef TCL_WIDE_INT_IS_LONG
- /*
- * If the object is already a wide integer, don't convert it.
- * This code allows for any integer in the range -ULONG_MAX to
- * ULONG_MAX to be converted to a long, ignoring overflow.
- * The rule preserves existing semantics for conversion of
- * integers on input, but avoids inadvertent demotion of
- * wide integers to 32-bit ones in the internal rep.
- */
- Tcl_WideInt w = objPtr->internalRep.wideValue;
- if (w >= -(Tcl_WideInt)(ULONG_MAX)
- && w <= (Tcl_WideInt)(ULONG_MAX)) {
- l = Tcl_WideAsLong(w);
- } else {
- goto tooBig;
- }
-#else
- l = objPtr->internalRep.longValue;
+ if (objPtr->typePtr == &tclWideIntType) {
+ w = objPtr->internalRep.wideValue;
+ } else
#endif
- } else {
- Tcl_Panic("string->integer conversion failed to convert the obj.");
+ {
+ w = Tcl_LongAsWide(objPtr->internalRep.longValue);
}
- if (((long)((int)l)) == l) {
- *intPtr = (int)l;
- return TCL_OK;
- }
-#ifndef TCL_WIDE_INT_IS_LONG
- tooBig:
-#endif
- if (interp != NULL) {
- Tcl_SetObjResult(interp, Tcl_NewStringObj(
+ if ((LLONG_MAX > UINT_MAX)
+ && ((w > UINT_MAX) || (w < -(Tcl_WideInt)UINT_MAX))) {
+ if (interp != NULL) {
+ Tcl_SetObjResult(interp, Tcl_NewStringObj(
"integer value too large to represent as non-long integer",
-1));
+ }
+ return TCL_ERROR;
}
- return TCL_ERROR;
+ *intPtr = (int)w;
+ return TCL_OK;
}
/*
@@ -2138,7 +2093,6 @@ SetIntOrWideFromAny(interp, objPtr)
register char *p;
unsigned long newLong;
int isNegative = 0;
- int isWide = 0;
/*
* Get the string representation. Make it up-to-date if necessary.
@@ -2150,8 +2104,9 @@ SetIntOrWideFromAny(interp, objPtr)
* Now parse "objPtr"s string as an int. We use an implementation here
* that doesn't report errors in interp if interp is NULL. Note: use
* strtoul instead of strtol for integer conversions to allow full-size
- * unsigned numbers, but don't depend on strtoul to handle sign
- * characters; it won't in some implementations.
+ * unsigned numbers. We parse the leading space and sign ourselves so
+ * we can tell the difference between apparently positive and negative
+ * values.
*/
errno = 0;
@@ -2180,14 +2135,6 @@ SetIntOrWideFromAny(interp, objPtr)
if (end == p) {
goto badInteger;
}
- if (errno == ERANGE) {
- if (interp != NULL) {
- CONST char *s = "integer value too large to represent";
- Tcl_SetObjResult(interp, Tcl_NewStringObj(s, -1));
- Tcl_SetErrorCode(interp, "ARITH", "IOVERFLOW", s, (char *) NULL);
- }
- return TCL_ERROR;
- }
/*
* Make sure that the string has no garbage after the end of the int.
@@ -2201,17 +2148,14 @@ SetIntOrWideFromAny(interp, objPtr)
goto badInteger;
}
- /*
- * If the resulting integer will exceed the range of a long,
- * put it into a wide instead. (Tcl Bug #868489)
- */
-
-#ifndef TCL_WIDE_INT_IS_LONG
- if ((isNegative && newLong > (unsigned long) (LONG_MAX) + 1)
- || (!isNegative && newLong > LONG_MAX)) {
- isWide = 1;
+ if (errno == ERANGE) {
+ if (interp != NULL) {
+ CONST char *s = "integer value too large to represent";
+ Tcl_SetObjResult(interp, Tcl_NewStringObj(s, -1));
+ Tcl_SetErrorCode(interp, "ARITH", "IOVERFLOW", s, (char *) NULL);
+ }
+ return TCL_ERROR;
}
-#endif
/*
* The conversion to int succeeded. Free the old internalRep before
@@ -2221,11 +2165,20 @@ SetIntOrWideFromAny(interp, objPtr)
*/
TclFreeIntRep(objPtr);
- if (isWide) {
+#ifndef TCL_WIDE_INT_IS_LONG
+ /*
+ * If the resulting integer will exceed the range of a long,
+ * put it into a wide instead. (Tcl Bug #868489)
+ */
+
+ if ((isNegative && newLong > (unsigned long) (LONG_MAX) + 1)
+ || (!isNegative && newLong > LONG_MAX)) {
objPtr->internalRep.wideValue =
(isNegative ? -(Tcl_WideInt)newLong : (Tcl_WideInt)newLong);
objPtr->typePtr = &tclWideIntType;
- } else {
+ } else
+#endif
+ {
objPtr->internalRep.longValue =
(isNegative ? -(long)newLong : (long)newLong);
objPtr->typePtr = &tclIntType;
@@ -2528,25 +2481,11 @@ SetWideIntFromAny(interp, objPtr)
* Now parse "objPtr"s string as an int. We use an implementation here
* that doesn't report errors in interp if interp is NULL. Note: use
* strtoull instead of strtoll for integer conversions to allow full-size
- * unsigned numbers, but don't depend on strtoull to handle sign
- * characters; it won't in some implementations.
+ * unsigned numbers.
*/
errno = 0;
-#ifdef TCL_STRTOUL_SIGN_CHECK
- for (; isspace(UCHAR(*p)) ; p++) { /* INTL: ISO space. */
- /* Empty loop body. */
- }
- if (*p == '-') {
- p++;
- newWide = -((Tcl_WideInt)strtoull(p, &end, 0));
- } else if (*p == '+') {
- p++;
- newWide = strtoull(p, &end, 0);
- } else
-#else
- newWide = strtoull(p, &end, 0);
-#endif
+ newWide = strtoull(p, &end, 0);
if (end == p) {
badInteger:
if (interp != NULL) {
@@ -2559,14 +2498,6 @@ SetWideIntFromAny(interp, objPtr)
}
return TCL_ERROR;
}
- if (errno == ERANGE) {
- if (interp != NULL) {
- CONST char *s = "integer value too large to represent";
- Tcl_SetObjResult(interp, Tcl_NewStringObj(s, -1));
- Tcl_SetErrorCode(interp, "ARITH", "IOVERFLOW", s, (char *) NULL);
- }
- return TCL_ERROR;
- }
/*
* Make sure that the string has no garbage after the end of the int.
@@ -2580,6 +2511,14 @@ SetWideIntFromAny(interp, objPtr)
goto badInteger;
}
+ if (errno == ERANGE) {
+ if (interp != NULL) {
+ CONST char *s = "integer value too large to represent";
+ Tcl_SetObjResult(interp, Tcl_NewStringObj(s, -1));
+ Tcl_SetErrorCode(interp, "ARITH", "IOVERFLOW", s, (char *) NULL);
+ }
+ return TCL_ERROR;
+ }
/*
* The conversion to int succeeded. Free the old internalRep before
* setting the new one. We do this as late as possible to allow the
diff --git a/generic/tclThreadAlloc.c b/generic/tclThreadAlloc.c
index 553bd4f..813b9a7 100755
--- a/generic/tclThreadAlloc.c
+++ b/generic/tclThreadAlloc.c
@@ -11,7 +11,7 @@
* See the file "license.terms" for information on usage and redistribution
* of this file, and for a DISCLAIMER OF ALL WARRANTIES.
*
- * RCS: @(#) $Id: tclThreadAlloc.c,v 1.14 2004/07/21 01:45:44 hobbs Exp $
+ * RCS: @(#) $Id: tclThreadAlloc.c,v 1.14.2.1 2005/04/25 21:37:22 kennykb Exp $
*/
#include "tclInt.h"
@@ -988,6 +988,8 @@ TclFinalizeThreadAlloc()
TclpFreeAllocMutex(listLockPtr);
listLockPtr = NULL;
+
+ TclpFreeAllocCache(NULL);
}
#else
diff --git a/generic/tclUtil.c b/generic/tclUtil.c
index 6708699..0d538e0 100644
--- a/generic/tclUtil.c
+++ b/generic/tclUtil.c
@@ -11,7 +11,7 @@
* See the file "license.terms" for information on usage and redistribution
* of this file, and for a DISCLAIMER OF ALL WARRANTIES.
*
- * RCS: @(#) $Id: tclUtil.c,v 1.51.2.9 2005/04/10 23:14:57 kennykb Exp $
+ * RCS: @(#) $Id: tclUtil.c,v 1.51.2.10 2005/04/25 21:37:22 kennykb Exp $
*/
#include "tclInt.h"
@@ -2851,14 +2851,14 @@ TclGetProcessGlobalValue(pgvPtr)
/* If no thread has set the shared value, call the initializer */
Tcl_MutexLock(&pgvPtr->mutex);
- if (NULL == pgvPtr->value) {
- if (pgvPtr->proc) {
- pgvPtr->epoch++;
- (*(pgvPtr->proc))(&pgvPtr->value, &pgvPtr->numBytes,
- &pgvPtr->encoding);
- Tcl_CreateExitHandler(FreeProcessGlobalValue,
- (ClientData) pgvPtr);
+ if ((NULL == pgvPtr->value) && (pgvPtr->proc)) {
+ pgvPtr->epoch++;
+ (*(pgvPtr->proc))(&pgvPtr->value, &pgvPtr->numBytes,
+ &pgvPtr->encoding);
+ if (pgvPtr->value == NULL) {
+ Tcl_Panic("PGV Initializer did not initialize.");
}
+ Tcl_CreateExitHandler(FreeProcessGlobalValue, (ClientData) pgvPtr);
}
/* Store a copy of the shared value in our epoch-indexed cache */
diff --git a/generic/tclVar.c b/generic/tclVar.c
index 035de76..bac67dc 100644
--- a/generic/tclVar.c
+++ b/generic/tclVar.c
@@ -15,7 +15,7 @@
* See the file "license.terms" for information on usage and redistribution
* of this file, and for a DISCLAIMER OF ALL WARRANTIES.
*
- * RCS: @(#) $Id: tclVar.c,v 1.99.2.3 2005/04/10 23:14:57 kennykb Exp $
+ * RCS: @(#) $Id: tclVar.c,v 1.99.2.4 2005/04/25 21:37:22 kennykb Exp $
*/
#include "tclInt.h"
@@ -2917,8 +2917,8 @@ Tcl_ArrayObjCmd(dummy, interp, objc, objv)
Tcl_DecrRefCount(namePtr); /* free unneeded name obj */
return result;
}
- Tcl_SetObjResult(interp, resultPtr);
}
+ Tcl_SetObjResult(interp, resultPtr);
break;
}
case ARRAY_NEXTELEMENT: {
generated by cgit v0.12 at 2024-08-20 23:58:39 (GMT)