summaryrefslogtreecommitdiffstats
diff options
context:
space:
mode:
Diffstat
-rw-r--r--.project2
-rw-r--r--generic/tclBasic.c8
-rw-r--r--generic/tclEncoding.c42
-rw-r--r--generic/tclEnv.c1
-rw-r--r--generic/tclFileName.c2
-rw-r--r--generic/tclInt.h18
-rw-r--r--generic/tclOO.c48
-rw-r--r--generic/tclOOCall.c8
-rw-r--r--generic/tclOOInt.h16
-rw-r--r--generic/tclStringObj.c42
-rw-r--r--generic/tclTest.c47
-rw-r--r--library/opt/optparse.tcl4
-rw-r--r--library/opt/pkgIndex.tcl4
-rw-r--r--library/tcltest/pkgIndex.tcl4
-rw-r--r--library/tcltest/tcltest.tcl2
-rw-r--r--tests/assemble.test2
-rw-r--r--tests/cmdAH.test8
-rw-r--r--tests/encoding.test36
-rw-r--r--tests/execute.test6
-rw-r--r--tests/oo.test30
-rw-r--r--tests/platform.test4
-rw-r--r--tests/resolver.test9
-rw-r--r--tests/string.test42
-rw-r--r--tests/stringObj.test5
-rw-r--r--tests/utf.test4
-rw-r--r--unix/Makefile.in4
-rw-r--r--unix/tclEpollNotfy.c5
-rw-r--r--win/tcl.hpj.in4
-rw-r--r--win/tclWinLoad.c10
29 files changed, 273 insertions, 144 deletions
diff --git a/.project b/.project
index a9d6ecf..eddd834 100644
--- a/.project
+++ b/.project
@@ -1,6 +1,6 @@
<?xml version="1.0" encoding="UTF-8"?>
<projectDescription>
- <name>tcl8.7</name>
+ <name>tcl8</name>
<comment></comment>
<projects>
</projects>
diff --git a/generic/tclBasic.c b/generic/tclBasic.c
index d4fa833..e6022ac 100644
--- a/generic/tclBasic.c
+++ b/generic/tclBasic.c
@@ -3112,7 +3112,7 @@ Tcl_DeleteCommandFromToken(
/*
* We must delete this command, even though both traces and delete procs
* may try to avoid this (renaming the command etc). Also traces and
- * delete procs may try to delete the command themsevles. This flag
+ * delete procs may try to delete the command themselves. This flag
* declares that a delete is in progress and that recursive deletes should
* be ignored.
*/
@@ -7722,8 +7722,8 @@ ExprRandFunc(
iPtr->flags |= RAND_SEED_INITIALIZED;
/*
- * Take into consideration the thread this interp is running in order
- * to insure different seeds in different threads (bug #416643)
+ * To ensure different seeds in different threads (bug #416643),
+ * take into consideration the thread this interp is running in.
*/
iPtr->randSeed = TclpGetClicks() + (PTR2INT(Tcl_GetCurrentThread())<<12);
@@ -9091,7 +9091,7 @@ TclNRCoroutineObjCmd(
TclNRAddCallback(interp, NRCoroutineExitCallback, corPtr,
NULL, NULL, NULL);
- /* insure that the command is looked up in the correct namespace */
+ /* ensure that the command is looked up in the correct namespace */
iPtr->lookupNsPtr = lookupNsPtr;
Tcl_NREvalObj(interp, Tcl_NewListObj(objc-2, objv+2), 0);
iPtr->numLevels--;
diff --git a/generic/tclEncoding.c b/generic/tclEncoding.c
index e328340..1f48a1c 100644
--- a/generic/tclEncoding.c
+++ b/generic/tclEncoding.c
@@ -563,7 +563,7 @@ TclInitEncodingSubsystem(void)
* formed UTF-8 into a properly formed stream.
*/
- type.encodingName = "identity";
+ type.encodingName = NULL;
type.toUtfProc = BinaryProc;
type.fromUtfProc = BinaryProc;
type.freeProc = NULL;
@@ -851,7 +851,9 @@ FreeEncoding(
if (encodingPtr->hPtr != NULL) {
Tcl_DeleteHashEntry(encodingPtr->hPtr);
}
- ckfree(encodingPtr->name);
+ if (encodingPtr->name) {
+ ckfree(encodingPtr->name);
+ }
ckfree(encodingPtr);
}
}
@@ -1040,9 +1042,24 @@ Tcl_CreateEncoding(
const Tcl_EncodingType *typePtr)
/* The encoding type. */
{
+ Encoding *encodingPtr = ckalloc(sizeof(Encoding));
+ encodingPtr->name = NULL;
+ encodingPtr->toUtfProc = typePtr->toUtfProc;
+ encodingPtr->fromUtfProc = typePtr->fromUtfProc;
+ encodingPtr->freeProc = typePtr->freeProc;
+ encodingPtr->nullSize = typePtr->nullSize;
+ encodingPtr->clientData = typePtr->clientData;
+ if (typePtr->nullSize == 1) {
+ encodingPtr->lengthProc = (LengthProc *) strlen;
+ } else {
+ encodingPtr->lengthProc = (LengthProc *) unilen;
+ }
+ encodingPtr->refCount = 1;
+ encodingPtr->hPtr = NULL;
+
+ if (typePtr->encodingName) {
Tcl_HashEntry *hPtr;
int isNew;
- Encoding *encodingPtr;
char *name;
Tcl_MutexLock(&encodingMutex);
@@ -1053,30 +1070,17 @@ Tcl_CreateEncoding(
* reference goes away.
*/
- encodingPtr = Tcl_GetHashValue(hPtr);
- encodingPtr->hPtr = NULL;
+ Encoding *replaceMe = Tcl_GetHashValue(hPtr);
+ replaceMe->hPtr = NULL;
}
name = ckalloc(strlen(typePtr->encodingName) + 1);
-
- encodingPtr = ckalloc(sizeof(Encoding));
encodingPtr->name = strcpy(name, typePtr->encodingName);
- encodingPtr->toUtfProc = typePtr->toUtfProc;
- encodingPtr->fromUtfProc = typePtr->fromUtfProc;
- encodingPtr->freeProc = typePtr->freeProc;
- encodingPtr->nullSize = typePtr->nullSize;
- encodingPtr->clientData = typePtr->clientData;
- if (typePtr->nullSize == 1) {
- encodingPtr->lengthProc = (LengthProc *) strlen;
- } else {
- encodingPtr->lengthProc = (LengthProc *) unilen;
- }
- encodingPtr->refCount = 1;
encodingPtr->hPtr = hPtr;
Tcl_SetHashValue(hPtr, encodingPtr);
Tcl_MutexUnlock(&encodingMutex);
-
+ }
return (Tcl_Encoding) encodingPtr;
}
diff --git a/generic/tclEnv.c b/generic/tclEnv.c
index 66ddb57..8cc4b74 100644
--- a/generic/tclEnv.c
+++ b/generic/tclEnv.c
@@ -130,6 +130,7 @@ TclSetupEnv(
* '='; ignore the entry.
*/
+ Tcl_DStringFree(&envString);
continue;
}
p2++;
diff --git a/generic/tclFileName.c b/generic/tclFileName.c
index 150fb8c..15fcde7 100644
--- a/generic/tclFileName.c
+++ b/generic/tclFileName.c
@@ -1904,7 +1904,7 @@ TclGlob(
}
/*
- * To process a [glob] invokation, this function may be called multiple
+ * To process a [glob] invocation, this function may be called multiple
* times. Each time, the previously discovered filenames are in the
* interpreter result. We stash that away here so the result is free for
* error messsages.
diff --git a/generic/tclInt.h b/generic/tclInt.h
index 0b5ff0c..0d68e8e 100644
--- a/generic/tclInt.h
+++ b/generic/tclInt.h
@@ -2445,8 +2445,8 @@ typedef struct List {
#define TCL_EACH_COLLECT 1 /* Collect iteration result like [lmap] */
/*
- * Macros providing a faster path to integers: Tcl_GetLongFromObj everywhere,
- * Tcl_GetIntFromObj and TclGetIntForIndex on platforms where longs are ints.
+ * Macros providing a faster path to integers: Tcl_GetLongFromObj,
+ * Tcl_GetIntFromObj and TclGetIntForIndex.
*
* WARNING: these macros eval their args more than once.
*/
@@ -2467,9 +2467,17 @@ typedef struct List {
: TclGetIntForIndex((interp), (objPtr), (endValue), (idxPtr)))
#else
#define TclGetIntFromObj(interp, objPtr, intPtr) \
- Tcl_GetIntFromObj((interp), (objPtr), (intPtr))
-#define TclGetIntForIndexM(interp, objPtr, ignore, idxPtr) \
- TclGetIntForIndex(interp, objPtr, ignore, idxPtr)
+ (((objPtr)->typePtr == &tclIntType \
+ && (objPtr)->internalRep.longValue >= -(Tcl_WideInt)(UINT_MAX) \
+ && (objPtr)->internalRep.longValue <= (Tcl_WideInt)(UINT_MAX)) \
+ ? ((*(intPtr) = (objPtr)->internalRep.longValue), TCL_OK) \
+ : Tcl_GetIntFromObj((interp), (objPtr), (intPtr)))
+#define TclGetIntForIndexM(interp, objPtr, endValue, idxPtr) \
+ (((objPtr)->typePtr == &tclIntType \
+ && (objPtr)->internalRep.longValue >= INT_MIN \
+ && (objPtr)->internalRep.longValue <= INT_MAX) \
+ ? ((*(idxPtr) = (objPtr)->internalRep.longValue), TCL_OK) \
+ : TclGetIntForIndex((interp), (objPtr), (endValue), (idxPtr)))
#endif
/*
diff --git a/generic/tclOO.c b/generic/tclOO.c
index 73acce8..51731d3 100644
--- a/generic/tclOO.c
+++ b/generic/tclOO.c
@@ -880,7 +880,7 @@ ObjectRenamedTrace(
* 2950259]
*/
- if (((Namespace *) oPtr->namespacePtr)->earlyDeleteProc != NULL) {
+ if (oPtr->namespacePtr && ((Namespace *) oPtr->namespacePtr)->earlyDeleteProc != NULL) {
Tcl_DeleteNamespace(oPtr->namespacePtr);
}
if (oPtr->classPtr) {
@@ -1006,8 +1006,18 @@ ReleaseClassContents(
}
for(j=0 ; j<instancePtr->mixins.num ; j++) {
Class *mixin = instancePtr->mixins.list[j];
+ Class *nextMixin = NULL;
if (mixin == clsPtr) {
- instancePtr->mixins.list[j] = NULL;
+ if (j < instancePtr->mixins.num - 1) {
+ nextMixin = instancePtr->mixins.list[j+1];
+ }
+ if (j == 0) {
+ instancePtr->mixins.num = 0;
+ instancePtr->mixins.list = NULL;
+ } else {
+ instancePtr->mixins.list[j-1] = nextMixin;
+ }
+ instancePtr->mixins.num -= 1;
}
}
if (instancePtr != NULL && !IsRoot(instancePtr)) {
@@ -1168,7 +1178,7 @@ ObjectNamespaceDeleted(
Class *clsPtr = oPtr->classPtr, *mixinPtr;
Method *mPtr;
Tcl_Obj *filterObj, *variableObj;
- int i;
+ int deleteAlreadyInProgress = 0, i;
/*
* Instruct everyone to no longer use any allocated fields of the object.
@@ -1178,6 +1188,15 @@ ObjectNamespaceDeleted(
*/
if (oPtr->command) {
+ if ((((Command *)oPtr->command)->flags && CMD_IS_DELETED)) {
+ /*
+ * Namespace deletion must have been triggered by a trace on command
+ * deletion , meaning that ObjectRenamedTrace() is eventually going
+ * to be called .
+ */
+ deleteAlreadyInProgress = 1;
+ }
+
Tcl_DeleteCommandFromToken(oPtr->fPtr->interp, oPtr->command);
}
if (oPtr->myCommand) {
@@ -1273,14 +1292,17 @@ ObjectNamespaceDeleted(
if (clsPtr->subclasses.list) {
ckfree(clsPtr->subclasses.list);
+ clsPtr->subclasses.list = NULL;
clsPtr->subclasses.num = 0;
}
if (clsPtr->instances.list) {
ckfree(clsPtr->instances.list);
+ clsPtr->instances.list = NULL;
clsPtr->instances.num = 0;
}
if (clsPtr->mixinSubs.list) {
ckfree(clsPtr->mixinSubs.list);
+ clsPtr->mixinSubs.list = NULL;
clsPtr->mixinSubs.num = 0;
}
@@ -1305,7 +1327,13 @@ ObjectNamespaceDeleted(
* Delete the object structure itself.
*/
- DelRef(oPtr);
+ if (deleteAlreadyInProgress) {
+ oPtr->classPtr = NULL;
+ oPtr->namespacePtr = NULL;
+ } else {
+ DelRef(oPtr);
+ }
+
}
/*
@@ -2433,7 +2461,7 @@ Tcl_ObjectSetMetadata(
*
* PublicObjectCmd, PrivateObjectCmd, TclOOInvokeObject --
*
- * Main entry point for object invokations. The Public* and Private*
+ * Main entry point for object invocations. The Public* and Private*
* wrapper functions (implementations of both object instance commands
* and [my]) are just thin wrappers round the main TclOOObjectCmdCore
* function. Note that the core is function is NRE-aware.
@@ -2518,8 +2546,8 @@ TclOOInvokeObject(
*
* TclOOObjectCmdCore, FinalizeObjectCall --
*
- * Main function for object invokations. Does call chain creation,
- * management and invokation. The function FinalizeObjectCall exists to
+ * Main function for object invocations. Does call chain creation,
+ * management and invocation. The function FinalizeObjectCall exists to
* clean up after the non-recursive processing of TclOOObjectCmdCore.
*
* ----------------------------------------------------------------------
@@ -2531,7 +2559,7 @@ TclOOObjectCmdCore(
Tcl_Interp *interp, /* The interpreter containing the object. */
int objc, /* How many arguments are being passed in. */
Tcl_Obj *const *objv, /* The array of arguments. */
- int flags, /* Whether this is an invokation through the
+ int flags, /* Whether this is an invocation through the
* public or the private command interface. */
Class *startCls) /* Where to start in the call chain, or NULL
* if we are to start at the front with
@@ -2720,7 +2748,7 @@ Tcl_ObjectContextInvokeNext(
* call context while we process the body. However, need to adjust the
* argument-skip control because we're guaranteed to have a single prefix
* arg (i.e., 'next') and not the variable amount that can happen because
- * method invokations (i.e., '$obj meth' and 'my meth'), constructors
+ * method invocations (i.e., '$obj meth' and 'my meth'), constructors
* (i.e., '$cls new' and '$cls create obj') and destructors (no args at
* all) come through the same code.
*/
@@ -2789,7 +2817,7 @@ TclNRObjectContextInvokeNext(
* call context while we process the body. However, need to adjust the
* argument-skip control because we're guaranteed to have a single prefix
* arg (i.e., 'next') and not the variable amount that can happen because
- * method invokations (i.e., '$obj meth' and 'my meth'), constructors
+ * method invocations (i.e., '$obj meth' and 'my meth'), constructors
* (i.e., '$cls new' and '$cls create obj') and destructors (no args at
* all) come through the same code.
*/
diff --git a/generic/tclOOCall.c b/generic/tclOOCall.c
index 3e4f561..d4e1e34 100644
--- a/generic/tclOOCall.c
+++ b/generic/tclOOCall.c
@@ -233,7 +233,7 @@ FreeMethodNameRep(
* TclOOInvokeContext --
*
* Invokes a single step along a method call-chain context. Note that the
- * invokation of a step along the chain can cause further steps along the
+ * invocation of a step along the chain can cause further steps along the
* chain to be invoked. Note that this function is written to be as light
* in stack usage as possible.
*
@@ -830,7 +830,7 @@ AddMethodToCallChain(
* Call chain semantics states that methods come as *late* in the
* call chain as possible. This is done by copying down the
* following methods. Note that this does not change the number of
- * method invokations in the call chain; it just rearranges them.
+ * method invocations in the call chain; it just rearranges them.
*/
Class *declCls = callPtr->chain[i].filterDeclarer;
@@ -935,7 +935,7 @@ IsStillValid(
* TclOOGetCallContext --
*
* Responsible for constructing the call context, an ordered list of all
- * method implementations to be called as part of a method invokation.
+ * method implementations to be called as part of a method invocation.
* This method is central to the whole operation of the OO system.
*
* ----------------------------------------------------------------------
@@ -1517,7 +1517,7 @@ TclOORenderCallChain(
/*
* Do the actual construction of the descriptions. They consist of a list
* of triples that describe the details of how a method is understood. For
- * each triple, the first word is the type of invokation ("method" is
+ * each triple, the first word is the type of invocation ("method" is
* normal, "unknown" is special because it adds the method name as an
* extra argument when handled by some method types, and "filter" is
* special because it's a filter method). The second word is the name of
diff --git a/generic/tclOOInt.h b/generic/tclOOInt.h
index 476446d..11ba698 100644
--- a/generic/tclOOInt.h
+++ b/generic/tclOOInt.h
@@ -149,8 +149,8 @@ typedef struct Object {
struct Foundation *fPtr; /* The basis for the object system. Putting
* this here allows the avoidance of quite a
* lot of hash lookups on the critical path
- * for object invokation and creation. */
- Tcl_Namespace *namespacePtr;/* This object's tame namespace. */
+ * for object invocation and creation. */
+ Tcl_Namespace *namespacePtr;/* This object's namespace. */
Tcl_Command command; /* Reference to this object's public
* command. */
Tcl_Command myCommand; /* Reference to this object's internal
@@ -162,12 +162,12 @@ typedef struct Object {
/* Classes mixed into this object. */
LIST_STATIC(Tcl_Obj *) filters;
/* List of filter names. */
- struct Class *classPtr; /* All classes have this non-NULL; it points
- * to the class structure. Everything else has
- * this NULL. */
+ struct Class *classPtr; /* This is non-NULL for all classes, and NULL
+ * for everything else. It points to the class
+ * structure. */
int refCount; /* Number of strong references to this object.
* Note that there may be many more weak
- * references; this mechanism is there to
+ * references; this mechanism exists to
* avoid Tcl_Preserve. */
int flags;
int creationEpoch; /* Unique value to make comparisons of objects
@@ -323,7 +323,7 @@ typedef struct Foundation {
} Foundation;
/*
- * A call context structure is built when a method is called. They contain the
+ * A call context structure is built when a method is called. It contains the
* chain of method implementations that are to be invoked by a particular
* call, and the process of calling walks the chain, with the [next] command
* proceeding to the next entry in the chain.
@@ -334,7 +334,7 @@ typedef struct Foundation {
struct MInvoke {
Method *mPtr; /* Reference to the method implementation
* record. */
- int isFilter; /* Whether this is a filter invokation. */
+ int isFilter; /* Whether this is a filter invocation. */
Class *filterDeclarer; /* What class decided to add the filter; if
* NULL, it was added by the object. */
};
diff --git a/generic/tclStringObj.c b/generic/tclStringObj.c
index b8e2293..3925a16 100644
--- a/generic/tclStringObj.c
+++ b/generic/tclStringObj.c
@@ -3267,40 +3267,44 @@ TclStringFind(
return -1;
}
+ /*
+ * Check if we have two strings of single-byte characters. If we have, we
+ * can use strstr() to do the search. Note that we can sometimes have
+ * multibyte characters when the string could be minimally represented
+ * using single byte characters; we can't assume that a mismatch here
+ * means no match.
+ */
+
lh = Tcl_GetCharLength(haystack);
- if (haystack->bytes && (lh == haystack->length)) {
- /* haystack is all single-byte chars */
+ if (haystack->bytes && (lh == haystack->length) && needle->bytes
+ && (ln == needle->length)) {
+ /*
+ * Both haystack and needle are all single-byte chars.
+ */
- if (needle->bytes && (ln == needle->length)) {
- /* needle is also all single-byte chars */
- char *found = strstr(haystack->bytes + start, needle->bytes);
+ char *found = strstr(haystack->bytes + start, needle->bytes);
- if (found) {
- return (found - haystack->bytes);
- } else {
- return -1;
- }
+ if (found) {
+ return (found - haystack->bytes);
} else {
- /*
- * Cannot find substring with a multi-byte char inside
- * a string with no multi-byte chars.
- */
return -1;
}
} else {
+ /*
+ * Do the search on the unicode representation for simplicity.
+ */
+
Tcl_UniChar *try, *end, *uh;
Tcl_UniChar *un = Tcl_GetUnicodeFromObj(needle, &ln);
uh = Tcl_GetUnicodeFromObj(haystack, &lh);
end = uh + lh;
- try = uh + start;
- while (try + ln <= end) {
- if ((*try == *un)
- && (0 == memcmp(try+1, un+1, (ln-1)*sizeof(Tcl_UniChar)))) {
+ for (try = uh + start; try + ln <= end; try++) {
+ if ((*try == *un) && (0 ==
+ memcmp(try + 1, un + 1, (ln-1) * sizeof(Tcl_UniChar)))) {
return (try - uh);
}
- try++;
}
return -1;
}
diff --git a/generic/tclTest.c b/generic/tclTest.c
index ebd90ae..834cd79 100644
--- a/generic/tclTest.c
+++ b/generic/tclTest.c
@@ -227,6 +227,9 @@ static int TestasyncCmd(ClientData dummy,
static int TestbytestringObjCmd(ClientData clientData,
Tcl_Interp *interp, int objc,
Tcl_Obj *const objv[]);
+static int TeststringbytesObjCmd(ClientData clientData,
+ Tcl_Interp *interp, int objc,
+ Tcl_Obj *const objv[]);
static int TestcmdinfoCmd(ClientData dummy,
Tcl_Interp *interp, int argc, const char **argv);
static int TestcmdtokenCmd(ClientData dummy,
@@ -581,6 +584,7 @@ Tcltest_Init(
Tcl_CreateCommand(interp, "noop", NoopCmd, NULL, NULL);
Tcl_CreateObjCommand(interp, "noop", NoopObjCmd, NULL, NULL);
Tcl_CreateObjCommand(interp, "testbytestring", TestbytestringObjCmd, NULL, NULL);
+ Tcl_CreateObjCommand(interp, "teststringbytes", TeststringbytesObjCmd, NULL, NULL);
Tcl_CreateObjCommand(interp, "testwrongnumargs", TestWrongNumArgsObjCmd,
NULL, NULL);
Tcl_CreateObjCommand(interp, "testfilesystem", TestFilesystemObjCmd,
@@ -1985,9 +1989,12 @@ TestencodingObjCmd(
if (objc != 3) {
return TCL_ERROR;
}
- encoding = Tcl_GetEncoding(NULL, Tcl_GetString(objv[2]));
- Tcl_FreeEncoding(encoding);
- Tcl_FreeEncoding(encoding);
+ if (TCL_OK != Tcl_GetEncodingFromObj(interp, objv[2], &encoding)) {
+ return TCL_ERROR;
+ }
+ Tcl_FreeEncoding(encoding); /* Free returned reference */
+ Tcl_FreeEncoding(encoding); /* Free to match CREATE */
+ TclFreeIntRep(objv[2]); /* Free the cached ref */
break;
}
return TCL_OK;
@@ -5046,6 +5053,40 @@ NoopObjCmd(
/*
*----------------------------------------------------------------------
*
+ * TeststringbytesObjCmd --
+ * Returns bytearray value of the bytes in argument string rep
+ *
+ * Results:
+ * Returns the TCL_OK result code.
+ *
+ * Side effects:
+ * None.
+ *
+ *----------------------------------------------------------------------
+ */
+
+static int
+TeststringbytesObjCmd(
+ ClientData unused, /* Not used. */
+ Tcl_Interp *interp, /* Current interpreter. */
+ int objc, /* Number of arguments. */
+ Tcl_Obj *const objv[]) /* The argument objects. */
+{
+ int n;
+ const unsigned char *p;
+
+ if (objc != 2) {
+ Tcl_WrongNumArgs(interp, 1, objv, "value");
+ return TCL_ERROR;
+ }
+ p = (const unsigned char *)Tcl_GetStringFromObj(objv[1], &n);
+ Tcl_SetObjResult(interp, Tcl_NewByteArrayObj(p, n));
+ return TCL_OK;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
* TestbytestringObjCmd --
*
* This object-based procedure constructs a string which can
diff --git a/library/opt/optparse.tcl b/library/opt/optparse.tcl
index 869a2b6..c8946fd 100644
--- a/library/opt/optparse.tcl
+++ b/library/opt/optparse.tcl
@@ -8,10 +8,10 @@
# on it. If your code does rely on this package you
# may directly incorporate this code into your application.
-package require Tcl 8.2
+package require Tcl 8.5-
# When this version number changes, update the pkgIndex.tcl file
# and the install directory in the Makefiles.
-package provide opt 0.4.6
+package provide opt 0.4.7
namespace eval ::tcl {
diff --git a/library/opt/pkgIndex.tcl b/library/opt/pkgIndex.tcl
index 107d4c6..daf9aa9 100644
--- a/library/opt/pkgIndex.tcl
+++ b/library/opt/pkgIndex.tcl
@@ -8,5 +8,5 @@
# script is sourced, the variable $dir must contain the
# full path name of this file's directory.
-if {![package vsatisfies [package provide Tcl] 8.2]} {return}
-package ifneeded opt 0.4.6 [list source [file join $dir optparse.tcl]]
+if {![package vsatisfies [package provide Tcl] 8.5-]} {return}
+package ifneeded opt 0.4.7 [list source [file join $dir optparse.tcl]]
diff --git a/library/tcltest/pkgIndex.tcl b/library/tcltest/pkgIndex.tcl
index 5ac8823..eadb1bd 100644
--- a/library/tcltest/pkgIndex.tcl
+++ b/library/tcltest/pkgIndex.tcl
@@ -8,5 +8,5 @@
# script is sourced, the variable $dir must contain the
# full path name of this file's directory.
-if {![package vsatisfies [package provide Tcl] 8.5]} {return}
-package ifneeded tcltest 2.4.0 [list source [file join $dir tcltest.tcl]]
+if {![package vsatisfies [package provide Tcl] 8.5-]} {return}
+package ifneeded tcltest 2.4.1 [list source [file join $dir tcltest.tcl]]
diff --git a/library/tcltest/tcltest.tcl b/library/tcltest/tcltest.tcl
index 75975d2..f1b6082 100644
--- a/library/tcltest/tcltest.tcl
+++ b/library/tcltest/tcltest.tcl
@@ -22,7 +22,7 @@ namespace eval tcltest {
# When the version number changes, be sure to update the pkgIndex.tcl file,
# and the install directory in the Makefiles. When the minor version
# changes (new feature) be sure to update the man page as well.
- variable Version 2.4.0
+ variable Version 2.4.1
# Compatibility support for dumb variables defined in tcltest 1
# Do not use these. Call [package provide Tcl] and [info patchlevel]
diff --git a/tests/assemble.test b/tests/assemble.test
index d17bfd9..6e5308d 100644
--- a/tests/assemble.test
+++ b/tests/assemble.test
@@ -852,7 +852,7 @@ test assemble-8.5 {bad context} {
-body {
namespace eval assem {
set x 1
- list [catch {assemble {load x}} result] $result $errorCode
+ list [catch {assemble {load x}} result opts] $result [dict get $opts -errorcode]
}
}
-result {1 {cannot use this instruction to create a variable in a non-proc context} {TCL ASSEM LVT}}
diff --git a/tests/cmdAH.test b/tests/cmdAH.test
index 3c58c1b..e334dff 100644
--- a/tests/cmdAH.test
+++ b/tests/cmdAH.test
@@ -188,7 +188,7 @@ test cmdAH-4.5 {Tcl_EncodingObjCmd} -setup {
test cmdAH-4.6 {Tcl_EncodingObjCmd} -setup {
set system [encoding system]
} -body {
- encoding system identity
+ encoding system iso8859-1
encoding convertto jis0208 \u4e4e
} -cleanup {
encoding system $system
@@ -210,7 +210,7 @@ test cmdAH-4.9 {Tcl_EncodingObjCmd} -setup {
test cmdAH-4.10 {Tcl_EncodingObjCmd} -setup {
set system [encoding system]
} -body {
- encoding system identity
+ encoding system iso8859-1
encoding convertfrom jis0208 8C
} -cleanup {
encoding system $system
@@ -224,11 +224,11 @@ test cmdAH-4.12 {Tcl_EncodingObjCmd} -returnCodes error -body {
test cmdAH-4.13 {Tcl_EncodingObjCmd} -setup {
set system [encoding system]
} -body {
- encoding system identity
+ encoding system iso8859-1
encoding system
} -cleanup {
encoding system $system
-} -result identity
+} -result iso8859-1
test cmdAH-5.1 {Tcl_FileObjCmd} -returnCodes error -body {
file
diff --git a/tests/encoding.test b/tests/encoding.test
index be1f4d5..e447c20 100644
--- a/tests/encoding.test
+++ b/tests/encoding.test
@@ -34,6 +34,8 @@ proc runtests {} {
# Some tests require the testencoding command
testConstraint testencoding [llength [info commands testencoding]]
+testConstraint testbytestring [llength [info commands testbytestring]]
+testConstraint teststringbytes [llength [info commands teststringbytes]]
testConstraint fullutf [expr {[format %c 0x010000] != "\ufffd"}]
testConstraint exec [llength [info commands exec]]
testConstraint testgetencpath [llength [info commands testgetencpath]]
@@ -75,11 +77,11 @@ test encoding-2.2 {Tcl_FreeEncoding: refcount != 0} -setup {
encoding system shiftjis ;# incr ref count
encoding dirs [list [pwd]]
set x [encoding convertto shiftjis \u4e4e] ;# old one found
- encoding system identity
+ encoding system iso8859-1
llength shiftjis ;# Shimmer away any cache of Tcl_Encoding
lappend x [catch {encoding convertto shiftjis \u4e4e} msg] $msg
} -cleanup {
- encoding system identity
+ encoding system iso8859-1
encoding dirs $path
encoding system $system
} -result "\u008c\u00c1 1 {unknown encoding \"shiftjis\"}"
@@ -136,7 +138,7 @@ test encoding-5.1 {Tcl_SetSystemEncoding} -setup {
encoding system jis0208
encoding convertto \u4e4e
} -cleanup {
- encoding system identity
+ encoding system iso8859-1
encoding system $old
} -result {8C}
test encoding-5.2 {Tcl_SetSystemEncoding: test ref count} {
@@ -259,7 +261,7 @@ test encoding-11.5.1 {LoadEncodingFile: escape file} {
test encoding-11.6 {LoadEncodingFile: invalid file} -constraints {testencoding} -setup {
set system [encoding system]
set path [encoding dirs]
- encoding system identity
+ encoding system iso8859-1
} -body {
cd [temporaryDirectory]
encoding dirs [file join tmp encoding]
@@ -308,26 +310,18 @@ test encoding-13.1 {LoadEscapeTable} {
viewable [set x [encoding convertto iso2022 ab\u4e4e\u68d9g]]
} [viewable "ab\x1b\$B8C\x1b\$\(DD%\x1b(Bg"]
-test encoding-14.1 {BinaryProc} {
- encoding convertto identity \x12\x34\x56\xff\x69
-} "\x12\x34\x56\xc3\xbf\x69"
-
test encoding-15.1 {UtfToUtfProc} {
encoding convertto utf-8 \xa3
} "\xc2\xa3"
-test encoding-15.2 {UtfToUtfProc null character output} {
- set x \u0000
- set y [encoding convertto utf-8 \u0000]
- set y [encoding convertfrom identity $y]
- binary scan $y H* z
- list [string bytelength $x] [string bytelength $y] $z
-} {2 1 00}
-test encoding-15.3 {UtfToUtfProc null character input} {
- set x [encoding convertfrom identity \x00]
- set y [encoding convertfrom utf-8 $x]
- binary scan [encoding convertto identity $y] H* z
- list [string bytelength $x] [string bytelength $y] $z
-} {1 2 c080}
+test encoding-15.2 {UtfToUtfProc null character output} testbytestring {
+ binary scan [testbytestring [encoding convertto utf-8 \u0000]] H* z
+ set z
+} 00
+test encoding-15.3 {UtfToUtfProc null character input} teststringbytes {
+ set y [encoding convertfrom utf-8 [encoding convertto utf-8 \u0000]]
+ binary scan [teststringbytes $y] H* z
+ set z
+} c080
test encoding-16.1 {UnicodeToUtfProc} {
set val [encoding convertfrom unicode NN]
diff --git a/tests/execute.test b/tests/execute.test
index 5b8ce2d..6c277f8 100644
--- a/tests/execute.test
+++ b/tests/execute.test
@@ -724,7 +724,7 @@ test execute-6.14 {Tcl_ExprObj: exprcode context validation} -setup {
}
set result {}
lappend result [expr $e]
- lappend result [namespace eval foo {expr $e}]
+ lappend result [namespace eval foo [list expr $e]]
} -cleanup {
namespace delete foo
} -result {1 2}
@@ -733,11 +733,11 @@ test execute-6.15 {Tcl_ExprObj: exprcode name resolution epoch validation} -setu
} -body {
set e { [llength {}]+1 }
set result {}
- lappend result [namespace eval foo {expr $e}]
+ lappend result [namespace eval foo [list expr $e]]
namespace eval foo {
proc llength {args} {return 1}
}
- lappend result [namespace eval foo {expr $e}]
+ lappend result [namespace eval foo [list expr $e]]
} -cleanup {
namespace delete foo
} -result {1 2}
diff --git a/tests/oo.test b/tests/oo.test
index 54c4b75..b6af1ee 100644
--- a/tests/oo.test
+++ b/tests/oo.test
@@ -1482,6 +1482,36 @@ test oo-11.4 {OO: cleanup} {
lappend result [bar0 destroy] [oo::object create foo] [foo destroy] \
[oo::object create bar2] [bar2 destroy]
} {1 {can't create object "foo": command already exists with that name} destroyed {} ::foo {} ::bar2 {}}
+test oo-11.5 {OO: cleanup} {
+ oo::class create obj1
+
+ trace add command obj1 delete {apply {{name1 name2 action} {
+ set namespace [info object namespace $name1]
+ namespace delete $namespace
+ }}}
+
+ rename obj1 {}
+ # No segmentation fault
+ return done
+} done
+
+test oo-11.6 {
+ OO: cleanup ReleaseClassContents() where class is mixed into one of its
+ instances
+} {
+ oo::class create obj1
+ ::oo::define obj1 {self mixin [self]}
+
+ ::oo::copy obj1 obj2
+ ::oo::objdefine obj2 {mixin [self]}
+
+ ::oo::copy obj2 obj3
+ trace add command obj3 delete [list obj3 dying]
+ rename obj2 {}
+
+ # No segmentation fault
+ return done
+} done
test oo-12.1 {OO: filters} {
oo::class create Aclass
diff --git a/tests/platform.test b/tests/platform.test
index 5838a41..8a68351 100644
--- a/tests/platform.test
+++ b/tests/platform.test
@@ -16,7 +16,9 @@ namespace eval ::tcl::test::platform {
namespace import ::tcltest::test
namespace import ::tcltest::cleanupTests
- variable ::tcl_platform
+ # This is not how [variable] works. See TIP 276.
+ #variable ::tcl_platform
+ namespace upvar :: tcl_platform tcl_platform
::tcltest::loadTestedCommands
catch [list package require -exact Tcltest [info patchlevel]]
diff --git a/tests/resolver.test b/tests/resolver.test
index 9bb4c08..b0b395d 100644
--- a/tests/resolver.test
+++ b/tests/resolver.test
@@ -139,13 +139,10 @@ test resolver-1.5 {cmdNameObj sharing vs. cmd resolver: other than global NS} -s
variable r2 ""
}
} -constraints testinterpresolver -body {
- set r0 [namespace eval ::ns2 {x}]
- set r1 [namespace eval ::ns2 {z}]
- namespace eval ::ns2 {
+ list [namespace eval ::ns2 {x}] [namespace eval ::ns2 {z}] [namespace eval ::ns2 {
namespace import ::ns1::z
- set r2 [z]
- }
- list $r0 $r1 $r2
+ z
+ }]
} -cleanup {
testinterpresolver down
namespace delete ::ns2
diff --git a/tests/string.test b/tests/string.test
index 549944d..cebaf4c 100644
--- a/tests/string.test
+++ b/tests/string.test
@@ -28,6 +28,11 @@ testConstraint testindexobj [expr {[info commands testindexobj] != {}}]
# Used for constraining memory leak tests
testConstraint memory [llength [info commands memory]]
+proc representationpoke s {
+ set r [::tcl::unsupported::representation $s]
+ list [lindex $r 3] [string match {*, string representation "*"} $r]
+}
+
test string-1.1 {error conditions} {
list [catch {string gorp a b} msg] $msg
} {1 {unknown or ambiguous subcommand "gorp": must be bytelength, cat, compare, equal, first, index, is, last, length, map, match, range, repeat, replace, reverse, tolower, totitle, toupper, trim, trimleft, trimright, wordend, or wordstart}}
@@ -224,6 +229,13 @@ test string-4.15 {string first, ability to two-byte encoded utf-8 chars} {
set uchar \u057e ;# character with two-byte encoding in utf-8
string first % %#$uchar$uchar#$uchar$uchar#% 3
} 8
+test string-4.16 {string first, normal string vs pure unicode string} {
+ set s hello
+ regexp ll $s m
+ # Representation checks are canaries
+ list [representationpoke $s] [representationpoke $m] \
+ [string first $m $s]
+} {{string 1} {string 0} 2}
test string-5.1 {string index} {
list [catch {string index} msg] $msg
@@ -1685,40 +1697,40 @@ test string-24.4 {string reverse command - unshared string} {
string reverse $x$y
} edcba
test string-24.5 {string reverse command - shared unicode string} {
- set x abcde\udead
+ set x abcde\ud0ad
string reverse $x
-} \udeadedcba
+} \ud0adedcba
test string-24.6 {string reverse command - unshared string} {
set x abc
- set y de\udead
+ set y de\ud0ad
string reverse $x$y
-} \udeadedcba
+} \ud0adedcba
test string-24.7 {string reverse command - simple case} {
string reverse a
} a
test string-24.8 {string reverse command - simple case} {
- string reverse \udead
-} \udead
+ string reverse \ud0ad
+} \ud0ad
test string-24.9 {string reverse command - simple case} {
string reverse {}
} {}
test string-24.10 {string reverse command - corner case} {
- set x \ubeef\udead
+ set x \ubeef\ud0ad
string reverse $x
-} \udead\ubeef
+} \ud0ad\ubeef
test string-24.11 {string reverse command - corner case} {
set x \ubeef
- set y \udead
+ set y \ud0ad
string reverse $x$y
-} \udead\ubeef
+} \ud0ad\ubeef
test string-24.12 {string reverse command - corner case} {
set x \ubeef
- set y \udead
+ set y \ud0ad
string is ascii [string reverse $x$y]
} 0
test string-24.13 {string reverse command - pure Unicode string} {
- string reverse [string range \ubeef\udead\ubeef\udead\ubeef\udead 1 5]
-} \udead\ubeef\udead\ubeef\udead
+ string reverse [string range \ubeef\ud0ad\ubeef\ud0ad\ubeef\ud0ad 1 5]
+} \ud0ad\ubeef\ud0ad\ubeef\ud0ad
test string-24.14 {string reverse command - pure bytearray} {
binary scan [string reverse [binary format H* 010203]] H* x
set x
@@ -2042,9 +2054,7 @@ test string-29.15 {string cat, efficiency} -setup {
} -body {
tcl::unsupported::representation [string cat $e $f $e $f [list x]]
} -match glob -result {*no string representation}
-
-
-
+
# cleanup
rename MemStress {}
catch {rename foo {}}
diff --git a/tests/stringObj.test b/tests/stringObj.test
index 49f268e..a78b5f8 100644
--- a/tests/stringObj.test
+++ b/tests/stringObj.test
@@ -480,7 +480,6 @@ test stringObj-15.8 {Tcl_Append*ToObj: self appends} testobj {
teststringobj set 1 foo
teststringobj appendself2 1 3
} foo
-
if {[testConstraint testobj]} {
testobj freeallvars
@@ -489,3 +488,7 @@ if {[testConstraint testobj]} {
# cleanup
::tcltest::cleanupTests
return
+
+# Local Variables:
+# mode: tcl
+# End:
diff --git a/tests/utf.test b/tests/utf.test
index 422ab08..45f9c0c 100644
--- a/tests/utf.test
+++ b/tests/utf.test
@@ -68,10 +68,10 @@ test utf-2.7 {Tcl_UtfToUniChar: lead (3-byte) followed by 2 trail} testbytestrin
} {1}
test utf-2.8 {Tcl_UtfToUniChar: lead (4-byte) followed by 3 trail} -constraints {fullutf testbytestring} -body {
string length [testbytestring "\xF0\x90\x80\x80"]
-} -result {1}
+} -result {2}
test utf-2.9 {Tcl_UtfToUniChar: lead (4-byte) followed by 3 trail} -constraints {fullutf testbytestring} -body {
string length [testbytestring "\xF4\x8F\xBF\xBF"]
-} -result {1}
+} -result {2}
test utf-2.10 {Tcl_UtfToUniChar: lead (4-byte) followed by 3 trail, underflow} testbytestring {
string length [testbytestring "\xF0\x8F\xBF\xBF"]
} {4}
diff --git a/unix/Makefile.in b/unix/Makefile.in
index c31d128..032b5ac 100644
--- a/unix/Makefile.in
+++ b/unix/Makefile.in
@@ -857,8 +857,8 @@ install-libraries: libraries
done;
@echo "Installing package msgcat 1.6.1 as a Tcl Module";
@$(INSTALL_DATA) $(TOP_DIR)/library/msgcat/msgcat.tcl "$(SCRIPT_INSTALL_DIR)"/../tcl8/8.5/msgcat-1.6.1.tm;
- @echo "Installing package tcltest 2.4.0 as a Tcl Module";
- @$(INSTALL_DATA) $(TOP_DIR)/library/tcltest/tcltest.tcl "$(SCRIPT_INSTALL_DIR)"/../tcl8/8.5/tcltest-2.4.0.tm;
+ @echo "Installing package tcltest 2.4.1 as a Tcl Module";
+ @$(INSTALL_DATA) $(TOP_DIR)/library/tcltest/tcltest.tcl "$(SCRIPT_INSTALL_DIR)"/../tcl8/8.5/tcltest-2.4.1.tm;
@echo "Installing package platform 1.0.14 as a Tcl Module";
@$(INSTALL_DATA) $(TOP_DIR)/library/platform/platform.tcl "$(SCRIPT_INSTALL_DIR)"/../tcl8/8.4/platform-1.0.14.tm;
diff --git a/unix/tclEpollNotfy.c b/unix/tclEpollNotfy.c
index 088f314..9d0053c 100644
--- a/unix/tclEpollNotfy.c
+++ b/unix/tclEpollNotfy.c
@@ -462,7 +462,10 @@ PlatformEventsWait(
} else if (!timePtr->tv_sec && !timePtr->tv_usec) {
timeout = 0;
} else {
- timeout = (int)timePtr->tv_sec;
+ timeout = (int)timePtr->tv_sec * 1000;
+ if (timePtr->tv_usec) {
+ timeout += (int)timePtr->tv_usec / 1000;
+ }
}
/*
diff --git a/win/tcl.hpj.in b/win/tcl.hpj.in
index a94cea6..08d411d 100644
--- a/win/tcl.hpj.in
+++ b/win/tcl.hpj.in
@@ -5,9 +5,9 @@ HCW=0
LCID=0x409 0x0 0x0 ;English (United States)
REPORT=Yes
TITLE=Tcl/Tk Reference Manual
-CNT=tcl86.cnt
+CNT=tcl87.cnt
COPYRIGHT=Copyright © 2000 Ajuba Solutions
-HLP=tcl86.hlp
+HLP=tcl87.hlp
[FILES]
tcl.rtf
diff --git a/win/tclWinLoad.c b/win/tclWinLoad.c
index 27eb8f3..69263e9 100644
--- a/win/tclWinLoad.c
+++ b/win/tclWinLoad.c
@@ -63,7 +63,7 @@ TclpDlopen(
* file. */
int flags)
{
- HINSTANCE hInstance;
+ HINSTANCE hInstance = NULL;
const TCHAR *nativeName;
Tcl_LoadHandle handlePtr;
DWORD firstError;
@@ -75,7 +75,10 @@ TclpDlopen(
*/
nativeName = Tcl_FSGetNativePath(pathPtr);
- hInstance = LoadLibraryEx(nativeName,NULL,LOAD_WITH_ALTERED_SEARCH_PATH);
+ if (nativeName != NULL) {
+ hInstance = LoadLibraryEx(nativeName, NULL,
+ LOAD_WITH_ALTERED_SEARCH_PATH);
+ }
if (hInstance == NULL) {
/*
* Let the OS loader examine the binary search path for whatever
@@ -89,7 +92,8 @@ TclpDlopen(
* Remember the first error on load attempt to be used if the
* second load attempt below also fails.
*/
- firstError = GetLastError();
+ firstError = (nativeName == NULL) ?
+ ERROR_MOD_NOT_FOUND : GetLastError();
nativeName = Tcl_WinUtfToTChar(Tcl_GetString(pathPtr), -1, &ds);
hInstance = LoadLibraryEx(nativeName, NULL,
generated by cgit v0.12 at 2024-10-22 01:58:42 (GMT)