summaryrefslogtreecommitdiffstats
diff options
context:
space:
mode:
Diffstat
-rw-r--r--doc/Eval.32
-rw-r--r--generic/tcl.h5
-rw-r--r--generic/tclBasic.c4
-rw-r--r--generic/tclCmdMZ.c30
-rw-r--r--generic/tclCompile.h2
-rw-r--r--generic/tclDictObj.c2
-rw-r--r--generic/tclEnsemble.c2
-rw-r--r--generic/tclExecute.c4
-rw-r--r--generic/tclHistory.c5
-rw-r--r--generic/tclIO.c2
-rw-r--r--generic/tclIO.h2
-rw-r--r--generic/tclInt.h21
-rw-r--r--generic/tclLink.c197
-rw-r--r--generic/tclListObj.c16
-rw-r--r--generic/tclObj.c11
-rw-r--r--generic/tclPathObj.c2
-rw-r--r--generic/tclPkg.c22
-rw-r--r--generic/tclResult.c4
-rw-r--r--generic/tclStrToD.c27
-rw-r--r--generic/tclStringObj.c12
-rw-r--r--generic/tclUtil.c6
-rw-r--r--library/init.tcl21
-rw-r--r--library/package.tcl6
-rw-r--r--library/tclIndex132
-rw-r--r--tests/get.test8
-rw-r--r--tests/parseExpr.test5
-rw-r--r--unix/tclUnixSock.c2
27 files changed, 309 insertions, 243 deletions
diff --git a/doc/Eval.3 b/doc/Eval.3
index 8661923..191bace 100644
--- a/doc/Eval.3
+++ b/doc/Eval.3
@@ -205,7 +205,7 @@ and sets \fIinterp\fR's result to an error message indicating that
the \fBreturn\fR, \fBbreak\fR, or \fBcontinue\fR command was
invoked in an inappropriate place.
This means that top-level applications should never see a return code
-from \fBTcl_EvalObjEx\fR other then \fBTCL_OK\fR or \fBTCL_ERROR\fR.
+from \fBTcl_EvalObjEx\fR other than \fBTCL_OK\fR or \fBTCL_ERROR\fR.
.SH KEYWORDS
execute, file, global, result, script, value
diff --git a/generic/tcl.h b/generic/tcl.h
index 334fa31..e823f98 100644
--- a/generic/tcl.h
+++ b/generic/tcl.h
@@ -1147,8 +1147,13 @@ typedef struct Tcl_DString {
#define TCL_LINK_SHORT 8
#define TCL_LINK_USHORT 9
#define TCL_LINK_UINT 10
+#if defined(TCL_WIDE_INT_IS_LONG) || defined(_WIN32) || defined(__CYGWIN__)
+#define TCL_LINK_LONG ((sizeof(long) != sizeof(int)) ? TCL_LINK_WIDE_INT : TCL_LINK_INT)
+#define TCL_LINK_ULONG ((sizeof(long) != sizeof(int)) ? TCL_LINK_WIDE_UINT : TCL_LINK_UINT)
+#else
#define TCL_LINK_LONG 11
#define TCL_LINK_ULONG 12
+#endif
#define TCL_LINK_FLOAT 13
#define TCL_LINK_WIDE_UINT 14
#define TCL_LINK_READ_ONLY 0x80
diff --git a/generic/tclBasic.c b/generic/tclBasic.c
index d4a433a..8fd4370 100644
--- a/generic/tclBasic.c
+++ b/generic/tclBasic.c
@@ -4709,7 +4709,7 @@ TEOV_RunEnterTraces(
{
Interp *iPtr = (Interp *) interp;
Command *cmdPtr = *cmdPtrPtr;
- int newEpoch, cmdEpoch = cmdPtr->cmdEpoch;
+ size_t newEpoch, cmdEpoch = cmdPtr->cmdEpoch;
int length, traceCode = TCL_OK;
const char *command = TclGetStringFromObj(commandPtr, &length);
@@ -6063,7 +6063,7 @@ TclNREvalObjEx(
TclNRAddCallback(interp, TEOEx_ListCallback, listPtr, eoFramePtr,
objPtr, NULL);
- ListObjGetElements(listPtr, objc, objv);
+ TclListObjGetElements(NULL, listPtr, &objc, &objv);
return TclNREvalObjv(interp, objc, objv, flags, NULL);
}
diff --git a/generic/tclCmdMZ.c b/generic/tclCmdMZ.c
index 23e6bd1..ba1fc41 100644
--- a/generic/tclCmdMZ.c
+++ b/generic/tclCmdMZ.c
@@ -989,8 +989,11 @@ TclNRSourceObjCmd(
{
const char *encodingName = NULL;
Tcl_Obj *fileName;
+ int result;
+ void **pkgFiles = NULL;
+ void *names = NULL;
- if (objc != 2 && objc !=4) {
+ if (objc < 2 || objc > 4) {
Tcl_WrongNumArgs(interp, 1, objv, "?-encoding name? fileName");
return TCL_ERROR;
}
@@ -1008,9 +1011,30 @@ TclNRSourceObjCmd(
return TCL_ERROR;
}
encodingName = TclGetString(objv[2]);
- }
+ } else if (objc == 3) {
+ /* Handle undocumented -nopkg option. This should only be
+ * used by the internal ::tcl::Pkg::source utility function. */
+ static const char *const nopkgoptions[] = {
+ "-nopkg", NULL
+ };
+ int index;
- return TclNREvalFile(interp, fileName, encodingName);
+ if (TCL_ERROR == Tcl_GetIndexFromObj(interp, objv[1], nopkgoptions,
+ "option", TCL_EXACT, &index)) {
+ return TCL_ERROR;
+ }
+ pkgFiles = Tcl_GetAssocData(interp, "tclPkgFiles", NULL);
+ /* Make sure that during the following TclNREvalFile no filenames
+ * are recorded for inclusion in the "package files" command */
+ names = *pkgFiles;
+ *pkgFiles = NULL;
+ }
+ result = TclNREvalFile(interp, fileName, encodingName);
+ if (pkgFiles) {
+ /* restore "tclPkgFiles" assocdata to how it was. */
+ *pkgFiles = names;
+ }
+ return result;
}
/*
diff --git a/generic/tclCompile.h b/generic/tclCompile.h
index 5ef154e..5bc3e81 100644
--- a/generic/tclCompile.h
+++ b/generic/tclCompile.h
@@ -425,7 +425,7 @@ typedef struct ByteCode {
* compiled. If the code is executed if a
* different namespace, it must be
* recompiled. */
- int nsEpoch; /* Value of nsPtr->resolverEpoch when this
+ size_t nsEpoch; /* Value of nsPtr->resolverEpoch when this
* ByteCode was compiled. Used to invalidate
* code when new namespace resolution rules
* are put into effect. */
diff --git a/generic/tclDictObj.c b/generic/tclDictObj.c
index 1115999..970978f 100644
--- a/generic/tclDictObj.c
+++ b/generic/tclDictObj.c
@@ -506,7 +506,7 @@ UpdateStringOfDict(
/* Handle empty list case first, simplifies what follows */
if (numElems == 0) {
- dictPtr->bytes = tclEmptyStringRep;
+ dictPtr->bytes = &tclEmptyString;
dictPtr->length = 0;
return;
}
diff --git a/generic/tclEnsemble.c b/generic/tclEnsemble.c
index 6ada155..f3e8187 100644
--- a/generic/tclEnsemble.c
+++ b/generic/tclEnsemble.c
@@ -92,7 +92,7 @@ static const Tcl_ObjType ensembleCmdType = {
*/
typedef struct {
- int epoch; /* Used to confirm when the data in this
+ size_t epoch; /* Used to confirm when the data in this
* really structure matches up with the
* ensemble. */
Command *token; /* Reference to the command for which this
diff --git a/generic/tclExecute.c b/generic/tclExecute.c
index c0dc9c0..c244b08 100644
--- a/generic/tclExecute.c
+++ b/generic/tclExecute.c
@@ -512,7 +512,7 @@ VarHashCreateVar(
(&((objPtr)->internalRep.doubleValue)), TCL_OK) : \
((((objPtr)->typePtr == NULL) && ((objPtr)->bytes == NULL)) || \
(((objPtr)->bytes != NULL) && ((objPtr)->length == 0))) \
- ? (*(tPtr) = TCL_NUMBER_LONG),TCL_ERROR : \
+ ? TCL_ERROR : \
TclGetNumberFromObj((interp), (objPtr), (ptrPtr), (tPtr)))
#else /* !TCL_WIDE_INT_IS_LONG */
#define GetNumberFromObj(interp, objPtr, ptrPtr, tPtr) \
@@ -532,7 +532,7 @@ VarHashCreateVar(
(&((objPtr)->internalRep.doubleValue)), TCL_OK) : \
((((objPtr)->typePtr == NULL) && ((objPtr)->bytes == NULL)) || \
(((objPtr)->bytes != NULL) && ((objPtr)->length == 0))) \
- ? (*(tPtr) = TCL_NUMBER_LONG),TCL_ERROR : \
+ ? TCL_ERROR : \
TclGetNumberFromObj((interp), (objPtr), (ptrPtr), (tPtr)))
#endif /* TCL_WIDE_INT_IS_LONG */
diff --git a/generic/tclHistory.c b/generic/tclHistory.c
index b08e352..47806d4 100644
--- a/generic/tclHistory.c
+++ b/generic/tclHistory.c
@@ -62,15 +62,14 @@ Tcl_RecordAndEval(
* instead of Tcl_Eval. */
{
register Tcl_Obj *cmdPtr;
- int length = strlen(cmd);
int result;
- if (length > 0) {
+ if (cmd[0]) {
/*
* Call Tcl_RecordAndEvalObj to do the actual work.
*/
- cmdPtr = Tcl_NewStringObj(cmd, length);
+ cmdPtr = Tcl_NewStringObj(cmd, -1);
Tcl_IncrRefCount(cmdPtr);
result = Tcl_RecordAndEvalObj(interp, cmdPtr, flags);
diff --git a/generic/tclIO.c b/generic/tclIO.c
index 506e6d5..6bf8451 100644
--- a/generic/tclIO.c
+++ b/generic/tclIO.c
@@ -321,7 +321,7 @@ static int WillRead(Channel *chanPtr);
typedef struct ResolvedChanName {
ChannelState *statePtr; /* The saved lookup result */
Tcl_Interp *interp; /* The interp in which the lookup was done. */
- int epoch; /* The epoch of the channel when the lookup
+ size_t epoch; /* The epoch of the channel when the lookup
* was done. Use to verify validity. */
size_t refCount; /* Share this struct among many Tcl_Obj. */
} ResolvedChanName;
diff --git a/generic/tclIO.h b/generic/tclIO.h
index ffbfa31..07c54fa 100644
--- a/generic/tclIO.h
+++ b/generic/tclIO.h
@@ -214,7 +214,7 @@ typedef struct ChannelState {
* because it happened in the background. The
* value is the chanMg, if any. #219's
* companion to 'unreportedError'. */
- int epoch; /* Used to test validity of stored channelname
+ size_t epoch; /* Used to test validity of stored channelname
* lookup results. */
} ChannelState;
diff --git a/generic/tclInt.h b/generic/tclInt.h
index 5074378..f078d18 100644
--- a/generic/tclInt.h
+++ b/generic/tclInt.h
@@ -265,7 +265,7 @@ typedef struct Namespace {
* strings; values have type (Namespace *). If
* NULL, there are no children. */
#endif
- long nsId; /* Unique id for the namespace. */
+ size_t nsId; /* Unique id for the namespace. */
Tcl_Interp *interp; /* The interpreter containing this
* namespace. */
int flags; /* OR-ed combination of the namespace status
@@ -299,12 +299,12 @@ typedef struct Namespace {
* registered using "namespace export". */
int maxExportPatterns; /* Mumber of export patterns for which space
* is currently allocated. */
- int cmdRefEpoch; /* Incremented if a newly added command
+ size_t cmdRefEpoch; /* Incremented if a newly added command
* shadows a command for which this namespace
* has already cached a Command* pointer; this
* causes all its cached Command* pointers to
* be invalidated. */
- int resolverEpoch; /* Incremented whenever (a) the name
+ size_t resolverEpoch; /* Incremented whenever (a) the name
* resolution rules change for this namespace
* or (b) a newly added command shadows a
* command that is compiled to bytecodes. This
@@ -331,7 +331,7 @@ typedef struct Namespace {
* LookupCompiledLocal to resolve variable
* references within the namespace at compile
* time. */
- int exportLookupEpoch; /* Incremented whenever a command is added to
+ size_t exportLookupEpoch; /* Incremented whenever a command is added to
* a namespace, removed from a namespace or
* the exports of a namespace are changed.
* Allows TIP#112-driven command lists to be
@@ -432,7 +432,7 @@ typedef struct EnsembleConfig {
* if the command has been deleted (or never
* existed; the global namespace never has an
* ensemble command.) */
- int epoch; /* The epoch at which this ensemble's table of
+ size_t epoch; /* The epoch at which this ensemble's table of
* exported commands is valid. */
char **subcommandArrayPtr; /* Array of ensemble subcommand names. At all
* consistent points, this will have the same
@@ -1639,7 +1639,7 @@ typedef struct Command {
* representing a command's name in a ByteCode
* instruction sequence. This structure can be
* freed when refCount becomes zero. */
- int cmdEpoch; /* Incremented to invalidate any references
+ size_t cmdEpoch; /* Incremented to invalidate any references
* that point to this command when it is
* renamed, deleted, hidden, or exposed. */
CompileProc *compileProc; /* Procedure called to compile command. NULL
@@ -2745,7 +2745,6 @@ MODULE_SCOPE long tclObjsShared[TCL_MAX_SHARED_OBJ_STATS];
* shared by all new objects allocated by Tcl_NewObj.
*/
-MODULE_SCOPE char * tclEmptyStringRep;
MODULE_SCOPE char tclEmptyString;
/*
@@ -4066,7 +4065,7 @@ typedef const char *TclDTraceStr;
TclIncrObjsAllocated(); \
TclAllocObjStorage(objPtr); \
(objPtr)->refCount = 0; \
- (objPtr)->bytes = tclEmptyStringRep; \
+ (objPtr)->bytes = &tclEmptyString; \
(objPtr)->length = 0; \
(objPtr)->typePtr = NULL; \
TCL_DTRACE_OBJ_CREATE(objPtr)
@@ -4083,7 +4082,7 @@ typedef const char *TclDTraceStr;
if (!(objPtr)->typePtr || !(objPtr)->typePtr->freeIntRepProc) { \
TCL_DTRACE_OBJ_FREE(objPtr); \
if ((objPtr)->bytes \
- && ((objPtr)->bytes != tclEmptyStringRep)) { \
+ && ((objPtr)->bytes != &tclEmptyString)) { \
ckfree((objPtr)->bytes); \
} \
(objPtr)->length = -1; \
@@ -4244,7 +4243,7 @@ MODULE_SCOPE void TclDbInitNewObj(Tcl_Obj *objPtr, const char *file,
#define TclInitStringRep(objPtr, bytePtr, len) \
if ((len) == 0) { \
- (objPtr)->bytes = tclEmptyStringRep; \
+ (objPtr)->bytes = &tclEmptyString; \
(objPtr)->length = 0; \
} else { \
(objPtr)->bytes = (char *) ckalloc((unsigned) ((len) + 1)); \
@@ -4302,7 +4301,7 @@ MODULE_SCOPE void TclDbInitNewObj(Tcl_Obj *objPtr, const char *file,
#define TclInvalidateStringRep(objPtr) \
if ((objPtr)->bytes != NULL) { \
- if ((objPtr)->bytes != tclEmptyStringRep) { \
+ if ((objPtr)->bytes != &tclEmptyString) { \
ckfree((objPtr)->bytes); \
} \
(objPtr)->bytes = NULL; \
diff --git a/generic/tclLink.c b/generic/tclLink.c
index 88c98df..a39dfcd 100644
--- a/generic/tclLink.c
+++ b/generic/tclLink.c
@@ -36,8 +36,10 @@ typedef struct Link {
unsigned int ui;
short s;
unsigned short us;
+#if !defined(TCL_WIDE_INT_IS_LONG) && !defined(_WIN32) && !defined(__CYGWIN__)
long l;
unsigned long ul;
+#endif
Tcl_WideInt w;
Tcl_WideUInt uw;
float f;
@@ -68,6 +70,7 @@ static char * LinkTraceProc(ClientData clientData,Tcl_Interp *interp,
const char *name1, const char *name2, int flags);
static Tcl_Obj * ObjValue(Link *linkPtr);
static int GetInvalidIntFromObj(Tcl_Obj *objPtr, int *intPtr);
+static int GetInvalidWideFromObj(Tcl_Obj *objPtr, Tcl_WideInt *widePtr);
static int GetInvalidDoubleFromObj(Tcl_Obj *objPtr, double *doublePtr);
/*
@@ -128,6 +131,14 @@ Tcl_LinkVar(
Tcl_IncrRefCount(linkPtr->varName);
linkPtr->addr = addr;
linkPtr->type = type & ~TCL_LINK_READ_ONLY;
+#if !defined(TCL_NO_DEPRECATED) && (defined(TCL_WIDE_INT_IS_LONG) \
+ || defined(_WIN32) || defined(__CYGWIN__))
+ if (linkPtr->type == 11 /* legacy TCL_LINK_LONG */) {
+ linkPtr->type = TCL_LINK_LONG;
+ } else if (linkPtr->type == 12 /* legacy TCL_LINK_ULONG */) {
+ linkPtr->type = TCL_LINK_ULONG;
+ }
+#endif
if (type & TCL_LINK_READ_ONLY) {
linkPtr->flags = LINK_READ_ONLY;
} else {
@@ -334,12 +345,14 @@ LinkTraceProc(
case TCL_LINK_UINT:
changed = (LinkedVar(unsigned int) != linkPtr->lastValue.ui);
break;
+#if !defined(TCL_WIDE_INT_IS_LONG) && !defined(_WIN32) && !defined(__CYGWIN__)
case TCL_LINK_LONG:
changed = (LinkedVar(long) != linkPtr->lastValue.l);
break;
case TCL_LINK_ULONG:
changed = (LinkedVar(unsigned long) != linkPtr->lastValue.ul);
break;
+#endif
case TCL_LINK_FLOAT:
changed = (LinkedVar(float) != linkPtr->lastValue.f);
break;
@@ -381,38 +394,31 @@ LinkTraceProc(
switch (linkPtr->type) {
case TCL_LINK_INT:
- if (Tcl_GetIntFromObj(NULL, valueObj, &linkPtr->lastValue.i)
- != TCL_OK) {
- if (GetInvalidIntFromObj(valueObj, &linkPtr->lastValue.i) != TCL_OK) {
- Tcl_ObjSetVar2(interp, linkPtr->varName, NULL, ObjValue(linkPtr),
+ if (Tcl_GetIntFromObj(NULL, valueObj, &linkPtr->lastValue.i) != TCL_OK
+ && GetInvalidIntFromObj(valueObj, &linkPtr->lastValue.i) != TCL_OK) {
+ Tcl_ObjSetVar2(interp, linkPtr->varName, NULL, ObjValue(linkPtr),
TCL_GLOBAL_ONLY);
- return (char *) "variable must have integer value";
- }
+ return (char *) "variable must have integer value";
}
LinkedVar(int) = linkPtr->lastValue.i;
break;
case TCL_LINK_WIDE_INT:
- if (Tcl_GetWideIntFromObj(NULL, valueObj, &linkPtr->lastValue.w)
- != TCL_OK) {
- if (GetInvalidIntFromObj(valueObj, &valueInt) != TCL_OK) {
- Tcl_ObjSetVar2(interp, linkPtr->varName, NULL, ObjValue(linkPtr),
+ if (Tcl_GetWideIntFromObj(NULL, valueObj, &linkPtr->lastValue.w) != TCL_OK
+ && GetInvalidWideFromObj(valueObj, &linkPtr->lastValue.w) != TCL_OK) {
+ Tcl_ObjSetVar2(interp, linkPtr->varName, NULL, ObjValue(linkPtr),
TCL_GLOBAL_ONLY);
- return (char *) "variable must have integer value";
- }
- linkPtr->lastValue.w = (Tcl_WideInt) valueInt;
+ return (char *) "variable must have integer value";
}
LinkedVar(Tcl_WideInt) = linkPtr->lastValue.w;
break;
case TCL_LINK_DOUBLE:
- if (Tcl_GetDoubleFromObj(NULL, valueObj, &linkPtr->lastValue.d)
- != TCL_OK) {
+ if (Tcl_GetDoubleFromObj(NULL, valueObj, &linkPtr->lastValue.d) != TCL_OK) {
#ifdef ACCEPT_NAN
if (valueObj->typePtr != &tclDoubleType) {
#endif
- if (GetInvalidDoubleFromObj(valueObj, &linkPtr->lastValue.d)
- != TCL_OK) {
+ if (GetInvalidDoubleFromObj(valueObj, &linkPtr->lastValue.d) != TCL_OK) {
Tcl_ObjSetVar2(interp, linkPtr->varName, NULL, ObjValue(linkPtr),
TCL_GLOBAL_ONLY);
return (char *) "variable must have real value";
@@ -426,8 +432,7 @@ LinkTraceProc(
break;
case TCL_LINK_BOOLEAN:
- if (Tcl_GetBooleanFromObj(NULL, valueObj, &linkPtr->lastValue.i)
- != TCL_OK) {
+ if (Tcl_GetBooleanFromObj(NULL, valueObj, &linkPtr->lastValue.i) != TCL_OK) {
Tcl_ObjSetVar2(interp, linkPtr->varName, NULL, ObjValue(linkPtr),
TCL_GLOBAL_ONLY);
return (char *) "variable must have boolean value";
@@ -436,131 +441,106 @@ LinkTraceProc(
break;
case TCL_LINK_CHAR:
- if (Tcl_GetIntFromObj(NULL, valueObj, &valueInt) != TCL_OK
+ if ((Tcl_GetIntFromObj(NULL, valueObj, &valueInt) != TCL_OK
+ && GetInvalidIntFromObj(valueObj, &valueInt) != TCL_OK)
|| valueInt < SCHAR_MIN || valueInt > SCHAR_MAX) {
- if (GetInvalidIntFromObj(valueObj, &valueInt) != TCL_OK) {
- Tcl_ObjSetVar2(interp, linkPtr->varName, NULL, ObjValue(linkPtr),
- TCL_GLOBAL_ONLY);
- return (char *) "variable must have char value";
- }
+ Tcl_ObjSetVar2(interp, linkPtr->varName, NULL, ObjValue(linkPtr),
+ TCL_GLOBAL_ONLY);
+ return (char *) "variable must have char value";
}
- linkPtr->lastValue.c = (char)valueInt;
- LinkedVar(char) = linkPtr->lastValue.c;
+ LinkedVar(char) = linkPtr->lastValue.c = (char)valueInt;
break;
case TCL_LINK_UCHAR:
- if (Tcl_GetIntFromObj(NULL, valueObj, &valueInt) != TCL_OK
+ if ((Tcl_GetIntFromObj(NULL, valueObj, &valueInt) != TCL_OK
+ && GetInvalidIntFromObj(valueObj, &valueInt) != TCL_OK)
|| valueInt < 0 || valueInt > UCHAR_MAX) {
- if (GetInvalidIntFromObj(valueObj, &valueInt) != TCL_OK) {
- Tcl_ObjSetVar2(interp, linkPtr->varName, NULL, ObjValue(linkPtr),
- TCL_GLOBAL_ONLY);
- return (char *) "variable must have unsigned char value";
- }
+ Tcl_ObjSetVar2(interp, linkPtr->varName, NULL, ObjValue(linkPtr),
+ TCL_GLOBAL_ONLY);
+ return (char *) "variable must have unsigned char value";
}
- linkPtr->lastValue.uc = (unsigned char) valueInt;
- LinkedVar(unsigned char) = linkPtr->lastValue.uc;
+ LinkedVar(unsigned char) = linkPtr->lastValue.uc = (unsigned char) valueInt;
break;
case TCL_LINK_SHORT:
- if (Tcl_GetIntFromObj(NULL, valueObj, &valueInt) != TCL_OK
+ if ((Tcl_GetIntFromObj(NULL, valueObj, &valueInt) != TCL_OK
+ && GetInvalidIntFromObj(valueObj, &valueInt) != TCL_OK)
|| valueInt < SHRT_MIN || valueInt > SHRT_MAX) {
- if (GetInvalidIntFromObj(valueObj, &valueInt) != TCL_OK) {
- Tcl_ObjSetVar2(interp, linkPtr->varName, NULL, ObjValue(linkPtr),
- TCL_GLOBAL_ONLY);
- return (char *) "variable must have short value";
- }
+ Tcl_ObjSetVar2(interp, linkPtr->varName, NULL, ObjValue(linkPtr),
+ TCL_GLOBAL_ONLY);
+ return (char *) "variable must have short value";
}
- linkPtr->lastValue.s = (short)valueInt;
- LinkedVar(short) = linkPtr->lastValue.s;
+ LinkedVar(short) = linkPtr->lastValue.s = (short)valueInt;
break;
case TCL_LINK_USHORT:
- if (Tcl_GetIntFromObj(NULL, valueObj, &valueInt) != TCL_OK
+ if ((Tcl_GetIntFromObj(NULL, valueObj, &valueInt) != TCL_OK
+ && GetInvalidIntFromObj(valueObj, &valueInt) != TCL_OK)
|| valueInt < 0 || valueInt > USHRT_MAX) {
- if (GetInvalidIntFromObj(valueObj, &valueInt) != TCL_OK) {
- Tcl_ObjSetVar2(interp, linkPtr->varName, NULL, ObjValue(linkPtr),
- TCL_GLOBAL_ONLY);
- return (char *) "variable must have unsigned short value";
- }
+ Tcl_ObjSetVar2(interp, linkPtr->varName, NULL, ObjValue(linkPtr),
+ TCL_GLOBAL_ONLY);
+ return (char *) "variable must have unsigned short value";
}
- linkPtr->lastValue.us = (unsigned short)valueInt;
- LinkedVar(unsigned short) = linkPtr->lastValue.us;
+ LinkedVar(unsigned short) = linkPtr->lastValue.us = (unsigned short)valueInt;
break;
case TCL_LINK_UINT:
- if (Tcl_GetWideIntFromObj(NULL, valueObj, &valueWide) != TCL_OK
+ if ((Tcl_GetWideIntFromObj(NULL, valueObj, &valueWide) != TCL_OK
+ && GetInvalidWideFromObj(valueObj, &valueWide) != TCL_OK)
|| valueWide < 0 || valueWide > UINT_MAX) {
- if (GetInvalidIntFromObj(valueObj, &valueInt) != TCL_OK) {
- Tcl_ObjSetVar2(interp, linkPtr->varName, NULL, ObjValue(linkPtr),
- TCL_GLOBAL_ONLY);
- return (char *) "variable must have unsigned int value";
- }
- linkPtr->lastValue.ui = (unsigned int)valueInt;
- } else {
- linkPtr->lastValue.ui = (unsigned int)valueWide;
+ Tcl_ObjSetVar2(interp, linkPtr->varName, NULL, ObjValue(linkPtr),
+ TCL_GLOBAL_ONLY);
+ return (char *) "variable must have unsigned int value";
}
- LinkedVar(unsigned int) = linkPtr->lastValue.ui;
+ LinkedVar(unsigned int) = linkPtr->lastValue.ui = (unsigned int)valueWide;
break;
+#if !defined(TCL_WIDE_INT_IS_LONG) && !defined(_WIN32) && !defined(__CYGWIN__)
case TCL_LINK_LONG:
- if (Tcl_GetWideIntFromObj(NULL, valueObj, &valueWide) != TCL_OK
+ if ((Tcl_GetWideIntFromObj(NULL, valueObj, &valueWide) != TCL_OK
+ && GetInvalidWideFromObj(valueObj, &valueWide) != TCL_OK)
|| valueWide < LONG_MIN || valueWide > LONG_MAX) {
- if (GetInvalidIntFromObj(valueObj, &valueInt) != TCL_OK) {
- Tcl_ObjSetVar2(interp, linkPtr->varName, NULL, ObjValue(linkPtr),
- TCL_GLOBAL_ONLY);
- return (char *) "variable must have long value";
- }
- linkPtr->lastValue.l = (long)valueInt;
- } else {
- linkPtr->lastValue.l = (long)valueWide;
+ Tcl_ObjSetVar2(interp, linkPtr->varName, NULL, ObjValue(linkPtr),
+ TCL_GLOBAL_ONLY);
+ return (char *) "variable must have long value";
}
- LinkedVar(long) = linkPtr->lastValue.l;
+ LinkedVar(long) = linkPtr->lastValue.l = (long)valueWide;
break;
case TCL_LINK_ULONG:
- if (Tcl_GetWideIntFromObj(NULL, valueObj, &valueWide) != TCL_OK
+ if ((Tcl_GetWideIntFromObj(NULL, valueObj, &valueWide) != TCL_OK
+ && GetInvalidWideFromObj(valueObj, &valueWide) != TCL_OK)
|| valueWide < 0 || (Tcl_WideUInt) valueWide > ULONG_MAX) {
- if (GetInvalidIntFromObj(valueObj, &valueInt) != TCL_OK) {
- Tcl_ObjSetVar2(interp, linkPtr->varName, NULL, ObjValue(linkPtr),
- TCL_GLOBAL_ONLY);
- return (char *) "variable must have unsigned long value";
- }
- linkPtr->lastValue.ul = (unsigned long)valueInt;
- } else {
- linkPtr->lastValue.ul = (unsigned long)valueWide;
+ Tcl_ObjSetVar2(interp, linkPtr->varName, NULL, ObjValue(linkPtr),
+ TCL_GLOBAL_ONLY);
+ return (char *) "variable must have unsigned long value";
}
- LinkedVar(unsigned long) = linkPtr->lastValue.ul;
+ LinkedVar(unsigned long) = linkPtr->lastValue.ul = (unsigned long)valueWide;
break;
+#endif
case TCL_LINK_WIDE_UINT:
/*
* FIXME: represent as a bignum.
*/
- if (Tcl_GetWideIntFromObj(NULL, valueObj, &valueWide) != TCL_OK) {
- if (GetInvalidIntFromObj(valueObj, &valueInt) != TCL_OK) {
- Tcl_ObjSetVar2(interp, linkPtr->varName, NULL, ObjValue(linkPtr),
- TCL_GLOBAL_ONLY);
- return (char *) "variable must have unsigned wide int value";
- }
- linkPtr->lastValue.uw = (Tcl_WideUInt)valueInt;
- } else {
- linkPtr->lastValue.uw = (Tcl_WideUInt)valueWide;
+ if (Tcl_GetWideIntFromObj(NULL, valueObj, &valueWide) != TCL_OK
+ && GetInvalidWideFromObj(valueObj, &valueWide) != TCL_OK) {
+ Tcl_ObjSetVar2(interp, linkPtr->varName, NULL, ObjValue(linkPtr),
+ TCL_GLOBAL_ONLY);
+ return (char *) "variable must have unsigned wide int value";
}
- LinkedVar(Tcl_WideUInt) = linkPtr->lastValue.uw;
+ LinkedVar(Tcl_WideUInt) = linkPtr->lastValue.uw = (Tcl_WideUInt)valueWide;
break;
case TCL_LINK_FLOAT:
- if (Tcl_GetDoubleFromObj(NULL, valueObj, &valueDouble) != TCL_OK
+ if ((Tcl_GetDoubleFromObj(NULL, valueObj, &valueDouble) != TCL_OK
+ && GetInvalidDoubleFromObj(valueObj, &valueDouble) != TCL_OK)
|| valueDouble < -FLT_MAX || valueDouble > FLT_MAX) {
- if (GetInvalidDoubleFromObj(valueObj, &valueDouble)
- != TCL_OK) {
- Tcl_ObjSetVar2(interp, linkPtr->varName, NULL, ObjValue(linkPtr),
- TCL_GLOBAL_ONLY);
- return (char *) "variable must have float value";
- }
+ Tcl_ObjSetVar2(interp, linkPtr->varName, NULL, ObjValue(linkPtr),
+ TCL_GLOBAL_ONLY);
+ return (char *) "variable must have float value";
}
- linkPtr->lastValue.f = (float)valueDouble;
- LinkedVar(float) = linkPtr->lastValue.f;
+ LinkedVar(float) = linkPtr->lastValue.f = (float)valueDouble;
break;
case TCL_LINK_STRING:
@@ -631,12 +611,14 @@ ObjValue(
case TCL_LINK_UINT:
linkPtr->lastValue.ui = LinkedVar(unsigned int);
return Tcl_NewWideIntObj((Tcl_WideInt) linkPtr->lastValue.ui);
+#if !defined(TCL_WIDE_INT_IS_LONG) && !defined(_WIN32) && !defined(__CYGWIN__)
case TCL_LINK_LONG:
linkPtr->lastValue.l = LinkedVar(long);
return Tcl_NewWideIntObj((Tcl_WideInt) linkPtr->lastValue.l);
case TCL_LINK_ULONG:
linkPtr->lastValue.ul = LinkedVar(unsigned long);
return Tcl_NewWideIntObj((Tcl_WideInt) linkPtr->lastValue.ul);
+#endif
case TCL_LINK_FLOAT:
linkPtr->lastValue.f = LinkedVar(float);
return Tcl_NewDoubleObj(linkPtr->lastValue.f);
@@ -729,6 +711,18 @@ GetInvalidIntFromObj(Tcl_Obj *objPtr, int *intPtr)
return TCL_ERROR;
}
+int
+GetInvalidWideFromObj(Tcl_Obj *objPtr, Tcl_WideInt *widePtr)
+{
+ int intValue;
+
+ if (GetInvalidIntFromObj(objPtr, &intValue) != TCL_OK) {
+ return TCL_ERROR;
+ }
+ *widePtr = intValue;
+ return TCL_OK;
+}
+
/*
* This function checks for double representations, which are valid
* when linking with C variables, but which are invalid in other
@@ -736,8 +730,7 @@ GetInvalidIntFromObj(Tcl_Obj *objPtr, int *intPtr)
* (upper- and lowercase) and sequences like "1e-". See bug [39f6304c2e].
*/
int
-GetInvalidDoubleFromObj(Tcl_Obj *objPtr,
- double *doublePtr)
+GetInvalidDoubleFromObj(Tcl_Obj *objPtr, double *doublePtr)
{
int intValue;
diff --git a/generic/tclListObj.c b/generic/tclListObj.c
index c9fd333..11374cc 100644
--- a/generic/tclListObj.c
+++ b/generic/tclListObj.c
@@ -374,7 +374,7 @@ Tcl_SetListObj(
listRepPtr = NewListIntRep(objc, objv, 1);
ListSetIntRep(objPtr, listRepPtr);
} else {
- objPtr->bytes = tclEmptyStringRep;
+ objPtr->bytes = &tclEmptyString;
objPtr->length = 0;
}
}
@@ -465,7 +465,7 @@ Tcl_ListObjGetElements(
if (listPtr->typePtr != &tclListType) {
int result;
- if (listPtr->bytes == tclEmptyStringRep) {
+ if (listPtr->bytes == &tclEmptyString) {
*objcPtr = 0;
*objvPtr = NULL;
return TCL_OK;
@@ -575,7 +575,7 @@ Tcl_ListObjAppendElement(
if (listPtr->typePtr != &tclListType) {
int result;
- if (listPtr->bytes == tclEmptyStringRep) {
+ if (listPtr->bytes == &tclEmptyString) {
Tcl_SetListObj(listPtr, 1, &objPtr);
return TCL_OK;
}
@@ -739,7 +739,7 @@ Tcl_ListObjIndex(
if (listPtr->typePtr != &tclListType) {
int result;
- if (listPtr->bytes == tclEmptyStringRep) {
+ if (listPtr->bytes == &tclEmptyString) {
*objPtrPtr = NULL;
return TCL_OK;
}
@@ -792,7 +792,7 @@ Tcl_ListObjLength(
if (listPtr->typePtr != &tclListType) {
int result;
- if (listPtr->bytes == tclEmptyStringRep) {
+ if (listPtr->bytes == &tclEmptyString) {
*intPtr = 0;
return TCL_OK;
}
@@ -863,7 +863,7 @@ Tcl_ListObjReplace(
Tcl_Panic("%s called with shared object", "Tcl_ListObjReplace");
}
if (listPtr->typePtr != &tclListType) {
- if (listPtr->bytes == tclEmptyStringRep) {
+ if (listPtr->bytes == &tclEmptyString) {
if (!objc) {
return TCL_OK;
}
@@ -1650,7 +1650,7 @@ TclListObjSetElement(
if (listPtr->typePtr != &tclListType) {
int result;
- if (listPtr->bytes == tclEmptyStringRep) {
+ if (listPtr->bytes == &tclEmptyString) {
if (interp != NULL) {
Tcl_SetObjResult(interp,
Tcl_NewStringObj("list index out of range", -1));
@@ -1979,7 +1979,7 @@ UpdateStringOfList(
*/
if (numElems == 0) {
- listPtr->bytes = tclEmptyStringRep;
+ listPtr->bytes = &tclEmptyString;
listPtr->length = 0;
return;
}
diff --git a/generic/tclObj.c b/generic/tclObj.c
index 90df579..7ec259f 100644
--- a/generic/tclObj.c
+++ b/generic/tclObj.c
@@ -49,7 +49,6 @@ Tcl_Mutex tclObjMutex;
*/
char tclEmptyString = '\0';
-char *tclEmptyStringRep = &tclEmptyString;
#if defined(TCL_MEM_DEBUG) && defined(TCL_THREADS)
/*
@@ -345,17 +344,17 @@ typedef struct ResolvedCmdName {
* reference (not the namespace that contains
* the referenced command). NULL if the name
* is fully qualified.*/
- long refNsId; /* refNsPtr's unique namespace id. Used to
+ size_t refNsId; /* refNsPtr's unique namespace id. Used to
* verify that refNsPtr is still valid (e.g.,
* it's possible that the cmd's containing
* namespace was deleted and a new one created
* at the same address). */
- int refNsCmdEpoch; /* Value of the referencing namespace's
+ size_t refNsCmdEpoch; /* Value of the referencing namespace's
* cmdRefEpoch when the pointer was cached.
* Before using the cached pointer, we check
* if the namespace's epoch was incremented;
* if so, this cached pointer is invalid. */
- int cmdEpoch; /* Value of the command's cmdEpoch when this
+ size_t cmdEpoch; /* Value of the command's cmdEpoch when this
* pointer was cached. Before using the cached
* pointer, we check if the cmd's epoch was
* incremented; if so, the cmd was renamed,
@@ -1060,7 +1059,7 @@ TclDbInitNewObj(
* debugging. */
{
objPtr->refCount = 0;
- objPtr->bytes = tclEmptyStringRep;
+ objPtr->bytes = &tclEmptyString;
objPtr->length = 0;
objPtr->typePtr = NULL;
@@ -3395,7 +3394,7 @@ GetBignumFromObj(
objPtr->internalRep.twoPtrValue.ptr2 = NULL;
objPtr->typePtr = NULL;
if (objPtr->bytes == NULL) {
- TclInitStringRep(objPtr, tclEmptyStringRep, 0);
+ TclInitStringRep(objPtr, &tclEmptyString, 0);
}
}
return TCL_OK;
diff --git a/generic/tclPathObj.c b/generic/tclPathObj.c
index 68ec2c4..0053041 100644
--- a/generic/tclPathObj.c
+++ b/generic/tclPathObj.c
@@ -2608,7 +2608,7 @@ UpdateStringOfFsPath(
pathPtr->bytes = TclGetStringFromObj(copy, &cwdLen);
pathPtr->length = cwdLen;
- copy->bytes = tclEmptyStringRep;
+ copy->bytes = &tclEmptyString;
copy->length = 0;
TclDecrRefCount(copy);
}
diff --git a/generic/tclPkg.c b/generic/tclPkg.c
index 24a67d0..ec9f3e6 100644
--- a/generic/tclPkg.c
+++ b/generic/tclPkg.c
@@ -17,6 +17,10 @@
#include "tclInt.h"
+MODULE_SCOPE char *tclEmptyStringRep;
+
+char *tclEmptyStringRep = &tclEmptyString;
+
/*
* Each invocation of the "package ifneeded" command creates a structure of
* the following type, which is used to load the package into the interpreter
@@ -28,6 +32,7 @@ typedef struct PkgAvail {
char *script; /* Script to invoke to provide this version of
* the package. Malloc'ed and protected by
* Tcl_Preserve and Tcl_Release. */
+ char *pkgIndex; /* Full file name of pkgIndex file */
struct PkgAvail *nextPtr; /* Next in list of available versions of the
* same package. */
} PkgAvail;
@@ -569,6 +574,9 @@ PkgRequireCore(
pkgName->nextPtr = pkgFiles->names;
strcpy(pkgName->name, name);
pkgFiles->names = pkgName;
+ if (bestPtr->pkgIndex) {
+ TclPkgFileSeen(interp, bestPtr->pkgIndex);
+ }
code = Tcl_EvalEx(interp, script, -1, TCL_EVAL_GLOBAL);
/* Pop the "ifneeded" package name from "tclPkgFiles" assocdata*/
pkgFiles->names = pkgName->nextPtr;
@@ -917,6 +925,9 @@ Tcl_PackageObjCmd(
pkgPtr->availPtr = availPtr->nextPtr;
Tcl_EventuallyFree(availPtr->version, TCL_DYNAMIC);
Tcl_EventuallyFree(availPtr->script, TCL_DYNAMIC);
+ if (availPtr->pkgIndex) {
+ Tcl_EventuallyFree(availPtr->pkgIndex, TCL_DYNAMIC);
+ }
ckfree(availPtr);
}
ckfree(pkgPtr);
@@ -967,6 +978,9 @@ Tcl_PackageObjCmd(
return TCL_OK;
}
Tcl_EventuallyFree(availPtr->script, TCL_DYNAMIC);
+ if (availPtr->pkgIndex) {
+ Tcl_EventuallyFree(availPtr->pkgIndex, TCL_DYNAMIC);
+ }
break;
}
}
@@ -977,6 +991,7 @@ Tcl_PackageObjCmd(
}
if (availPtr == NULL) {
availPtr = ckalloc(sizeof(PkgAvail));
+ availPtr->pkgIndex = 0;
DupBlock(availPtr->version, argv3, (unsigned) length + 1);
if (prevPtr == NULL) {
@@ -987,6 +1002,10 @@ Tcl_PackageObjCmd(
prevPtr->nextPtr = availPtr;
}
}
+ if (iPtr->scriptFile) {
+ argv4 = TclGetStringFromObj(iPtr->scriptFile, &length);
+ DupBlock(availPtr->pkgIndex, argv4, (unsigned) length + 1);
+ }
argv4 = TclGetStringFromObj(objv[4], &length);
DupBlock(availPtr->script, argv4, (unsigned) length + 1);
break;
@@ -1342,6 +1361,9 @@ TclFreePackageInfo(
pkgPtr->availPtr = availPtr->nextPtr;
Tcl_EventuallyFree(availPtr->version, TCL_DYNAMIC);
Tcl_EventuallyFree(availPtr->script, TCL_DYNAMIC);
+ if (availPtr->pkgIndex) {
+ Tcl_EventuallyFree(availPtr->pkgIndex, TCL_DYNAMIC);
+ }
ckfree(availPtr);
}
ckfree(pkgPtr);
diff --git a/generic/tclResult.c b/generic/tclResult.c
index 6346636..ddf764b 100644
--- a/generic/tclResult.c
+++ b/generic/tclResult.c
@@ -1015,11 +1015,11 @@ ResetObjResult(
Tcl_IncrRefCount(objResultPtr);
iPtr->objResultPtr = objResultPtr;
} else {
- if (objResultPtr->bytes != tclEmptyStringRep) {
+ if (objResultPtr->bytes != &tclEmptyString) {
if (objResultPtr->bytes) {
ckfree(objResultPtr->bytes);
}
- objResultPtr->bytes = tclEmptyStringRep;
+ objResultPtr->bytes = &tclEmptyString;
objResultPtr->length = 0;
}
TclFreeIntRep(objResultPtr);
diff --git a/generic/tclStrToD.c b/generic/tclStrToD.c
index 6da6df3..77e1839 100644
--- a/generic/tclStrToD.c
+++ b/generic/tclStrToD.c
@@ -18,13 +18,6 @@
#include <math.h>
/*
- * Define KILL_OCTAL to suppress interpretation of numbers with leading zero
- * as octal. (Ceterum censeo: numeros octonarios delendos esse.)
- */
-
-#undef KILL_OCTAL
-
-/*
* This code supports (at least hypothetically), IBM, Cray, VAX and IEEE-754
* floating point; of these, only IEEE-754 can represent NaN. IEEE-754 can be
* uniquely determined by radix and by the widths of significand and exponent.
@@ -546,6 +539,20 @@ TclParseNumber(
*/
if (bytes == NULL) {
+ if (endPtrPtr == NULL) {
+ if (objPtr->typePtr == &tclDictType) {
+ /* A dict can never be a (single) number */
+ return TCL_ERROR;
+ }
+ if (objPtr->typePtr == &tclListType) {
+ int length;
+ /* A list can only be a (single) number if its length == 1 */
+ TclListObjLength(NULL, objPtr, &length);
+ if (length != 1) {
+ return TCL_ERROR;
+ }
+ }
+ }
bytes = TclGetString(objPtr);
}
@@ -657,7 +664,7 @@ TclParseNumber(
state = ZERO_O;
break;
}
-#ifdef KILL_OCTAL
+#ifdef TCL_NO_DEPRECATED
goto decimal;
#endif
/* FALLTHROUGH */
@@ -740,7 +747,7 @@ TclParseNumber(
goto endgame;
}
-#ifndef KILL_OCTAL
+#ifndef TCL_NO_DEPRECATED
/*
* Scanned a number with a leading zero that contains an 8, 9,
@@ -879,7 +886,7 @@ TclParseNumber(
* digits.
*/
-#ifdef KILL_OCTAL
+#ifdef TCL_NO_DEPRECATED
decimal:
#endif
acceptState = state;
diff --git a/generic/tclStringObj.c b/generic/tclStringObj.c
index db233b3..c45baa1 100644
--- a/generic/tclStringObj.c
+++ b/generic/tclStringObj.c
@@ -136,7 +136,7 @@ GrowStringBuffer(
char *ptr = NULL;
int attempt;
- if (objPtr->bytes == tclEmptyStringRep) {
+ if (objPtr->bytes == &tclEmptyString) {
objPtr->bytes = NULL;
}
if (flag == 0 || stringPtr->allocated > 0) {
@@ -767,7 +767,7 @@ Tcl_SetObjLength(
/*
* Need to enlarge the buffer.
*/
- if (objPtr->bytes == tclEmptyStringRep) {
+ if (objPtr->bytes == &tclEmptyString) {
objPtr->bytes = ckalloc(length + 1);
} else {
objPtr->bytes = ckrealloc(objPtr->bytes, length + 1);
@@ -873,7 +873,7 @@ Tcl_AttemptSetObjLength(
char *newBytes;
- if (objPtr->bytes == tclEmptyStringRep) {
+ if (objPtr->bytes == &tclEmptyString) {
newBytes = attemptckalloc(length + 1);
} else {
newBytes = attemptckrealloc(objPtr->bytes, length + 1);
@@ -1202,7 +1202,7 @@ Tcl_AppendObjToObj(
* that appending nothing to anything leaves that starting anything...
*/
- if (appendObjPtr->bytes == tclEmptyStringRep) {
+ if (appendObjPtr->bytes == &tclEmptyString) {
return;
}
@@ -1213,7 +1213,7 @@ Tcl_AppendObjToObj(
* information; this is a special-case optimization only.
*/
- if ((TclIsPureByteArray(objPtr) || objPtr->bytes == tclEmptyStringRep)
+ if ((TclIsPureByteArray(objPtr) || objPtr->bytes == &tclEmptyString)
&& TclIsPureByteArray(appendObjPtr)) {
/*
@@ -3603,7 +3603,7 @@ UpdateStringOfString(
stringPtr->allocated = 0;
if (stringPtr->numChars == 0) {
- TclInitStringRep(objPtr, tclEmptyStringRep, 0);
+ TclInitStringRep(objPtr, &tclEmptyString, 0);
} else {
(void) ExtendStringRepWithUnicode(objPtr, stringPtr->unicode,
stringPtr->numChars);
diff --git a/generic/tclUtil.c b/generic/tclUtil.c
index ba709cc..a4d523a 100644
--- a/generic/tclUtil.c
+++ b/generic/tclUtil.c
@@ -1384,7 +1384,7 @@ TclConvertElement(
*/
if ((src == NULL) || (length == 0) || (*src == '\0' && length == -1)) {
- src = tclEmptyStringRep;
+ src = &tclEmptyString;
length = 0;
conversion = CONVERT_BRACE;
}
@@ -2954,7 +2954,7 @@ Tcl_DStringGetResult(
if (!iPtr->result[0] && iPtr->objResultPtr
&& !Tcl_IsShared(iPtr->objResultPtr)) {
- if (iPtr->objResultPtr->bytes == tclEmptyStringRep) {
+ if (iPtr->objResultPtr->bytes == &tclEmptyString) {
dsPtr->string = dsPtr->staticSpace;
dsPtr->string[0] = 0;
dsPtr->length = 0;
@@ -2964,7 +2964,7 @@ Tcl_DStringGetResult(
dsPtr->length = iPtr->objResultPtr->length;
dsPtr->spaceAvl = dsPtr->length + 1;
TclFreeIntRep(iPtr->objResultPtr);
- iPtr->objResultPtr->bytes = tclEmptyStringRep;
+ iPtr->objResultPtr->bytes = &tclEmptyString;
iPtr->objResultPtr->length = 0;
}
return;
diff --git a/library/init.tcl b/library/init.tcl
index 2378997..112bea8 100644
--- a/library/init.tcl
+++ b/library/init.tcl
@@ -45,6 +45,7 @@ if {![info exists auto_path]} {
set auto_path ""
}
}
+
namespace eval tcl {
variable Dir
foreach Dir [list $::tcl_library [file dirname $::tcl_library]] {
@@ -116,6 +117,8 @@ namespace eval tcl {
}
}
+namespace eval tcl::Pkg {}
+
# Windows specific end of initialization
if {(![interp issafe]) && ($tcl_platform(platform) eq "windows")} {
@@ -461,6 +464,22 @@ proc auto_load {cmd {namespace {}}} {
return 0
}
+# ::tcl::Pkg::source --
+# This procedure provides an alternative "source" command, which doesn't
+# register the file for the "package files" command. Safe interpreters
+# don't have to do anything special.
+#
+# Arguments:
+# filename
+
+proc ::tcl::Pkg::source {filename} {
+ if {[interp issafe]} {
+ uplevel 1 [list ::source $filename]
+ } else {
+ uplevel 1 [list ::source -nopkg $filename]
+ }
+}
+
# auto_load_index --
# Loads the contents of tclIndex files on the auto_path directory
# list. This is usually invoked within auto_load to load the index
@@ -503,7 +522,7 @@ proc auto_load_index {} {
}
set name [lindex $line 0]
set auto_index($name) \
- "source [file join $dir [lindex $line 1]]"
+ "::tcl::Pkg::source [file join $dir [lindex $line 1]]"
}
} else {
error "[file join $dir tclIndex] isn't a proper Tcl index file"
diff --git a/library/package.tcl b/library/package.tcl
index 44e3b28..c72fbfb 100644
--- a/library/package.tcl
+++ b/library/package.tcl
@@ -488,7 +488,7 @@ proc tclPkgUnknown {name args} {
set dir [file dirname $file]
if {![info exists procdDirs($dir)]} {
try {
- source $file
+ ::tcl::Pkg::source $file
} trap {POSIX EACCES} {} {
# $file was not readable; silently ignore
continue
@@ -506,7 +506,7 @@ proc tclPkgUnknown {name args} {
# safe interps usually don't have "file exists",
if {([interp issafe] || [file exists $file])} {
try {
- source $file
+ ::tcl::Pkg::source $file
} trap {POSIX EACCES} {} {
# $file was not readable; silently ignore
continue
@@ -590,7 +590,7 @@ proc tcl::MacOSXPkgUnknown {original name args} {
set dir [file dirname $file]
if {![info exists procdDirs($dir)]} {
try {
- source $file
+ ::tcl::Pkg::source $file
} trap {POSIX EACCES} {} {
# $file was not readable; silently ignore
continue
diff --git a/library/tclIndex b/library/tclIndex
index 26603c1..87a2814 100644
--- a/library/tclIndex
+++ b/library/tclIndex
@@ -7,69 +7,69 @@
# element name is the name of a command and the value is
# a script that loads the command.
-set auto_index(auto_reset) [list source [file join $dir auto.tcl]]
-set auto_index(tcl_findLibrary) [list source [file join $dir auto.tcl]]
-set auto_index(auto_mkindex) [list source [file join $dir auto.tcl]]
-set auto_index(auto_mkindex_old) [list source [file join $dir auto.tcl]]
-set auto_index(::auto_mkindex_parser::init) [list source [file join $dir auto.tcl]]
-set auto_index(::auto_mkindex_parser::cleanup) [list source [file join $dir auto.tcl]]
-set auto_index(::auto_mkindex_parser::mkindex) [list source [file join $dir auto.tcl]]
-set auto_index(::auto_mkindex_parser::hook) [list source [file join $dir auto.tcl]]
-set auto_index(::auto_mkindex_parser::slavehook) [list source [file join $dir auto.tcl]]
-set auto_index(::auto_mkindex_parser::command) [list source [file join $dir auto.tcl]]
-set auto_index(::auto_mkindex_parser::commandInit) [list source [file join $dir auto.tcl]]
-set auto_index(::auto_mkindex_parser::fullname) [list source [file join $dir auto.tcl]]
-set auto_index(history) [list source [file join $dir history.tcl]]
-set auto_index(::tcl::HistAdd) [list source [file join $dir history.tcl]]
-set auto_index(::tcl::HistKeep) [list source [file join $dir history.tcl]]
-set auto_index(::tcl::HistClear) [list source [file join $dir history.tcl]]
-set auto_index(::tcl::HistInfo) [list source [file join $dir history.tcl]]
-set auto_index(::tcl::HistRedo) [list source [file join $dir history.tcl]]
-set auto_index(::tcl::HistIndex) [list source [file join $dir history.tcl]]
-set auto_index(::tcl::HistEvent) [list source [file join $dir history.tcl]]
-set auto_index(::tcl::HistChange) [list source [file join $dir history.tcl]]
-set auto_index(pkg_mkIndex) [list source [file join $dir package.tcl]]
-set auto_index(tclPkgSetup) [list source [file join $dir package.tcl]]
-set auto_index(tclPkgUnknown) [list source [file join $dir package.tcl]]
-set auto_index(::tcl::MacOSXPkgUnknown) [list source [file join $dir package.tcl]]
-set auto_index(::pkg::create) [list source [file join $dir package.tcl]]
-set auto_index(parray) [list source [file join $dir parray.tcl]]
-set auto_index(::safe::InterpStatics) [list source [file join $dir safe.tcl]]
-set auto_index(::safe::InterpNested) [list source [file join $dir safe.tcl]]
-set auto_index(::safe::interpCreate) [list source [file join $dir safe.tcl]]
-set auto_index(::safe::interpInit) [list source [file join $dir safe.tcl]]
-set auto_index(::safe::CheckInterp) [list source [file join $dir safe.tcl]]
-set auto_index(::safe::interpConfigure) [list source [file join $dir safe.tcl]]
-set auto_index(::safe::InterpCreate) [list source [file join $dir safe.tcl]]
-set auto_index(::safe::InterpSetConfig) [list source [file join $dir safe.tcl]]
-set auto_index(::safe::interpFindInAccessPath) [list source [file join $dir safe.tcl]]
-set auto_index(::safe::interpAddToAccessPath) [list source [file join $dir safe.tcl]]
-set auto_index(::safe::InterpInit) [list source [file join $dir safe.tcl]]
-set auto_index(::safe::AddSubDirs) [list source [file join $dir safe.tcl]]
-set auto_index(::safe::interpDelete) [list source [file join $dir safe.tcl]]
-set auto_index(::safe::setLogCmd) [list source [file join $dir safe.tcl]]
-set auto_index(::safe::SyncAccessPath) [list source [file join $dir safe.tcl]]
-set auto_index(::safe::PathToken) [list source [file join $dir safe.tcl]]
-set auto_index(::safe::TranslatePath) [list source [file join $dir safe.tcl]]
-set auto_index(::safe::Log) [list source [file join $dir safe.tcl]]
-set auto_index(::safe::CheckFileName) [list source [file join $dir safe.tcl]]
-set auto_index(::safe::AliasGlob) [list source [file join $dir safe.tcl]]
-set auto_index(::safe::AliasSource) [list source [file join $dir safe.tcl]]
-set auto_index(::safe::AliasLoad) [list source [file join $dir safe.tcl]]
-set auto_index(::safe::FileInAccessPath) [list source [file join $dir safe.tcl]]
-set auto_index(::safe::DirInAccessPath) [list source [file join $dir safe.tcl]]
-set auto_index(::safe::Subset) [list source [file join $dir safe.tcl]]
-set auto_index(::safe::AliasSubset) [list source [file join $dir safe.tcl]]
-set auto_index(::safe::AliasEncoding) [list source [file join $dir safe.tcl]]
-set auto_index(tcl_wordBreakAfter) [list source [file join $dir word.tcl]]
-set auto_index(tcl_wordBreakBefore) [list source [file join $dir word.tcl]]
-set auto_index(tcl_endOfWord) [list source [file join $dir word.tcl]]
-set auto_index(tcl_startOfNextWord) [list source [file join $dir word.tcl]]
-set auto_index(tcl_startOfPreviousWord) [list source [file join $dir word.tcl]]
-set auto_index(::tcl::tm::add) [list source [file join $dir tm.tcl]]
-set auto_index(::tcl::tm::remove) [list source [file join $dir tm.tcl]]
-set auto_index(::tcl::tm::list) [list source [file join $dir tm.tcl]]
-set auto_index(::tcl::tm::Defaults) [list source [file join $dir tm.tcl]]
-set auto_index(::tcl::tm::UnknownHandler) [list source [file join $dir tm.tcl]]
-set auto_index(::tcl::tm::roots) [list source [file join $dir tm.tcl]]
-set auto_index(::tcl::tm::path) [list source [file join $dir tm.tcl]]
+set auto_index(auto_reset) [list ::tcl::Pkg::source [file join $dir auto.tcl]]
+set auto_index(tcl_findLibrary) [list ::tcl::Pkg::source [file join $dir auto.tcl]]
+set auto_index(auto_mkindex) [list ::tcl::Pkg::source [file join $dir auto.tcl]]
+set auto_index(auto_mkindex_old) [list ::tcl::Pkg::source [file join $dir auto.tcl]]
+set auto_index(::auto_mkindex_parser::init) [list ::tcl::Pkg::source [file join $dir auto.tcl]]
+set auto_index(::auto_mkindex_parser::cleanup) [list ::tcl::Pkg::source [file join $dir auto.tcl]]
+set auto_index(::auto_mkindex_parser::mkindex) [list ::tcl::Pkg::source [file join $dir auto.tcl]]
+set auto_index(::auto_mkindex_parser::hook) [list ::tcl::Pkg::source [file join $dir auto.tcl]]
+set auto_index(::auto_mkindex_parser::slavehook) [list ::tcl::Pkg::source [file join $dir auto.tcl]]
+set auto_index(::auto_mkindex_parser::command) [list ::tcl::Pkg::source [file join $dir auto.tcl]]
+set auto_index(::auto_mkindex_parser::commandInit) [list ::tcl::Pkg::source [file join $dir auto.tcl]]
+set auto_index(::auto_mkindex_parser::fullname) [list ::tcl::Pkg::source [file join $dir auto.tcl]]
+set auto_index(history) [list ::tcl::Pkg::source [file join $dir history.tcl]]
+set auto_index(::tcl::HistAdd) [list ::tcl::Pkg::source [file join $dir history.tcl]]
+set auto_index(::tcl::HistKeep) [list ::tcl::Pkg::source [file join $dir history.tcl]]
+set auto_index(::tcl::HistClear) [list ::tcl::Pkg::source [file join $dir history.tcl]]
+set auto_index(::tcl::HistInfo) [list ::tcl::Pkg::source [file join $dir history.tcl]]
+set auto_index(::tcl::HistRedo) [list ::tcl::Pkg::source [file join $dir history.tcl]]
+set auto_index(::tcl::HistIndex) [list ::tcl::Pkg::source [file join $dir history.tcl]]
+set auto_index(::tcl::HistEvent) [list ::tcl::Pkg::source [file join $dir history.tcl]]
+set auto_index(::tcl::HistChange) [list ::tcl::Pkg::source [file join $dir history.tcl]]
+set auto_index(pkg_mkIndex) [list ::tcl::Pkg::source [file join $dir package.tcl]]
+set auto_index(tclPkgSetup) [list ::tcl::Pkg::source [file join $dir package.tcl]]
+set auto_index(tclPkgUnknown) [list ::tcl::Pkg::source [file join $dir package.tcl]]
+set auto_index(::tcl::MacOSXPkgUnknown) [list ::tcl::Pkg::source [file join $dir package.tcl]]
+set auto_index(::pkg::create) [list ::tcl::Pkg::source [file join $dir package.tcl]]
+set auto_index(parray) [list ::tcl::Pkg::source [file join $dir parray.tcl]]
+set auto_index(::safe::InterpStatics) [list ::tcl::Pkg::source [file join $dir safe.tcl]]
+set auto_index(::safe::InterpNested) [list ::tcl::Pkg::source [file join $dir safe.tcl]]
+set auto_index(::safe::interpCreate) [list ::tcl::Pkg::source [file join $dir safe.tcl]]
+set auto_index(::safe::interpInit) [list ::tcl::Pkg::source [file join $dir safe.tcl]]
+set auto_index(::safe::CheckInterp) [list ::tcl::Pkg::source [file join $dir safe.tcl]]
+set auto_index(::safe::interpConfigure) [list ::tcl::Pkg::source [file join $dir safe.tcl]]
+set auto_index(::safe::InterpCreate) [list ::tcl::Pkg::source [file join $dir safe.tcl]]
+set auto_index(::safe::InterpSetConfig) [list ::tcl::Pkg::source [file join $dir safe.tcl]]
+set auto_index(::safe::interpFindInAccessPath) [list ::tcl::Pkg::source [file join $dir safe.tcl]]
+set auto_index(::safe::interpAddToAccessPath) [list ::tcl::Pkg::source [file join $dir safe.tcl]]
+set auto_index(::safe::InterpInit) [list ::tcl::Pkg::source [file join $dir safe.tcl]]
+set auto_index(::safe::AddSubDirs) [list ::tcl::Pkg::source [file join $dir safe.tcl]]
+set auto_index(::safe::interpDelete) [list ::tcl::Pkg::source [file join $dir safe.tcl]]
+set auto_index(::safe::setLogCmd) [list ::tcl::Pkg::source [file join $dir safe.tcl]]
+set auto_index(::safe::SyncAccessPath) [list ::tcl::Pkg::source [file join $dir safe.tcl]]
+set auto_index(::safe::PathToken) [list ::tcl::Pkg::source [file join $dir safe.tcl]]
+set auto_index(::safe::TranslatePath) [list ::tcl::Pkg::source [file join $dir safe.tcl]]
+set auto_index(::safe::Log) [list ::tcl::Pkg::source [file join $dir safe.tcl]]
+set auto_index(::safe::CheckFileName) [list ::tcl::Pkg::source [file join $dir safe.tcl]]
+set auto_index(::safe::AliasGlob) [list ::tcl::Pkg::source [file join $dir safe.tcl]]
+set auto_index(::safe::AliasSource) [list ::tcl::Pkg::source [file join $dir safe.tcl]]
+set auto_index(::safe::AliasLoad) [list ::tcl::Pkg::source [file join $dir safe.tcl]]
+set auto_index(::safe::FileInAccessPath) [list ::tcl::Pkg::source [file join $dir safe.tcl]]
+set auto_index(::safe::DirInAccessPath) [list ::tcl::Pkg::source [file join $dir safe.tcl]]
+set auto_index(::safe::Subset) [list ::tcl::Pkg::source [file join $dir safe.tcl]]
+set auto_index(::safe::AliasSubset) [list ::tcl::Pkg::source [file join $dir safe.tcl]]
+set auto_index(::safe::AliasEncoding) [list ::tcl::Pkg::source [file join $dir safe.tcl]]
+set auto_index(tcl_wordBreakAfter) [list ::tcl::Pkg::source [file join $dir word.tcl]]
+set auto_index(tcl_wordBreakBefore) [list ::tcl::Pkg::source [file join $dir word.tcl]]
+set auto_index(tcl_endOfWord) [list ::tcl::Pkg::source [file join $dir word.tcl]]
+set auto_index(tcl_startOfNextWord) [list ::tcl::Pkg::source [file join $dir word.tcl]]
+set auto_index(tcl_startOfPreviousWord) [list ::tcl::Pkg::source [file join $dir word.tcl]]
+set auto_index(::tcl::tm::add) [list ::tcl::Pkg::source [file join $dir tm.tcl]]
+set auto_index(::tcl::tm::remove) [list ::tcl::Pkg::source [file join $dir tm.tcl]]
+set auto_index(::tcl::tm::list) [list ::tcl::Pkg::source [file join $dir tm.tcl]]
+set auto_index(::tcl::tm::Defaults) [list ::tcl::Pkg::source [file join $dir tm.tcl]]
+set auto_index(::tcl::tm::UnknownHandler) [list ::tcl::Pkg::source [file join $dir tm.tcl]]
+set auto_index(::tcl::tm::roots) [list ::tcl::Pkg::source [file join $dir tm.tcl]]
+set auto_index(::tcl::tm::path) [list ::tcl::Pkg::source [file join $dir tm.tcl]]
diff --git a/tests/get.test b/tests/get.test
index 7aa06c1..d6a7206 100644
--- a/tests/get.test
+++ b/tests/get.test
@@ -98,17 +98,17 @@ test get-3.2 {Tcl_GetDouble(FromObj), bad numbers} {
} {0 1 0 1 1 {expected floating-point number but got "++1.0"} 1 {expected floating-point number but got "+-1.0"} 1 {expected floating-point number but got "-+1.0"} 0 -1 1 {expected floating-point number but got "--1.0"} 1 {expected floating-point number but got "- +1.0"}}
# Bug 7114ac6141
test get-3.3 {tcl_GetInt with iffy numbers} testgetint {
- lmap x {0 " 0" "0 " " 0 " " 0xa " " 010 " " 0o10 " " 0b10 "} {
+ lmap x {0 " 0" "0 " " 0 " " 0xa " " 007 " " 0o10 " " 0b10 "} {
catch {testgetint 44 $x} x
set x
}
-} {44 44 44 44 54 52 52 46}
+} {44 44 44 44 54 51 52 46}
test get-3.4 {Tcl_GetDouble with iffy numbers} testdoubleobj {
- lmap x {0 0.0 " .0" ".0 " " 0e0 " "09" "- 0" "-0" "0o12" "0b10"} {
+ lmap x {0 0.0 " .0" ".0 " " 0e0 " "07" "- 0" "-0" "0o12" "0b10"} {
catch {testdoubleobj set 1 $x} x
set x
}
-} {0.0 0.0 0.0 0.0 0.0 {expected floating-point number but got "09" (looks like invalid octal number)} {expected floating-point number but got "- 0"} 0.0 10.0 2.0}
+} {0.0 0.0 0.0 0.0 0.0 7.0 {expected floating-point number but got "- 0"} 0.0 10.0 2.0}
# cleanup
::tcltest::cleanupTests
diff --git a/tests/parseExpr.test b/tests/parseExpr.test
index fda25b7..47dbec5 100644
--- a/tests/parseExpr.test
+++ b/tests/parseExpr.test
@@ -1044,9 +1044,8 @@ test parseExpr-22.13 {Bug 3401704} -constraints testexprparser -body {
} -result {- {} 0 subexpr naner() 1 operator naner 0 {}}
test parseExpr-22.14 {Bug 3401704} -constraints testexprparser -body {
- catch {testexprparser 08 -1} m o
- dict get $o -errorcode
-} -result {TCL PARSE EXPR BADNUMBER OCTAL}
+ testexprparser 07 -1
+} -result {- {} 0 subexpr 07 1 text 07 0 {}}
test parseExpr-22.15 {Bug 3401704} -constraints testexprparser -body {
catch {testexprparser 0o8 -1} m o
dict get $o -errorcode
diff --git a/unix/tclUnixSock.c b/unix/tclUnixSock.c
index 8e97543..9387d05 100644
--- a/unix/tclUnixSock.c
+++ b/unix/tclUnixSock.c
@@ -240,7 +240,7 @@ InitializeHostName(
}
}
if (native == NULL) {
- native = tclEmptyStringRep;
+ native = &tclEmptyString;
}
#else /* !NO_UNAME */
/*
generated by cgit v0.12 at 2024-07-15 12:51:17 (GMT)