summaryrefslogtreecommitdiffstats
diff options
context:
space:
mode:
Diffstat
-rw-r--r--generic/tclEncoding.c42
-rw-r--r--generic/tclEnv.c1
-rw-r--r--generic/tclInt.h18
-rw-r--r--generic/tclOO.c15
-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/encoding.test28
-rw-r--r--tests/oo.test18
-rw-r--r--unix/Makefile.in4
-rw-r--r--win/tclWinLoad.c10
13 files changed, 139 insertions, 58 deletions
diff --git a/generic/tclEncoding.c b/generic/tclEncoding.c
index 3445548..bf1e02f 100644
--- a/generic/tclEncoding.c
+++ b/generic/tclEncoding.c
@@ -579,7 +579,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;
@@ -867,7 +867,9 @@ FreeEncoding(
if (encodingPtr->hPtr != NULL) {
Tcl_DeleteHashEntry(encodingPtr->hPtr);
}
- ckfree(encodingPtr->name);
+ if (encodingPtr->name) {
+ ckfree(encodingPtr->name);
+ }
ckfree(encodingPtr);
}
}
@@ -1056,9 +1058,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);
@@ -1069,30 +1086,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/tclInt.h b/generic/tclInt.h
index e1651da..dab640b 100644
--- a/generic/tclInt.h
+++ b/generic/tclInt.h
@@ -2446,8 +2446,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.
*/
@@ -2468,9 +2468,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 e9ef2ce..51731d3 100644
--- a/generic/tclOO.c
+++ b/generic/tclOO.c
@@ -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)) {
@@ -1181,7 +1191,8 @@ ObjectNamespaceDeleted(
if ((((Command *)oPtr->command)->flags && CMD_IS_DELETED)) {
/*
* Namespace deletion must have been triggered by a trace on command
- * deletion , meaning that
+ * deletion , meaning that ObjectRenamedTrace() is eventually going
+ * to be called .
*/
deleteAlreadyInProgress = 1;
}
diff --git a/generic/tclTest.c b/generic/tclTest.c
index 47c572f..6366be2 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..e5ce052 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.2-
# 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..d6ecdd6 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.2-]} {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/encoding.test b/tests/encoding.test
index ffac748..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]]
@@ -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/oo.test b/tests/oo.test
index 6413094..b6af1ee 100644
--- a/tests/oo.test
+++ b/tests/oo.test
@@ -1495,6 +1495,24 @@ test oo-11.5 {OO: cleanup} {
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
Aclass create Aobject
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/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-11-16 10:39:03 (GMT)