summaryrefslogtreecommitdiffstats
diff options
context:
space:
mode:
authorjan.nijtmans <nijtmans@users.sourceforge.net>2021-05-26 10:28:11 (GMT)
committerjan.nijtmans <nijtmans@users.sourceforge.net>2021-05-26 10:28:11 (GMT)
commit0e90b5c0cf5d0cf25ebb0ef40f1e014f675b7b0c (patch)
tree9d29cac7c763ccb8b87c00eef67590e467d3ff51
parent15ba6741cfdbedfb264478ebef44ba013cf9fd97 (diff)
parent9d13d5e64b0b91da24a22b1ac9e2d3bc403c433e (diff)
downloadtcl-0e90b5c0cf5d0cf25ebb0ef40f1e014f675b7b0c.zip
tcl-0e90b5c0cf5d0cf25ebb0ef40f1e014f675b7b0c.tar.gz
tcl-0e90b5c0cf5d0cf25ebb0ef40f1e014f675b7b0c.tar.bz2
Merge 8.7. Add "ilp32" build flag
-rw-r--r--.github/workflows/mac-build.yml4
-rw-r--r--.github/workflows/onefiledist.yml28
-rw-r--r--doc/Access.32
-rw-r--r--doc/AddErrInfo.34
-rw-r--r--doc/Backslash.32
-rw-r--r--doc/CrtObjCmd.32
-rw-r--r--doc/Eval.32
-rw-r--r--doc/FileSystem.32
-rw-r--r--doc/GetCwd.36
-rw-r--r--doc/NRE.34
-rw-r--r--doc/ParseArgs.32
-rw-r--r--doc/RegExp.34
-rw-r--r--doc/SplitList.32
-rw-r--r--doc/StringObj.32
-rw-r--r--doc/UniCharIsAlpha.38
-rw-r--r--doc/encoding.n20
-rw-r--r--doc/string.n8
-rw-r--r--generic/tcl.decls3
-rw-r--r--generic/tclBasic.c19
-rw-r--r--generic/tclCmdAH.c2
-rw-r--r--generic/tclCmdMZ.c15
-rw-r--r--generic/tclCompCmdsSZ.c24
-rw-r--r--generic/tclCompile.h3
-rw-r--r--generic/tclDecls.h5
-rw-r--r--generic/tclEncoding.c63
-rw-r--r--generic/tclEnsemble.c4
-rw-r--r--generic/tclEvent.c3
-rw-r--r--generic/tclExecute.c4
-rw-r--r--generic/tclIO.c5
-rw-r--r--generic/tclInt.h29
-rw-r--r--generic/tclLoad.c219
-rw-r--r--generic/tclNamesp.c183
-rw-r--r--generic/tclPosixStr.c6
-rw-r--r--generic/tclStubInit.c1
-rw-r--r--generic/tclTestObj.c3
-rw-r--r--generic/tclUtf.c30
-rw-r--r--generic/tclZipfs.c44
-rw-r--r--library/init.tcl4
-rw-r--r--tests/chanio.test2
-rw-r--r--tests/encoding.test56
-rw-r--r--tests/info.test4
-rw-r--r--tests/io.test6
-rw-r--r--tests/namespace.test114
-rw-r--r--tests/pkgMkIndex.test4
-rw-r--r--tests/regexp.test3
-rw-r--r--tests/regexpComp.test4
-rw-r--r--tests/string.test45
-rw-r--r--tests/winDde.test3
-rw-r--r--unix/Makefile.in16
-rw-r--r--unix/dltest/pkgooa.c7
-rw-r--r--unix/dltest/pkgua.c53
-rw-r--r--unix/tclXtTest.c3
52 files changed, 727 insertions, 364 deletions
diff --git a/.github/workflows/mac-build.yml b/.github/workflows/mac-build.yml
index bf3c420..a57a6cf 100644
--- a/.github/workflows/mac-build.yml
+++ b/.github/workflows/mac-build.yml
@@ -2,7 +2,7 @@ name: macOS
on: [push]
jobs:
xcode:
- runs-on: macos-11.0
+ runs-on: macos-11
defaults:
run:
shell: bash
@@ -24,7 +24,7 @@ jobs:
ERROR_ON_FAILURES: 1
MAC_CI: 1
clang:
- runs-on: macos-11.0
+ runs-on: macos-11
strategy:
matrix:
cfgopt:
diff --git a/.github/workflows/onefiledist.yml b/.github/workflows/onefiledist.yml
index a60428d..f2f6c1e 100644
--- a/.github/workflows/onefiledist.yml
+++ b/.github/workflows/onefiledist.yml
@@ -27,18 +27,18 @@ jobs:
working-directory: unix
- name: Package
run: |
- cp ../unix/tclsh tclsh${TCL_PATCHLEVEL}_unofficial
- chmod +x tclsh${TCL_PATCHLEVEL}_unofficial
- tar -cf tclsh${TCL_PATCHLEVEL}_unofficial.tar tclsh${TCL_PATCHLEVEL}_unofficial
+ cp ../unix/tclsh tclsh${TCL_PATCHLEVEL}_snapshot
+ chmod +x tclsh${TCL_PATCHLEVEL}_snapshot
+ tar -cf tclsh${TCL_PATCHLEVEL}_snapshot.tar tclsh${TCL_PATCHLEVEL}_snapshot
working-directory: 1dist
- name: Upload
uses: actions/upload-artifact@v2
with:
- name: Tclsh ${{ env.TCL_PATCHLEVEL }} Linux single-file build (unofficial)
+ name: Tclsh ${{ env.TCL_PATCHLEVEL }} Linux single-file build (snapshot)
path: 1dist/*.tar
macos:
name: macOS
- runs-on: macos-11.0
+ runs-on: macos-11
defaults:
run:
shell: bash
@@ -74,8 +74,8 @@ jobs:
- name: Package
run: |
mkdir contents
- cp $TCL_BIN contents/tclsh${TCL_PATCHLEVEL}_unofficial
- chmod +x contents/tclsh${TCL_PATCHLEVEL}_unofficial
+ cp $TCL_BIN contents/tclsh${TCL_PATCHLEVEL}_snapshot
+ chmod +x contents/tclsh${TCL_PATCHLEVEL}_snapshot
cat > contents/README.txt <<EOF
This is a single-file executable developer preview of Tcl $TCL_PATCHLEVEL
@@ -83,20 +83,20 @@ jobs:
Use strictly at your own risk.
To run it, you need to copy the executable out and run:
- xattr -d com.apple.quarantine tclsh${TCL_PATCHLEVEL}_unofficial
+ xattr -d com.apple.quarantine tclsh${TCL_PATCHLEVEL}_snapshot
to mark the executable as runnable on your machine.
EOF
$CREATE_DMG \
- --volname "Tcl $TCL_PATCHLEVEL (unofficial)" \
+ --volname "Tcl $TCL_PATCHLEVEL (snapshot)" \
--window-pos 200 120 \
--window-size 800 400 \
- "Tcl-$TCL_PATCHLEVEL-(unofficial).dmg" \
+ "Tcl-$TCL_PATCHLEVEL-(snapshot).dmg" \
"contents/"
working-directory: 1dist
- name: Upload
uses: actions/upload-artifact@v2
with:
- name: Tclsh ${{ env.TCL_PATCHLEVEL }} macOS single-file build (unofficial)
+ name: Tclsh ${{ env.TCL_PATCHLEVEL }} macOS single-file build (snapshot)
path: 1dist/*.dmg
win:
name: Windows
@@ -129,10 +129,10 @@ jobs:
working-directory: win
- name: Set Executable Name
run: |
- cp ../win/tclsh*.exe tclsh${TCL_PATCHLEVEL}_unofficial.exe
+ cp ../win/tclsh*.exe tclsh${TCL_PATCHLEVEL}_snapshot.exe
working-directory: 1dist
- name: Upload
uses: actions/upload-artifact@v2
with:
- name: Tclsh ${{ env.TCL_PATCHLEVEL }} Windows single-file build (unofficial)
- path: '1dist/*_unofficial.exe'
+ name: Tclsh ${{ env.TCL_PATCHLEVEL }} Windows single-file build (snapshot)
+ path: '1dist/*_snapshot.exe'
diff --git a/doc/Access.3 b/doc/Access.3
index 699d7ed..5a29ec2 100644
--- a/doc/Access.3
+++ b/doc/Access.3
@@ -20,7 +20,7 @@ int
\fBTcl_Stat\fR(\fIpath\fR, \fIstatPtr\fR)
.SH ARGUMENTS
.AS "struct stat" *statPtr out
-.AP char *path in
+.AP "const char" *path in
Native name of the file to check the attributes of.
.AP int mode in
Mask consisting of one or more of \fBR_OK\fR, \fBW_OK\fR, \fBX_OK\fR and
diff --git a/doc/AddErrInfo.3 b/doc/AddErrInfo.3
index d04b4c9..53f134a 100644
--- a/doc/AddErrInfo.3
+++ b/doc/AddErrInfo.3
@@ -49,7 +49,7 @@ Interpreter in which to record information.
The code returned from script evaluation.
.AP Tcl_Obj *options
A dictionary of return options.
-.AP char *message in
+.AP "const char" *message in
For \fBTcl_AddErrorInfo\fR,
this is a conventional C string to append to the \fB\-errorinfo\fR return option.
For \fBTcl_AddObjErrorInfo\fR,
@@ -66,7 +66,7 @@ appending to the \fB\-errorinfo\fR return option.
If negative, all bytes up to the first null byte are used.
.AP Tcl_Obj *errorObjPtr in
The \fB\-errorcode\fR return option will be set to this value.
-.AP char *element in
+.AP "const char" *element in
String to record as one element of the \fB\-errorcode\fR return option.
Last \fIelement\fR argument must be NULL.
.AP va_list argList in
diff --git a/doc/Backslash.3 b/doc/Backslash.3
index 0805f8e..1a807f6 100644
--- a/doc/Backslash.3
+++ b/doc/Backslash.3
@@ -18,7 +18,7 @@ char
\fBTcl_Backslash\fR(\fIsrc, countPtr\fR)
.SH ARGUMENTS
.AS char *countPtr out
-.AP char *src in
+.AP "const char" *src in
Pointer to a string starting with a backslash.
.AP int *countPtr out
If \fIcountPtr\fR is not NULL, \fI*countPtr\fR gets filled
diff --git a/doc/CrtObjCmd.3 b/doc/CrtObjCmd.3
index 59b217e..f15e277 100644
--- a/doc/CrtObjCmd.3
+++ b/doc/CrtObjCmd.3
@@ -54,7 +54,7 @@ const char *
.AS Tcl_CmdDeleteProc *deleteProc in/out
.AP Tcl_Interp *interp in
Interpreter in which to create a new command or that contains a command.
-.AP char *cmdName in
+.AP "const char" *cmdName in
Name of command.
.AP Tcl_ObjCmdProc *proc in
Implementation of the new command: \fIproc\fR will be called whenever
diff --git a/doc/Eval.3 b/doc/Eval.3
index 2769595..5929a83 100644
--- a/doc/Eval.3
+++ b/doc/Eval.3
@@ -65,7 +65,7 @@ null terminating character. If \-1, then all characters up to the
first null byte are used.
.AP "const char" *script in
Points to first byte of script to execute (null-terminated and UTF-8).
-.AP char *part in
+.AP "const char" *part in
String forming part of a Tcl script.
.AP va_list argList in
An argument list which must have been initialized using
diff --git a/doc/FileSystem.3 b/doc/FileSystem.3
index 4e901e0..4951ec5 100644
--- a/doc/FileSystem.3
+++ b/doc/FileSystem.3
@@ -1745,7 +1745,7 @@ to it should be retained.
.
If \fItoPtr\fR is NULL, this should return a value with reference count 1 that
has just been allocated and passed to \fBTcl_IncrRefCount\fR. If \fItoPtr\fR
-is not NULL, it should be returned on success.
+is not NULL, it should be returned on success.
.TP
\fIlistVolumesProc\fR
.
diff --git a/doc/GetCwd.3 b/doc/GetCwd.3
index f4f37a1..b19f587 100644
--- a/doc/GetCwd.3
+++ b/doc/GetCwd.3
@@ -17,7 +17,7 @@ char *
\fBTcl_GetCwd\fR(\fIinterp\fR, \fIbufferPtr\fR)
.sp
int
-\fBTcl_Chdir\fR(\fIpath\fR)
+\fBTcl_Chdir\fR(\fIdirName\fR)
.SH ARGUMENTS
.AS Tcl_DString *bufferPtr in/out
.AP Tcl_Interp *interp in
@@ -27,7 +27,7 @@ This dynamic string is used to store the current working directory.
At the time of the call it should be uninitialized or free. The
caller must eventually call \fBTcl_DStringFree\fR to free up
anything stored here.
-.AP char *path in
+.AP "const char" *dirName in
File path in UTF\-8 format.
.BE
@@ -45,7 +45,7 @@ must call \fBTcl_DStringFree()\fR when the result is no longer needed.
The format of the path is UTF\-8.
.PP
\fBTcl_Chdir\fR changes the applications current working directory to
-the value specified in \fIpath\fR. The format of the passed in string
+the value specified in \fIdirName\fR. The format of the passed in string
must be UTF\-8. The function returns -1 on error or 0 on success.
.SH KEYWORDS
diff --git a/doc/NRE.3 b/doc/NRE.3
index 011e100..72bb370 100644
--- a/doc/NRE.3
+++ b/doc/NRE.3
@@ -40,7 +40,7 @@ void
.AS Tcl_CmdDeleteProc *interp in
.AP Tcl_Interp *interp in
The relevant Interpreter.
-.AP char *cmdName in
+.AP "const char" *cmdName in
Name of the command to create.
.AP Tcl_ObjCmdProc *proc in
Called in order to evaluate a command. Is often just a small wrapper that uses
@@ -245,7 +245,7 @@ Use \fBTcl_NRAddCallback\fR to schedule any required final decrementing of the
reference counts of arguments to any of the other functions on this page, as
with any other post-processing step in the non-recursive execution engine.
.PP
-The
+The
.SH "SEE ALSO"
Tcl_CreateCommand(3), Tcl_CreateObjCommand(3), Tcl_EvalObjEx(3), Tcl_GetCommandFromObj(3), Tcl_ExprObj(3)
.SH KEYWORDS
diff --git a/doc/ParseArgs.3 b/doc/ParseArgs.3
index 5ca9fa5..f29f161 100644
--- a/doc/ParseArgs.3
+++ b/doc/ParseArgs.3
@@ -191,7 +191,7 @@ came from, and so should be copied if it needs to be retained. The
\fIsrcPtr\fR and \fIclientData\fR fields are ignored.
.SH "REFERENCE COUNT MANAGEMENT"
.PP
-The values in the \fiobjv\fR argument to \fBTcl_ParseArgsObjv\fR will not have
+The values in the \fIobjv\fR argument to \fBTcl_ParseArgsObjv\fR will not have
their reference counts modified by this function. The interpreter result may
be modified on error; the values passed should not be the interpreter result
with no further reference added.
diff --git a/doc/RegExp.3 b/doc/RegExp.3
index 0d60b8a..40429c9 100644
--- a/doc/RegExp.3
+++ b/doc/RegExp.3
@@ -51,14 +51,14 @@ can be efficiently searched.
.AP Tcl_Obj *patObj in/out
Refers to the value from which to get a regular expression. The
compiled regular expression is cached in the value.
-.AP char *text in
+.AP "const char" *text in
Text to search for a match with a regular expression.
.AP "const char" *pattern in
String in the form of a regular expression pattern.
.AP Tcl_RegExp regexp in
Compiled regular expression. Must have been returned previously
by \fBTcl_GetRegExpFromObj\fR or \fBTcl_RegExpCompile\fR.
-.AP char *start in
+.AP "const char" *start in
If \fItext\fR is just a portion of some other string, this argument
identifies the beginning of the larger string.
If it is not the same as \fItext\fR, then no
diff --git a/doc/SplitList.3 b/doc/SplitList.3
index d19ca14..863e322 100644
--- a/doc/SplitList.3
+++ b/doc/SplitList.3
@@ -36,7 +36,7 @@ int
.AP Tcl_Interp *interp out
Interpreter to use for error reporting. If NULL, then no error message
is left.
-.AP char *list in
+.AP "const char" *list in
Pointer to a string with proper list structure.
.AP int *argcPtr out
Filled in with number of elements in \fIlist\fR.
diff --git a/doc/StringObj.3 b/doc/StringObj.3
index 22e872a..772073e 100644
--- a/doc/StringObj.3
+++ b/doc/StringObj.3
@@ -385,7 +385,7 @@ cleaner-looking. \fBTcl_ConcatObj\fR returns a pointer to a
newly-created value whose ref count is zero.
.SH "REFERENCE COUNT MANAGEMENT"
.PP
-\fBTcl_NewStringObj\fR, \fBTcl_NewUnicodeObj\fB, \fBTcl_Format\fR,
+\fBTcl_NewStringObj\fR, \fBTcl_NewUnicodeObj\fR, \fBTcl_Format\fR,
\fBTcl_ObjPrintf\fR, and \fBTcl_ConcatObj\fR always return a zero-reference
object, much like \fBTcl_NewObj\fR.
.PP
diff --git a/doc/UniCharIsAlpha.3 b/doc/UniCharIsAlpha.3
index 61490ed..a07af9a 100644
--- a/doc/UniCharIsAlpha.3
+++ b/doc/UniCharIsAlpha.3
@@ -8,7 +8,7 @@
.so man.macros
.BS
.SH NAME
-Tcl_UniCharIsAlnum, Tcl_UniCharIsAlpha, Tcl_UniCharIsControl, Tcl_UniCharIsDigit, Tcl_UniCharIsGraph, Tcl_UniCharIsLower, Tcl_UniCharIsPrint, Tcl_UniCharIsPunct, Tcl_UniCharIsSpace, Tcl_UniCharIsUpper, Tcl_UniCharIsWordChar \- routines for classification of Tcl_UniChar characters
+Tcl_UniCharIsAlnum, Tcl_UniCharIsAlpha, Tcl_UniCharIsControl, Tcl_UniCharIsDigit, Tcl_UniCharIsGraph, Tcl_UniCharIsLower, Tcl_UniCharIsPrint, Tcl_UniCharIsPunct, Tcl_UniCharIsSpace, Tcl_UniCharIsUpper, Tcl_UniCharIsUnicode, Tcl_UniCharIsWordChar \- routines for classification of Tcl_UniChar characters
.SH SYNOPSIS
.nf
\fB#include <tcl.h>\fR
@@ -44,6 +44,9 @@ int
\fBTcl_UniCharIsUpper\fR(\fIch\fR)
.sp
int
+\fBTcl_UniCharIsUnicode\fR(\fIch\fR)
+.sp
+int
\fBTcl_UniCharIsWordChar\fR(\fIch\fR)
.SH ARGUMENTS
.AS int ch
@@ -81,6 +84,9 @@ with the various routines.
.PP
\fBTcl_UniCharIsUpper\fR tests if the character is an uppercase Unicode character.
.PP
+\fBTcl_UniCharIsUnicode\fR tests if the character is a Unicode character, not being
+a surrogate or noncharacter.
+.PP
\fBTcl_UniCharIsWordChar\fR tests if the character is alphanumeric or
a connector punctuation mark.
diff --git a/doc/encoding.n b/doc/encoding.n
index 5aac181..e78a8e7 100644
--- a/doc/encoding.n
+++ b/doc/encoding.n
@@ -81,29 +81,13 @@ omitted then the command returns the current system encoding. The
system encoding is used whenever Tcl passes strings to system calls.
.SH EXAMPLE
.PP
-It is common practice to write script files using a text editor that
-produces output in the euc-jp encoding, which represents the ASCII
-characters as singe bytes and Japanese characters as two bytes. This
-makes it easy to embed literal strings that correspond to non-ASCII
-characters by simply typing the strings in place in the script.
-However, because the \fBsource\fR command always reads files using the
-current system encoding, Tcl will only source such files correctly
-when the encoding used to write the file is the same. This tends not
-to be true in an internationalized setting. For example, if such a
-file was sourced in North America (where the ISO8859\-1 is normally
-used), each byte in the file would be treated as a separate character
-that maps to the 00 page in Unicode. The resulting Tcl strings will
-not contain the expected Japanese characters. Instead, they will
-contain a sequence of Latin-1 characters that correspond to the bytes
-of the original string. The \fBencoding\fR command can be used to
-convert this string to the expected Japanese Unicode characters. For
-example,
+The following example converts a byte sequence in Japanese euc-jp encoding to a TCL string:
.PP
.CS
set s [\fBencoding convertfrom\fR euc-jp "\exA4\exCF"]
.CE
.PP
-would return the Unicode string
+The result is the unicode codepoint:
.QW "\eu306F" ,
which is the Hiragana letter HA.
.SH "SEE ALSO"
diff --git a/doc/string.n b/doc/string.n
index 7413e6b..f3d7616 100644
--- a/doc/string.n
+++ b/doc/string.n
@@ -413,10 +413,10 @@ store the representation is of very low value (except to C extension
code, which has direct access for the purpose of memory management,
etc.)
.PP
-\fICompatibility note:\fR it is likely that this subcommand will be
-withdrawn in a future version of Tcl. It is better to use the
-\fBencoding convertto\fR command to convert a string to a known
-encoding and then apply \fBstring length\fR to that.
+\fICompatibility note:\fR This subcommand is deprecated and will
+be removed in Tcl 9.0. It is better to use the \fBencoding convertto\fR
+command to convert a string to a known encoding (e.g. "utf-8" or "cesu-8")
+and then apply \fBstring length\fR to that.
.PP
.CS
\fBstring length\fR [encoding convertto utf-8 $theString]
diff --git a/generic/tcl.decls b/generic/tcl.decls
index 08800f0..9d030e0 100644
--- a/generic/tcl.decls
+++ b/generic/tcl.decls
@@ -2423,6 +2423,9 @@ declare 655 {
declare 656 {
const char *Tcl_UtfPrev(const char *src, const char *start)
}
+declare 657 {
+ int Tcl_UniCharIsUnicode(int ch)
+}
# ----- BASELINE -- FOR -- 8.7.0 ----- #
diff --git a/generic/tclBasic.c b/generic/tclBasic.c
index 833101c..f083c37 100644
--- a/generic/tclBasic.c
+++ b/generic/tclBasic.c
@@ -1826,28 +1826,28 @@ DeleteInterpProc(
ckfree(hTablePtr);
}
- /*
- * Invoke deletion callbacks; note that a callback can create new
- * callbacks, so we iterate.
- */
- while (iPtr->assocData != NULL) {
+ if (iPtr->assocData != NULL) {
AssocData *dPtr;
hTablePtr = iPtr->assocData;
- iPtr->assocData = NULL;
+ /*
+ * Invoke deletion callbacks; note that a callback can create new
+ * callbacks, so we iterate.
+ */
for (hPtr = Tcl_FirstHashEntry(hTablePtr, &search);
hPtr != NULL;
hPtr = Tcl_FirstHashEntry(hTablePtr, &search)) {
dPtr = (AssocData *)Tcl_GetHashValue(hPtr);
- Tcl_DeleteHashEntry(hPtr);
if (dPtr->proc != NULL) {
dPtr->proc(dPtr->clientData, interp);
}
+ Tcl_DeleteHashEntry(hPtr);
ckfree(dPtr);
}
Tcl_DeleteHashTable(hTablePtr);
ckfree(hTablePtr);
+ iPtr->assocData = NULL;
}
/*
@@ -3505,15 +3505,14 @@ Tcl_DeleteCommandFromToken(
cmdPtr->flags |= CMD_DYING;
/*
- * Call trace functions for the command being deleted. Then delete its
- * traces.
+ * Call each functions and then delete the trace.
*/
cmdPtr->nsPtr->refCount++;
if (cmdPtr->tracePtr != NULL) {
CommandTrace *tracePtr;
- /* Note that CallCommandTraces() never frees cmdPtr, that's
+ /* CallCommandTraces() does not cmdPtr, that's
* done just before Tcl_DeleteCommandFromToken() returns */
CallCommandTraces(iPtr,cmdPtr,NULL,NULL,TCL_TRACE_DELETE);
diff --git a/generic/tclCmdAH.c b/generic/tclCmdAH.c
index c09ad95..8e6200d 100644
--- a/generic/tclCmdAH.c
+++ b/generic/tclCmdAH.c
@@ -613,8 +613,6 @@ EncodingConverttoObjCmd(
int length; /* Length of the string being converted */
const char *stringPtr; /* Pointer to the first byte of the string */
- /* TODO - ADJUST OBJ INDICES WHEN ENSEMBLIFYING THIS */
-
if (objc == 2) {
encoding = Tcl_GetEncoding(interp, NULL);
data = objv[1];
diff --git a/generic/tclCmdMZ.c b/generic/tclCmdMZ.c
index d020a93..6f71198 100644
--- a/generic/tclCmdMZ.c
+++ b/generic/tclCmdMZ.c
@@ -1533,16 +1533,16 @@ StringIsCmd(
"boolean", "dict", "digit", "double",
"entier", "false", "graph", "integer",
"list", "lower", "print", "punct",
- "space", "true", "upper", "wideinteger",
- "wordchar", "xdigit", NULL
+ "space", "true", "upper", "unicode",
+ "wideinteger", "wordchar", "xdigit", NULL
};
enum isClassesEnum {
STR_IS_ALNUM, STR_IS_ALPHA, STR_IS_ASCII, STR_IS_CONTROL,
STR_IS_BOOL, STR_IS_DICT, STR_IS_DIGIT, STR_IS_DOUBLE,
STR_IS_ENTIER, STR_IS_FALSE, STR_IS_GRAPH, STR_IS_INT,
STR_IS_LIST, STR_IS_LOWER, STR_IS_PRINT, STR_IS_PUNCT,
- STR_IS_SPACE, STR_IS_TRUE, STR_IS_UPPER, STR_IS_WIDE,
- STR_IS_WORD, STR_IS_XDIGIT
+ STR_IS_SPACE, STR_IS_TRUE, STR_IS_UPPER, STR_IS_UNICODE,
+ STR_IS_WIDE, STR_IS_WORD, STR_IS_XDIGIT
};
static const char *const isOptions[] = {
"-strict", "-failindex", NULL
@@ -1872,6 +1872,9 @@ StringIsCmd(
case STR_IS_UPPER:
chcomp = Tcl_UniCharIsUpper;
break;
+ case STR_IS_UNICODE:
+ chcomp = Tcl_UniCharIsUnicode;
+ break;
case STR_IS_WORD:
chcomp = Tcl_UniCharIsWordChar;
break;
@@ -2832,6 +2835,7 @@ StringCatCmd(
*
*----------------------------------------------------------------------
*/
+#if TCL_MAJOR_VERSION < 9 && !defined(TCL_NO_DEPRECATED)
static int
StringBytesCmd(
TCL_UNUSED(ClientData),
@@ -2850,6 +2854,7 @@ StringBytesCmd(
Tcl_SetObjResult(interp, Tcl_NewWideIntObj(length));
return TCL_OK;
}
+#endif
/*
*----------------------------------------------------------------------
@@ -3306,7 +3311,9 @@ TclInitStringCmd(
Tcl_Interp *interp) /* Current interpreter. */
{
static const EnsembleImplMap stringImplMap[] = {
+#if TCL_MAJOR_VERSION < 9 && !defined(TCL_NO_DEPRECATED)
{"bytelength", StringBytesCmd, TclCompileBasic1ArgCmd, NULL, NULL, 0},
+#endif
{"cat", StringCatCmd, TclCompileStringCatCmd, NULL, NULL, 0},
{"compare", StringCmpCmd, TclCompileStringCmpCmd, NULL, NULL, 0},
{"equal", StringEqualCmd, TclCompileStringEqualCmd, NULL, NULL, 0},
diff --git a/generic/tclCompCmdsSZ.c b/generic/tclCompCmdsSZ.c
index 0bac52b..a160625 100644
--- a/generic/tclCompCmdsSZ.c
+++ b/generic/tclCompCmdsSZ.c
@@ -505,19 +505,19 @@ TclCompileStringIsCmd(
Tcl_Token *tokenPtr = TokenAfter(parsePtr->tokenPtr);
static const char *const isClasses[] = {
"alnum", "alpha", "ascii", "control",
- "boolean", "dict", "digit", "double", "entier",
- "false", "graph", "integer", "list",
- "lower", "print", "punct", "space",
- "true", "upper", "wideinteger", "wordchar",
- "xdigit", NULL
+ "boolean", "dict", "digit", "double",
+ "entier", "false", "graph", "integer",
+ "list", "lower", "print", "punct",
+ "space", "true", "upper", "unicode",
+ "wideinteger", "wordchar", "xdigit", NULL
};
enum isClassesEnum {
STR_IS_ALNUM, STR_IS_ALPHA, STR_IS_ASCII, STR_IS_CONTROL,
- STR_IS_BOOL, STR_IS_DICT, STR_IS_DIGIT, STR_IS_DOUBLE, STR_IS_ENTIER,
- STR_IS_FALSE, STR_IS_GRAPH, STR_IS_INT, STR_IS_LIST,
- STR_IS_LOWER, STR_IS_PRINT, STR_IS_PUNCT, STR_IS_SPACE,
- STR_IS_TRUE, STR_IS_UPPER, STR_IS_WIDE, STR_IS_WORD,
- STR_IS_XDIGIT
+ STR_IS_BOOL, STR_IS_DICT, STR_IS_DIGIT, STR_IS_DOUBLE,
+ STR_IS_ENTIER, STR_IS_FALSE, STR_IS_GRAPH, STR_IS_INT,
+ STR_IS_LIST, STR_IS_LOWER, STR_IS_PRINT, STR_IS_PUNCT,
+ STR_IS_SPACE, STR_IS_TRUE, STR_IS_UPPER, STR_IS_UNICODE,
+ STR_IS_WIDE, STR_IS_WORD, STR_IS_XDIGIT
};
int t, range, allowEmpty = 0, end;
InstStringClassType strClassType;
@@ -609,6 +609,9 @@ TclCompileStringIsCmd(
case STR_IS_UPPER:
strClassType = STR_CLASS_UPPER;
goto compileStrClass;
+ case STR_IS_UNICODE:
+ strClassType = STR_CLASS_UNICODE;
+ goto compileStrClass;
case STR_IS_WORD:
strClassType = STR_CLASS_WORD;
goto compileStrClass;
@@ -1415,6 +1418,7 @@ StringClassDesc const tclStringClassTable[] = {
{"upper", Tcl_UniCharIsUpper},
{"word", Tcl_UniCharIsWordChar},
{"xdigit", UniCharIsHexDigit},
+ {"unicode", Tcl_UniCharIsUnicode},
{"", NULL}
};
diff --git a/generic/tclCompile.h b/generic/tclCompile.h
index 21a27f7..6a5faaf 100644
--- a/generic/tclCompile.h
+++ b/generic/tclCompile.h
@@ -922,8 +922,9 @@ typedef enum InstStringClassType {
STR_CLASS_UPPER, /* Unicode upper-case alphabet characters. */
STR_CLASS_WORD, /* Unicode word (alphabetic, digit, connector
* punctuation) characters. */
- STR_CLASS_XDIGIT /* Characters that can be used as digits in
+ STR_CLASS_XDIGIT, /* Characters that can be used as digits in
* hexadecimal numbers ([0-9A-Fa-f]). */
+ STR_CLASS_UNICODE /* Unicode characters. */
} InstStringClassType;
typedef struct StringClassDesc {
diff --git a/generic/tclDecls.h b/generic/tclDecls.h
index 83ed09f..8b9aeee 100644
--- a/generic/tclDecls.h
+++ b/generic/tclDecls.h
@@ -1937,6 +1937,8 @@ EXTERN int Tcl_UtfCharComplete(const char *src, int length);
EXTERN const char * Tcl_UtfNext(const char *src);
/* 656 */
EXTERN const char * Tcl_UtfPrev(const char *src, const char *start);
+/* 657 */
+EXTERN int Tcl_UniCharIsUnicode(int ch);
typedef struct {
const struct TclPlatStubs *tclPlatStubs;
@@ -2629,6 +2631,7 @@ typedef struct TclStubs {
int (*tcl_UtfCharComplete) (const char *src, int length); /* 654 */
const char * (*tcl_UtfNext) (const char *src); /* 655 */
const char * (*tcl_UtfPrev) (const char *src, const char *start); /* 656 */
+ int (*tcl_UniCharIsUnicode) (int ch); /* 657 */
} TclStubs;
extern const TclStubs *tclStubsPtr;
@@ -3971,6 +3974,8 @@ extern const TclStubs *tclStubsPtr;
(tclStubsPtr->tcl_UtfNext) /* 655 */
#define Tcl_UtfPrev \
(tclStubsPtr->tcl_UtfPrev) /* 656 */
+#define Tcl_UniCharIsUnicode \
+ (tclStubsPtr->tcl_UniCharIsUnicode) /* 657 */
#endif /* defined(USE_TCL_STUBS) */
diff --git a/generic/tclEncoding.c b/generic/tclEncoding.c
index 8c4897e..d6c280f 100644
--- a/generic/tclEncoding.c
+++ b/generic/tclEncoding.c
@@ -510,11 +510,12 @@ FillEncodingFileMap(void)
*---------------------------------------------------------------------------
*/
-/* This flags must not conflict with other TCL_ENCODING_* flags in tcl.h */
+/* Those flags must not conflict with other TCL_ENCODING_* flags in tcl.h */
+/* Since TCL_ENCODING_MODIFIED is only used for utf-8/cesu-8 and
+ * TCL_ENCODING_LE is only used for utf-16/ucs-2. re-use the same value */
#define TCL_ENCODING_MODIFIED 0x20 /* Converting NULL bytes to 0xC0 0x80 */
-/* Since TCL_ENCODING_MODIFIED is only used for utf-8 and
- * TCL_ENCODING_LE is only used for utf-16/ucs-2, re-use the same value */
#define TCL_ENCODING_LE TCL_ENCODING_MODIFIED /* Little-endian encoding */
+#define TCL_ENCODING_UTF 0x200 /* For UTF-8 encoding, allow 4-byte output sequences */
void
TclInitEncodingSubsystem(void)
@@ -556,7 +557,10 @@ TclInitEncodingSubsystem(void)
type.fromUtfProc = UtfToUtfProc;
type.freeProc = NULL;
type.nullSize = 1;
- type.clientData = NULL;
+ type.clientData = INT2PTR(TCL_ENCODING_UTF);
+ Tcl_CreateEncoding(&type);
+ type.clientData = INT2PTR(0);
+ type.encodingName = "cesu-8";
Tcl_CreateEncoding(&type);
type.toUtfProc = Utf16ToUtfProc;
@@ -1141,7 +1145,7 @@ Tcl_ExternalToUtfDString(
flags = TCL_ENCODING_START | TCL_ENCODING_END;
if (encodingPtr->toUtfProc == UtfToUtfProc) {
- flags |= TCL_ENCODING_MODIFIED;
+ flags |= TCL_ENCODING_MODIFIED | TCL_ENCODING_UTF;
}
while (1) {
@@ -1258,7 +1262,7 @@ Tcl_ExternalToUtf(
dstLen--;
}
if (encodingPtr->toUtfProc == UtfToUtfProc) {
- flags |= TCL_ENCODING_MODIFIED;
+ flags |= TCL_ENCODING_MODIFIED | TCL_ENCODING_UTF;
}
do {
Tcl_EncodingState savedState = *statePtr;
@@ -1337,6 +1341,7 @@ Tcl_UtfToExternalDString(
&srcRead, &dstWrote, &dstChars);
soFar = dst + dstWrote - Tcl_DStringValue(dstPtr);
+ src += srcRead;
if (result != TCL_CONVERT_NOSPACE) {
if (encodingPtr->nullSize == 2) {
Tcl_DStringSetLength(dstPtr, soFar + 1);
@@ -1346,7 +1351,6 @@ Tcl_UtfToExternalDString(
}
flags &= ~TCL_ENCODING_START;
- src += srcRead;
srcLen -= srcRead;
if (Tcl_DStringLength(dstPtr) == 0) {
Tcl_DStringSetLength(dstPtr, dstLen);
@@ -2216,7 +2220,7 @@ UtfToUtfProc(
dstStart = dst;
flags |= PTR2INT(clientData);
- dstEnd = dst + dstLen - TCL_UTF_MAX;
+ dstEnd = dst + dstLen - ((flags & TCL_ENCODING_UTF) ? TCL_UTF_MAX : 6);
for (numChars = 0; src < srcEnd && numChars <= charLimit; numChars++) {
if ((src > srcClose) && (!Tcl_UtfCharComplete(src, srcEnd - src))) {
@@ -2269,6 +2273,7 @@ UtfToUtfProc(
dst += Tcl_UniCharToUtf(ch, dst);
} else {
int low;
+ const char *saveSrc = src;
size_t len = TclUtfToUCS4(src, &ch);
if ((len < 2) && (ch != 0) && (flags & TCL_ENCODING_STOPONERROR)
&& (flags & TCL_ENCODING_MODIFIED)) {
@@ -2276,7 +2281,17 @@ UtfToUtfProc(
break;
}
src += len;
- if ((ch | 0x7FF) == 0xDFFF) {
+ if (!(flags & TCL_ENCODING_UTF)) {
+ if (ch > 0xFFFF) {
+ /* CESU-8 6-byte sequence for chars > U+FFFF */
+ ch -= 0x10000;
+ *dst++ = 0xED;
+ *dst++ = (char) (((ch >> 16) & 0x0F) | 0xA0);
+ *dst++ = (char) (((ch >> 10) & 0x3F) | 0x80);
+ ch = (ch & 0x0CFF) | 0xDC00;
+ }
+ goto cesu8;
+ } else if ((ch | 0x7FF) == 0xDFFF) {
/*
* A surrogate character is detected, handle especially.
*/
@@ -2285,6 +2300,15 @@ UtfToUtfProc(
len = (src <= srcEnd-3) ? TclUtfToUCS4(src, &low) : 0;
if (((low & ~0x3FF) != 0xDC00) || (ch & 0x400)) {
+ if (flags & TCL_ENCODING_STOPONERROR) {
+ result = TCL_CONVERT_UNKNOWN;
+ src = saveSrc;
+ break;
+ }
+ if (!(flags & TCL_ENCODING_MODIFIED)) {
+ ch = 0xFFFD;
+ }
+ cesu8:
*dst++ = (char) (((ch >> 12) | 0xE0) & 0xEF);
*dst++ = (char) (((ch >> 6) | 0x80) & 0xBF);
*dst++ = (char) ((ch | 0x80) & 0xBF);
@@ -2293,6 +2317,15 @@ UtfToUtfProc(
src += len;
dst += Tcl_UniCharToUtf(ch, dst);
ch = low;
+ } else if (!Tcl_UniCharIsUnicode(ch)) {
+ if (flags & TCL_ENCODING_STOPONERROR) {
+ result = TCL_CONVERT_UNKNOWN;
+ src = saveSrc;
+ break;
+ }
+ if (!(flags & TCL_ENCODING_MODIFIED)) {
+ ch = 0xFFFD;
+ }
}
dst += Tcl_UniCharToUtf(ch, dst);
}
@@ -2451,7 +2484,7 @@ UtfToUtf16Proc(
{
const char *srcStart, *srcEnd, *srcClose, *dstStart, *dstEnd;
int result, numChars;
- int ch;
+ int ch, len;
srcStart = src;
srcEnd = src + srcLen;
@@ -2479,7 +2512,15 @@ UtfToUtf16Proc(
result = TCL_CONVERT_NOSPACE;
break;
}
- src += TclUtfToUCS4(src, &ch);
+ len = TclUtfToUCS4(src, &ch);
+ if (!Tcl_UniCharIsUnicode(ch)) {
+ if (flags & TCL_ENCODING_STOPONERROR) {
+ result = TCL_CONVERT_UNKNOWN;
+ break;
+ }
+ ch = 0xFFFD;
+ }
+ src += len;
if (flags & TCL_ENCODING_LE) {
if (ch <= 0xFFFF) {
*dst++ = (ch & 0xFF);
diff --git a/generic/tclEnsemble.c b/generic/tclEnsemble.c
index 929f3ef..ccd43b9 100644
--- a/generic/tclEnsemble.c
+++ b/generic/tclEnsemble.c
@@ -165,7 +165,7 @@ TclNamespaceEnsembleCmd(
const char *simpleName;
int index, done;
- if (nsPtr == NULL || nsPtr->flags & NS_DYING) {
+ if (nsPtr == NULL || nsPtr->flags & NS_DEAD) {
if (!Tcl_InterpDeleted(interp)) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"tried to manipulate ensemble of deleted namespace",
@@ -1730,7 +1730,7 @@ NsEnsembleImplementationCmdNR(
return TCL_ERROR;
}
- if (ensemblePtr->nsPtr->flags & NS_DYING) {
+ if (ensemblePtr->nsPtr->flags & NS_DEAD) {
/*
* Don't know how we got here, but make things give up quickly.
*/
diff --git a/generic/tclEvent.c b/generic/tclEvent.c
index f851c8a..6096323 100644
--- a/generic/tclEvent.c
+++ b/generic/tclEvent.c
@@ -1105,6 +1105,9 @@ Tcl_InitSubsystems(void)
#endif
STRINGIFY(__GNUC_MINOR__)
#endif
+#if (defined(_WIN32) && !defined(_WIN64)) || (ULONG_MAX == 0xffffffffUL)
+ ".ilp32"
+#endif
#ifdef TCL_MEM_DEBUG
".memdebug"
#endif
diff --git a/generic/tclExecute.c b/generic/tclExecute.c
index 55bc314..debb06e 100644
--- a/generic/tclExecute.c
+++ b/generic/tclExecute.c
@@ -5744,7 +5744,7 @@ TEBCresume(
{
ClientData ptr1, ptr2;
int type1, type2;
- Tcl_WideInt w1, w2, wResult;
+ Tcl_WideInt w1 = 0, w2, wResult;
case INST_NUM_TYPE:
if (GetNumberFromObj(NULL, OBJ_AT_TOS, &ptr1, &type1) != TCL_OK) {
@@ -8817,7 +8817,7 @@ ExecuteExtendedUnaryMathOp(
int opcode, /* What operation to perform. */
Tcl_Obj *valuePtr) /* The operand on the stack. */
{
- ClientData ptr;
+ ClientData ptr = NULL;
int type;
Tcl_WideInt w;
mp_int big;
diff --git a/generic/tclIO.c b/generic/tclIO.c
index b9ec2a7..d704d29 100644
--- a/generic/tclIO.c
+++ b/generic/tclIO.c
@@ -4321,6 +4321,7 @@ Write(
/* State info for channel */
char *nextNewLine = NULL;
int endEncoding, saved = 0, total = 0, flushed = 0, needNlFlush = 0;
+ char safe[BUFFER_PADDING];
if (srcLen) {
WillWrite(chanPtr);
@@ -4339,7 +4340,7 @@ Write(
while (srcLen + saved + endEncoding > 0) {
ChannelBuffer *bufPtr;
- char *dst, safe[BUFFER_PADDING];
+ char *dst;
int result, srcRead, dstLen, dstWrote, srcLimit = srcLen;
if (nextNewLine) {
@@ -4384,7 +4385,7 @@ Write(
ReleaseChannelBuffer(bufPtr);
if (total == 0) {
- Tcl_SetErrno(EINVAL);
+ Tcl_SetErrno(EILSEQ);
return -1;
}
break;
diff --git a/generic/tclInt.h b/generic/tclInt.h
index b8ed3c1..ad9a5c1 100644
--- a/generic/tclInt.h
+++ b/generic/tclInt.h
@@ -415,29 +415,27 @@ struct NamespacePathEntry {
* Flags used to represent the status of a namespace:
*
* NS_DYING - 1 means Tcl_DeleteNamespace has been called to delete the
- * namespace but there are still active call frames on the Tcl
+ * namespace. There may still be active call frames on the Tcl
* stack that refer to the namespace. When the last call frame
- * referring to it has been popped, it's variables and command
- * will be destroyed and it will be marked "dead" (NS_DEAD). The
- * namespace can no longer be looked up by name.
+ * referring to it has been popped, its remaining variables and
+ * commands are destroyed and it is marked "dead" (NS_DEAD).
+ * NS_TEARDOWN -1 means that TclTeardownNamespace has already been called on
+ * this namespace and it should not be called again [Bug 1355942].
* NS_DEAD - 1 means Tcl_DeleteNamespace has been called to delete the
- * namespace and no call frames still refer to it. Its variables
- * and command have already been destroyed. This bit allows the
- * namespace resolution code to recognize that the namespace is
- * "deleted". When the last namespaceName object in any byte code
- * unit that refers to the namespace has been freed (i.e., when
- * the namespace's refCount is 0), the namespace's storage will
- * be freed.
- * NS_KILLED - 1 means that TclTeardownNamespace has already been called on
- * this namespace and it should not be called again [Bug 1355942]
+ * namespace and no call frames still refer to it. It is no longer
+ * accessible by name. Its variables and commands have already
+ * been destroyed. When the last namespaceName object in any byte
+ * code unit that refers to the namespace has been freed (i.e.,
+ * when the namespace's refCount is 0), the namespace's storage
+ * will be freed.
* NS_SUPPRESS_COMPILATION -
* Marks the commands in this namespace for not being compiled,
* forcing them to be looked up every time.
*/
#define NS_DYING 0x01
-#define NS_DEAD 0x02
-#define NS_KILLED 0x04
+#define NS_TEARDOWN 0x02
+#define NS_DEAD 0x04
#define NS_SUPPRESS_COMPILATION 0x08
/*
@@ -2958,6 +2956,7 @@ MODULE_SCOPE Tcl_Command TclCreateEnsembleInNs(Tcl_Interp *interp,
const char *name, Tcl_Namespace *nameNamespacePtr,
Tcl_Namespace *ensembleNamespacePtr, int flags);
MODULE_SCOPE void TclDeleteNamespaceVars(Namespace *nsPtr);
+MODULE_SCOPE void TclDeleteNamespaceChildren(Namespace *nsPtr);
MODULE_SCOPE int TclFindDictElement(Tcl_Interp *interp,
const char *dict, int dictLength,
const char **elementPtr, const char **nextPtr,
diff --git a/generic/tclLoad.c b/generic/tclLoad.c
index c9d1b31..ed2be03 100644
--- a/generic/tclLoad.c
+++ b/generic/tclLoad.c
@@ -12,6 +12,7 @@
#include "tclInt.h"
+
/*
* The following structure describes a library that has been loaded either
* dynamically (with the "load" command) or statically (as indicated by a call
@@ -93,8 +94,20 @@ typedef struct InterpLibrary {
* Prototypes for functions that are private to this file:
*/
-static void LoadCleanupProc(ClientData clientData,
- Tcl_Interp *interp);
+static void LoadCleanupProc(ClientData clientData,
+ Tcl_Interp *interp);
+static int IsStatic (LoadedLibrary *libraryPtr);
+static int UnloadLibrary(Tcl_Interp *interp, Tcl_Interp *target,
+ LoadedLibrary *library, int keepLibrary,
+ const char *fullFileName, int interpExiting);
+
+
+static int
+IsStatic (LoadedLibrary *libraryPtr) {
+ int res;
+ res = (libraryPtr->fileName[0] == '\0');
+ return res;
+}
/*
*----------------------------------------------------------------------
@@ -547,12 +560,10 @@ Tcl_UnloadObjCmd(
Tcl_Obj *const objv[]) /* Argument objects. */
{
Tcl_Interp *target; /* Which interpreter to unload from. */
- LoadedLibrary *libraryPtr, *defaultPtr;
+ LoadedLibrary *libraryPtr;
Tcl_DString pfx, tmp;
- Tcl_LibraryUnloadProc *unloadProc;
InterpLibrary *ipFirstPtr, *ipPtr;
int i, index, code, complain = 1, keepLibrary = 0;
- int trustedRefCount = -1, safeRefCount = -1;
const char *fullFileName = "";
const char *prefix;
static const char *const options[] = {
@@ -646,12 +657,11 @@ Tcl_UnloadObjCmd(
* - Its prefix and file match the once we're looking for.
* - Its file matches, and we weren't given a prefix.
* - Its prefix matches, the file name was specified as empty, and there is
- * only no statically loaded library with the same prefix.
+ * no statically loaded library with the same prefix.
*/
Tcl_MutexLock(&libraryMutex);
- defaultPtr = NULL;
for (libraryPtr = firstLibraryPtr; libraryPtr != NULL; libraryPtr = libraryPtr->nextPtr) {
int namesMatch, filesMatch;
@@ -677,9 +687,6 @@ Tcl_UnloadObjCmd(
if (filesMatch && (namesMatch || (prefix == NULL))) {
break;
}
- if (namesMatch && (fullFileName[0] == 0)) {
- defaultPtr = libraryPtr;
- }
if (filesMatch && !namesMatch && (fullFileName[0] != 0)) {
break;
}
@@ -741,6 +748,34 @@ Tcl_UnloadObjCmd(
goto done;
}
+ code = UnloadLibrary(interp, target, libraryPtr, keepLibrary, fullFileName, 0);
+
+ done:
+ Tcl_DStringFree(&pfx);
+ Tcl_DStringFree(&tmp);
+ if (!complain && (code != TCL_OK)) {
+ code = TCL_OK;
+ Tcl_ResetResult(interp);
+ }
+ return code;
+}
+
+static int
+UnloadLibrary(
+ Tcl_Interp *interp,
+ Tcl_Interp *target,
+ LoadedLibrary *libraryPtr,
+ int keepLibrary,
+ const char *fullFileName,
+ int interpExiting
+)
+{
+ int code;
+ InterpLibrary *ipFirstPtr, *ipPtr;
+ LoadedLibrary *iterLibraryPtr;
+ int trustedRefCount = -1, safeRefCount = -1;
+ Tcl_LibraryUnloadProc *unloadProc = NULL;
+
/*
* Ensure that the DLL can be unloaded. If it is a trusted interpreter,
* libraryPtr->unloadProc must not be NULL for the DLL to be unloadable. If
@@ -749,28 +784,34 @@ Tcl_UnloadObjCmd(
if (Tcl_IsSafe(target)) {
if (libraryPtr->safeUnloadProc == NULL) {
- Tcl_SetObjResult(interp, Tcl_ObjPrintf(
- "file \"%s\" cannot be unloaded under a safe interpreter",
- fullFileName));
- Tcl_SetErrorCode(interp, "TCL", "OPERATION", "UNLOAD", "CANNOT",
- NULL);
- code = TCL_ERROR;
- goto done;
+ if (!interpExiting) {
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "file \"%s\" cannot be unloaded under a safe interpreter",
+ fullFileName));
+ Tcl_SetErrorCode(interp, "TCL", "OPERATION", "UNLOAD", "CANNOT",
+ NULL);
+ code = TCL_ERROR;
+ goto done;
+ }
}
unloadProc = libraryPtr->safeUnloadProc;
} else {
if (libraryPtr->unloadProc == NULL) {
- Tcl_SetObjResult(interp, Tcl_ObjPrintf(
- "file \"%s\" cannot be unloaded under a trusted interpreter",
- fullFileName));
- Tcl_SetErrorCode(interp, "TCL", "OPERATION", "UNLOAD", "CANNOT",
- NULL);
- code = TCL_ERROR;
- goto done;
+ if (!interpExiting) {
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "file \"%s\" cannot be unloaded under a trusted interpreter",
+ fullFileName));
+ Tcl_SetErrorCode(interp, "TCL", "OPERATION", "UNLOAD", "CANNOT",
+ NULL);
+ code = TCL_ERROR;
+ goto done;
+ }
}
unloadProc = libraryPtr->unloadProc;
}
+
+
/*
* We are ready to unload the library. First, evaluate the unload
* function. If this fails, we cannot proceed with unload. Also, we must
@@ -781,34 +822,69 @@ Tcl_UnloadObjCmd(
* after the callback returns, TCL_UNLOAD_DETACH_FROM_PROCESS is passed.
*/
- code = TCL_UNLOAD_DETACH_FROM_INTERPRETER;
- if (!keepLibrary) {
- Tcl_MutexLock(&libraryMutex);
- trustedRefCount = libraryPtr->interpRefCount;
- safeRefCount = libraryPtr->safeInterpRefCount;
- Tcl_MutexUnlock(&libraryMutex);
+ if (unloadProc == NULL) {
+ code = TCL_OK;
+ } else {
+ code = TCL_UNLOAD_DETACH_FROM_INTERPRETER;
+ if (!keepLibrary) {
+ Tcl_MutexLock(&libraryMutex);
+ trustedRefCount = libraryPtr->interpRefCount;
+ safeRefCount = libraryPtr->safeInterpRefCount;
+ Tcl_MutexUnlock(&libraryMutex);
- if (Tcl_IsSafe(target)) {
- safeRefCount--;
- } else {
- trustedRefCount--;
- }
+ if (Tcl_IsSafe(target)) {
+ safeRefCount--;
+ } else {
+ trustedRefCount--;
+ }
- if (safeRefCount <= 0 && trustedRefCount <= 0) {
- code = TCL_UNLOAD_DETACH_FROM_PROCESS;
+ if (safeRefCount <= 0 && trustedRefCount <= 0) {
+ code = TCL_UNLOAD_DETACH_FROM_PROCESS;
+ }
}
+ code = unloadProc(target, code);
}
- code = unloadProc(target, code);
+
+
if (code != TCL_OK) {
Tcl_TransferResult(target, code, interp);
goto done;
}
+
+ /*
+ * Remove this library from the interpreter's library cache.
+ */
+
+ ipFirstPtr = (InterpLibrary *)Tcl_GetAssocData(target, "tclLoad", NULL);
+ ipPtr = ipFirstPtr;
+ if (ipPtr->libraryPtr == libraryPtr) {
+ ipFirstPtr = ipFirstPtr->nextPtr;
+ } else {
+ InterpLibrary *ipPrevPtr;
+
+ for (ipPrevPtr = ipPtr; ipPtr != NULL;
+ ipPrevPtr = ipPtr, ipPtr = ipPtr->nextPtr) {
+ if (ipPtr->libraryPtr == libraryPtr) {
+ ipPrevPtr->nextPtr = ipPtr->nextPtr;
+ break;
+ }
+ }
+ }
+ ckfree(ipPtr);
+ Tcl_SetAssocData(target, "tclLoad", LoadCleanupProc, ipFirstPtr);
+
+
+ if (IsStatic(libraryPtr)) {
+ goto done;
+ }
+
/*
* The unload function executed fine. Examine the reference count to see
* if we unload the DLL.
*/
+
Tcl_MutexLock(&libraryMutex);
if (Tcl_IsSafe(target)) {
libraryPtr->safeInterpRefCount--;
@@ -850,51 +926,29 @@ Tcl_UnloadObjCmd(
* it's been unloaded.
*/
- if (libraryPtr->fileName[0] != '\0') {
+ if (!IsStatic(libraryPtr)) {
Tcl_MutexLock(&libraryMutex);
if (Tcl_FSUnloadFile(interp, libraryPtr->loadHandle) == TCL_OK) {
/*
* Remove this library from the loaded library cache.
*/
- defaultPtr = libraryPtr;
- if (defaultPtr == firstLibraryPtr) {
+ iterLibraryPtr = libraryPtr;
+ if (iterLibraryPtr == firstLibraryPtr) {
firstLibraryPtr = libraryPtr->nextPtr;
} else {
for (libraryPtr = firstLibraryPtr; libraryPtr != NULL;
libraryPtr = libraryPtr->nextPtr) {
- if (libraryPtr->nextPtr == defaultPtr) {
- libraryPtr->nextPtr = defaultPtr->nextPtr;
+ if (libraryPtr->nextPtr == iterLibraryPtr) {
+ libraryPtr->nextPtr = iterLibraryPtr->nextPtr;
break;
}
}
}
- /*
- * Remove this library from the interpreter's library cache.
- */
-
- ipFirstPtr = (InterpLibrary *)Tcl_GetAssocData(target, "tclLoad", NULL);
- ipPtr = ipFirstPtr;
- if (ipPtr->libraryPtr == defaultPtr) {
- ipFirstPtr = ipFirstPtr->nextPtr;
- } else {
- InterpLibrary *ipPrevPtr;
-
- for (ipPrevPtr = ipPtr; ipPtr != NULL;
- ipPrevPtr = ipPtr, ipPtr = ipPtr->nextPtr) {
- if (ipPtr->libraryPtr == defaultPtr) {
- ipPrevPtr->nextPtr = ipPtr->nextPtr;
- break;
- }
- }
- }
- Tcl_SetAssocData(target, "tclLoad", LoadCleanupProc,
- ipFirstPtr);
- ckfree(defaultPtr->fileName);
- ckfree(defaultPtr->prefix);
- ckfree(defaultPtr);
- ckfree(ipPtr);
+ ckfree(iterLibraryPtr->fileName);
+ ckfree(iterLibraryPtr->prefix);
+ ckfree(iterLibraryPtr);
Tcl_MutexUnlock(&libraryMutex);
} else {
code = TCL_ERROR;
@@ -911,12 +965,6 @@ Tcl_UnloadObjCmd(
}
done:
- Tcl_DStringFree(&pfx);
- Tcl_DStringFree(&tmp);
- if (!complain && (code != TCL_OK)) {
- code = TCL_OK;
- Tcl_ResetResult(interp);
- }
return code;
}
@@ -989,6 +1037,8 @@ Tcl_StaticLibrary(
libraryPtr->loadHandle = NULL;
libraryPtr->initProc = initProc;
libraryPtr->safeInitProc = safeInitProc;
+ libraryPtr->unloadProc = NULL;
+ libraryPtr->safeUnloadProc = NULL;
Tcl_MutexLock(&libraryMutex);
libraryPtr->nextPtr = firstLibraryPtr;
firstLibraryPtr = libraryPtr;
@@ -1137,17 +1187,20 @@ TclGetLoadedLibraries(
static void
LoadCleanupProc(
- ClientData clientData, /* Pointer to first InterpLibrary structure
+ TCL_UNUSED(ClientData), /* Pointer to first InterpLibrary structure
* for interp. */
- TCL_UNUSED(Tcl_Interp *))
+ Tcl_Interp *interp)
{
- InterpLibrary *ipPtr, *nextPtr;
+ InterpLibrary *ipPtr;
+ LoadedLibrary *libraryPtr;
- ipPtr = (InterpLibrary *)clientData;
- while (ipPtr != NULL) {
- nextPtr = ipPtr->nextPtr;
- ckfree(ipPtr);
- ipPtr = nextPtr;
+ while (1) {
+ ipPtr = (InterpLibrary *)Tcl_GetAssocData(interp, "tclLoad", NULL);
+ if (ipPtr == NULL) {
+ break;
+ }
+ libraryPtr = ipPtr->libraryPtr;
+ UnloadLibrary(interp, interp, libraryPtr, 0 ,"", 1);
}
}
@@ -1192,7 +1245,7 @@ TclFinalizeLoad(void)
* it has been unloaded.
*/
- if (libraryPtr->fileName[0] != '\0') {
+ if (!IsStatic(libraryPtr)) {
Tcl_FSUnloadFile(NULL, libraryPtr->loadHandle);
}
#endif
diff --git a/generic/tclNamesp.c b/generic/tclNamesp.c
index f57b7e1..5dc9659 100644
--- a/generic/tclNamesp.c
+++ b/generic/tclNamesp.c
@@ -306,7 +306,7 @@ Tcl_PushCallFrame(
/*
* TODO: Examine whether it would be better to guard based on NS_DYING
- * or NS_KILLED. It appears that these are not tested because they can
+ * or NS_TEARDOWN. It appears that these are not tested because they can
* be set in a global interp that has been [namespace delete]d, but
* which never really completely goes away because of lingering global
* things like ::errorInfo and [::unknown] and hidden commands.
@@ -986,20 +986,21 @@ Tcl_DeleteNamespace(
}
/*
- * If the namespace is on the call frame stack, it is marked as "dying"
- * (NS_DYING is OR'd into its flags): the namespace can't be looked up by
- * name but its commands and variables are still usable by those active
- * call frames. When all active call frames referring to the namespace
- * have been popped from the Tcl stack, Tcl_PopCallFrame will call this
- * function again to delete everything in the namespace. If no nsName
- * objects refer to the namespace (i.e., if its refCount is zero), its
- * commands and variables are deleted and the storage for its namespace
- * structure is freed. Otherwise, if its refCount is nonzero, the
- * namespace's commands and variables are deleted but the structure isn't
- * freed. Instead, NS_DEAD is OR'd into the structure's flags to allow the
- * namespace resolution code to recognize that the namespace is "deleted".
- * The structure's storage is freed by FreeNsNameInternalRep when its
- * refCount reaches 0.
+ * If the namespace is on the call frame stack, it is marked as "dying"
+ * (NS_DYING is OR'd into its flags): Contents of the namespace are
+ * still available and visible until the namespace is later marked as
+ * NS_DEAD, and its commands and variables are still usable by any
+ * active call frames referring to th namespace. When all active call
+ * frames referring to the namespace have been popped from the Tcl
+ * stack, Tcl_PopCallFrame calls Tcl_DeleteNamespace again. If no
+ * nsName objects refer to the namespace (i.e., if its refCount is
+ * zero), its commands and variables are deleted and the storage for
+ * its namespace structure is freed. Otherwise, if its refCount is
+ * nonzero, the namespace's commands and variables are deleted but the
+ * structure isn't freed. Instead, NS_DEAD is OR'd into the structure's
+ * flags to allow the namespace resolution code to recognize that the
+ * namespace is "deleted". The structure's storage is freed by
+ * FreeNsNameInternalRep when its refCount reaches 0.
*/
if (nsPtr->activationCount - (nsPtr == globalNsPtr) > 0) {
@@ -1013,16 +1014,16 @@ Tcl_DeleteNamespace(
}
}
nsPtr->parentPtr = NULL;
- } else if (!(nsPtr->flags & NS_KILLED)) {
+ } else if (!(nsPtr->flags & NS_TEARDOWN)) {
/*
* Delete the namespace and everything in it. If this is the global
* namespace, then clear it but don't free its storage unless the
- * interpreter is being torn down. Set the NS_KILLED flag to avoid
+ * interpreter is being torn down. Set the NS_TEARDOWN flag to avoid
* recursive calls here - if the namespace is really in the process of
* being deleted, ignore any second call.
*/
- nsPtr->flags |= (NS_DYING|NS_KILLED);
+ nsPtr->flags |= (NS_DYING|NS_TEARDOWN);
TclTeardownNamespace(nsPtr);
@@ -1060,7 +1061,7 @@ Tcl_DeleteNamespace(
* get killed later, avoiding mem leaks.
*/
- nsPtr->flags &= ~(NS_DYING|NS_KILLED);
+ nsPtr->flags &= ~(NS_DYING|NS_TEARDOWN);
}
}
TclNsDecrRefCount(nsPtr);
@@ -1073,6 +1074,83 @@ TclNamespaceDeleted(
return (nsPtr->flags & NS_DYING) ? 1 : 0;
}
+void
+TclDeleteNamespaceChildren(
+ Namespace *nsPtr /* Namespace whose children to delete */
+)
+{
+ Interp *iPtr = (Interp *) nsPtr->interp;
+ Tcl_HashEntry *entryPtr;
+ int i, unchecked;
+ Tcl_HashSearch search;
+ /*
+ * Delete all the child namespaces.
+ *
+ * BE CAREFUL: When each child is deleted, it divorces itself from its
+ * parent. The hash table can't be proplery traversed if its elements are
+ * being deleted. Because of traces (and the desire to avoid the
+ * quadratic problems of just using Tcl_FirstHashEntry over and over, [Bug
+ * f97d4ee020]) copy to a temporary array and then delete all those
+ * namespaces.
+ *
+ * Important: leave the hash table itself still live.
+ */
+
+#ifndef BREAK_NAMESPACE_COMPAT
+ unchecked = (nsPtr->childTable.numEntries > 0);
+ while (nsPtr->childTable.numEntries > 0 && unchecked) {
+ int length = nsPtr->childTable.numEntries;
+ Namespace **children = (Namespace **)TclStackAlloc((Tcl_Interp *) iPtr,
+ sizeof(Namespace *) * length);
+
+ i = 0;
+ for (entryPtr = Tcl_FirstHashEntry(&nsPtr->childTable, &search);
+ entryPtr != NULL;
+ entryPtr = Tcl_NextHashEntry(&search)) {
+ children[i] = (Namespace *)Tcl_GetHashValue(entryPtr);
+ children[i]->refCount++;
+ i++;
+ }
+ unchecked = 0;
+ for (i = 0 ; i < length ; i++) {
+ if (!(children[i]->flags & NS_DYING)) {
+ unchecked = 1;
+ Tcl_DeleteNamespace((Tcl_Namespace *) children[i]);
+ TclNsDecrRefCount(children[i]);
+ }
+ }
+ TclStackFree((Tcl_Interp *) iPtr, children);
+ }
+#else
+ if (nsPtr->childTablePtr != NULL) {
+ unchecked = (nsPtr->childTable.numEntries > 0);
+ while (nsPtr->childTable.numEntries > 0 && unchecked) {
+ int length = nsPtr->childTablePtr->numEntries;
+ Namespace **children = (Namespace **)TclStackAlloc((Tcl_Interp *) iPtr,
+ sizeof(Namespace *) * length);
+
+ i = 0;
+ for (entryPtr = Tcl_FirstHashEntry(nsPtr->childTablePtr, &search);
+ entryPtr != NULL;
+ entryPtr = Tcl_NextHashEntry(&search)) {
+ children[i] = (Namespace *)Tcl_GetHashValue(entryPtr);
+ children[i]->refCount++;
+ i++;
+ }
+ unchecked = 0;
+ for (i = 0 ; i < length ; i++) {
+ if (!(children[i]->flags & NS_DYING)) {
+ unchecked = 1;
+ Tcl_DeleteNamespace((Tcl_Namespace *) children[i]);
+ TclNsDecrRefCount(children[i]);
+ }
+ }
+ TclStackFree((Tcl_Interp *) iPtr, children);
+ }
+ }
+#endif
+}
+
/*
*----------------------------------------------------------------------
*
@@ -1181,62 +1259,7 @@ TclTeardownNamespace(
nsPtr->commandPathSourceList = NULL;
}
- /*
- * Delete all the child namespaces.
- *
- * BE CAREFUL: When each child is deleted, it will divorce itself from its
- * parent. You can't traverse a hash table properly if its elements are
- * being deleted. Because of traces (and the desire to avoid the
- * quadratic problems of just using Tcl_FirstHashEntry over and over, [Bug
- * f97d4ee020]) we copy to a temporary array and then delete all those
- * namespaces.
- *
- * Important: leave the hash table itself still live.
- */
-
-#ifndef BREAK_NAMESPACE_COMPAT
- while (nsPtr->childTable.numEntries > 0) {
- int length = nsPtr->childTable.numEntries;
- Namespace **children = (Namespace **)TclStackAlloc((Tcl_Interp *) iPtr,
- sizeof(Namespace *) * length);
-
- i = 0;
- for (entryPtr = Tcl_FirstHashEntry(&nsPtr->childTable, &search);
- entryPtr != NULL;
- entryPtr = Tcl_NextHashEntry(&search)) {
- children[i] = (Namespace *)Tcl_GetHashValue(entryPtr);
- children[i]->refCount++;
- i++;
- }
- for (i = 0 ; i < length ; i++) {
- Tcl_DeleteNamespace((Tcl_Namespace *) children[i]);
- TclNsDecrRefCount(children[i]);
- }
- TclStackFree((Tcl_Interp *) iPtr, children);
- }
-#else
- if (nsPtr->childTablePtr != NULL) {
- while (nsPtr->childTablePtr->numEntries > 0) {
- int length = nsPtr->childTablePtr->numEntries;
- Namespace **children = (Namespace **)TclStackAlloc((Tcl_Interp *) iPtr,
- sizeof(Namespace *) * length);
-
- i = 0;
- for (entryPtr = Tcl_FirstHashEntry(nsPtr->childTablePtr, &search);
- entryPtr != NULL;
- entryPtr = Tcl_NextHashEntry(&search)) {
- children[i] = Tcl_GetHashValue(entryPtr);
- children[i]->refCount++;
- i++;
- }
- for (i = 0 ; i < length ; i++) {
- Tcl_DeleteNamespace((Tcl_Namespace *) children[i]);
- TclNsDecrRefCount(children[i]);
- }
- TclStackFree((Tcl_Interp *) iPtr, children);
- }
- }
-#endif
+ TclDeleteNamespaceChildren(nsPtr);
/*
* Free the namespace's export pattern array.
@@ -2618,7 +2641,7 @@ Tcl_FindCommand(
&simpleName);
if ((realNsPtr != NULL) && (simpleName != NULL)) {
if ((cxtNsPtr == realNsPtr)
- || !(realNsPtr->flags & NS_DYING)) {
+ || !(realNsPtr->flags & NS_DEAD)) {
entryPtr = Tcl_FindHashEntry(&realNsPtr->cmdTable, simpleName);
if (entryPtr != NULL) {
cmdPtr = (Command *)Tcl_GetHashValue(entryPtr);
@@ -2630,7 +2653,7 @@ Tcl_FindCommand(
* Next, check along the path.
*/
- for (i=0 ; i<cxtNsPtr->commandPathLength && cmdPtr==NULL ; i++) {
+ for (i=0 ; (cmdPtr == NULL) && i<cxtNsPtr->commandPathLength ; i++) {
pathNsPtr = cxtNsPtr->commandPathArray[i].nsPtr;
if (pathNsPtr == NULL) {
continue;
@@ -2639,7 +2662,7 @@ Tcl_FindCommand(
TCL_NAMESPACE_ONLY, &realNsPtr, &dummyNsPtr, &dummyNsPtr,
&simpleName);
if ((realNsPtr != NULL) && (simpleName != NULL)
- && !(realNsPtr->flags & NS_DYING)) {
+ && !(realNsPtr->flags & NS_DEAD)) {
entryPtr = Tcl_FindHashEntry(&realNsPtr->cmdTable, simpleName);
if (entryPtr != NULL) {
cmdPtr = (Command *)Tcl_GetHashValue(entryPtr);
@@ -2657,7 +2680,7 @@ Tcl_FindCommand(
TCL_GLOBAL_ONLY, &realNsPtr, &dummyNsPtr, &dummyNsPtr,
&simpleName);
if ((realNsPtr != NULL) && (simpleName != NULL)
- && !(realNsPtr->flags & NS_DYING)) {
+ && !(realNsPtr->flags & NS_DEAD)) {
entryPtr = Tcl_FindHashEntry(&realNsPtr->cmdTable, simpleName);
if (entryPtr != NULL) {
cmdPtr = (Command *)Tcl_GetHashValue(entryPtr);
@@ -3277,7 +3300,7 @@ NamespaceDeleteCmd(
name = TclGetString(objv[i]);
namespacePtr = Tcl_FindNamespace(interp, name, NULL, /*flags*/ 0);
if ((namespacePtr == NULL)
- || (((Namespace *) namespacePtr)->flags & NS_KILLED)) {
+ || (((Namespace *) namespacePtr)->flags & NS_TEARDOWN)) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"unknown namespace \"%s\" in namespace delete command",
TclGetString(objv[i])));
diff --git a/generic/tclPosixStr.c b/generic/tclPosixStr.c
index d91a9c4..ecdf652 100644
--- a/generic/tclPosixStr.c
+++ b/generic/tclPosixStr.c
@@ -158,6 +158,9 @@ Tcl_ErrnoId(void)
#ifdef EINIT
case EINIT: return "EINIT";
#endif
+#ifdef EILSEQ
+ case EILSEQ: return "EILSEQ";
+#endif
#ifdef EINPROGRESS
case EINPROGRESS: return "EINPROGRESS";
#endif
@@ -617,6 +620,9 @@ Tcl_ErrnoMsg(
#ifdef EINIT
case EINIT: return "initialization error";
#endif
+#ifdef EILSEQ
+ case EILSEQ: return "illegal byte sequence";
+#endif
#ifdef EINPROGRESS
case EINPROGRESS: return "operation now in progress";
#endif
diff --git a/generic/tclStubInit.c b/generic/tclStubInit.c
index 01d9275..5028916 100644
--- a/generic/tclStubInit.c
+++ b/generic/tclStubInit.c
@@ -1941,6 +1941,7 @@ const TclStubs tclStubs = {
Tcl_UtfCharComplete, /* 654 */
Tcl_UtfNext, /* 655 */
Tcl_UtfPrev, /* 656 */
+ Tcl_UniCharIsUnicode, /* 657 */
};
/* !END!: Do not edit above this line. */
diff --git a/generic/tclTestObj.c b/generic/tclTestObj.c
index 17546a4..f766030 100644
--- a/generic/tclTestObj.c
+++ b/generic/tclTestObj.c
@@ -54,14 +54,13 @@ static Tcl_ObjCmdProc TeststringobjCmd;
#define VARPTR_KEY "TCLOBJTEST_VARPTR"
#define NUMBER_OF_OBJECT_VARS 20
-static void VarPtrDeleteProc(void *clientData, Tcl_Interp *interp)
+static void VarPtrDeleteProc(void *clientData, TCL_UNUSED(Tcl_Interp *))
{
int i;
Tcl_Obj **varPtr = (Tcl_Obj **) clientData;
for (i = 0; i < NUMBER_OF_OBJECT_VARS; i++) {
if (varPtr[i]) Tcl_DecrRefCount(varPtr[i]);
}
- Tcl_DeleteAssocData(interp, VARPTR_KEY);
ckfree(varPtr);
}
diff --git a/generic/tclUtf.c b/generic/tclUtf.c
index 28f725a..fcdf80a 100644
--- a/generic/tclUtf.c
+++ b/generic/tclUtf.c
@@ -2182,6 +2182,36 @@ Tcl_UniCharIsUpper(
/*
*----------------------------------------------------------------------
*
+ * Tcl_UniCharIsUnicode --
+ *
+ * Test if a character is a Unicode character.
+ *
+ * Results:
+ * Returns non-zero if character belongs to the Unicode set.
+ *
+ * Excluded are:
+ * 1) All characters > U+10FFFF
+ * 2) Surrogates U+D800 - U+DFFF
+ * 3) Last 2 characters of each plane, so U+??FFFE and U+??FFFF
+ * 4) The characters in the range U+FDD0 - U+FDEF
+ *
+ * Side effects:
+ * None.
+ *
+ *----------------------------------------------------------------------
+ */
+
+int
+Tcl_UniCharIsUnicode(
+ int ch) /* Unicode character to test. */
+{
+ return ((unsigned int)ch <= 0x10FFFF) && ((ch & 0xFFF800) != 0xD800)
+ && ((ch & 0xFFFE) != 0xFFFE) && ((unsigned int)(ch - 0xFDD0) >= 32);
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
* Tcl_UniCharIsWordChar --
*
* Test if a character is alphanumeric or a connector punctuation mark.
diff --git a/generic/tclZipfs.c b/generic/tclZipfs.c
index de74fb3..dbb4cd9 100644
--- a/generic/tclZipfs.c
+++ b/generic/tclZipfs.c
@@ -249,7 +249,7 @@ typedef struct ZipChannel {
* Most are kept in single ZipFS struct. When build with threading support
* this struct is protected by the ZipFSMutex (see below).
*
- * The "fileHash" component is the process wide global table of all known ZIP
+ * The "fileHash" component is the process-wide global table of all known ZIP
* archive members in all mounted ZIP archives.
*
* The "zipHash" components is the process wide global table of all mounted
@@ -346,7 +346,9 @@ static int ZipFSLoadFile(Tcl_Interp *interp, Tcl_Obj *path,
static int ZipMapArchive(Tcl_Interp *interp, ZipFile *zf,
void *handle);
static void ZipfsExitHandler(ClientData clientData);
+static void ZipfsMountExitHandler(ClientData clientData);
static void ZipfsSetup(void);
+static void ZipfsFinalize(void);
static int ZipChannelClose(void *instanceData,
Tcl_Interp *interp, int flags);
static Tcl_DriverGetHandleProc ZipChannelGetFile;
@@ -1613,7 +1615,7 @@ ZipFSCatalogFilesystem(
*/
zf->mountPoint = (char *) Tcl_GetHashKey(&ZipFS.zipHash, hPtr);
- Tcl_CreateExitHandler(ZipfsExitHandler, zf);
+ Tcl_CreateExitHandler(ZipfsMountExitHandler, zf);
zf->mountPointLen = strlen(zf->mountPoint);
zf->nameLength = strlen(zipname);
@@ -1855,6 +1857,7 @@ ZipfsSetup(void)
strcpy(ZipFS.fallbackEntryEncoding, ZIPFS_FALLBACK_ENCODING);
ZipFS.utf8 = Tcl_GetEncoding(NULL, "utf-8");
ZipFS.initialized = 1;
+ Tcl_CreateExitHandler(ZipfsExitHandler, NULL);
}
/*
@@ -2178,7 +2181,7 @@ TclZipfs_Unmount(
ckfree(z);
}
ZipFSCloseArchive(interp, zf);
- Tcl_DeleteExitHandler(ZipfsExitHandler, zf);
+ Tcl_DeleteExitHandler(ZipfsMountExitHandler, zf);
ckfree(zf);
unmounted = 1;
@@ -5730,13 +5733,48 @@ ZipfsAppHookFindTclInit(
static void
ZipfsExitHandler(
+ TCL_UNUSED(ClientData)
+)
+{
+ Tcl_HashEntry *hPtr;
+ Tcl_HashSearch search;
+ if (ZipFS.initialized != -1) {
+ hPtr = Tcl_FirstHashEntry(&ZipFS.fileHash, &search);
+ if (hPtr == NULL) {
+ ZipfsFinalize();
+ } else {
+ /* ZipFS.fallbackEntryEncoding was already freed by
+ * ZipfsMountExitHandler
+ */
+ }
+ }
+}
+
+static void
+ZipfsFinalize(void) {
+ Tcl_DeleteHashTable(&ZipFS.fileHash);
+ ckfree(ZipFS.fallbackEntryEncoding);
+ ZipFS.initialized = -1;
+}
+
+static void
+ZipfsMountExitHandler(
ClientData clientData)
{
+ Tcl_HashEntry *hPtr;
+ Tcl_HashSearch search;
+
ZipFile *zf = (ZipFile *) clientData;
if (TCL_OK != TclZipfs_Unmount(NULL, zf->mountPoint)) {
Tcl_Panic("tried to unmount busy filesystem");
}
+
+ hPtr = Tcl_FirstHashEntry(&ZipFS.fileHash, &search);
+ if (hPtr == NULL) {
+ ZipfsFinalize();
+ }
+
}
/*
diff --git a/library/init.tcl b/library/init.tcl
index c9bfff6..e30296e 100644
--- a/library/init.tcl
+++ b/library/init.tcl
@@ -214,9 +214,9 @@ proc unknown args {
set errInfo [dict get $opts -errorinfo]
set errCode [dict get $opts -errorcode]
set cinfo $args
- if {[string bytelength $cinfo] > 150} {
+ if {[string length [encoding convertto utf-8 $cinfo]] > 150} {
set cinfo [string range $cinfo 0 150]
- while {[string bytelength $cinfo] > 150} {
+ while {[string length [encoding convertto utf-8 $cinfo]] > 150} {
set cinfo [string range $cinfo 0 end-1]
}
append cinfo ...
diff --git a/tests/chanio.test b/tests/chanio.test
index 8dfefb7..53e8020 100644
--- a/tests/chanio.test
+++ b/tests/chanio.test
@@ -7518,7 +7518,7 @@ test chan-io-60.1 {writing illegal utf sequences} {fileevent testbytestring} {
# cut of the remainder of the error stack, especially the filename
set result [lreplace $result 3 3 [lindex [split [lindex $result 3] \n] 0]]
list $x $result
-} {1 {gets {} catch {error writing "stdout": invalid argument}}}
+} {1 {gets {} catch {error writing "stdout": illegal byte sequence}}}
test chan-io-61.1 {Reset eof state after changing the eof char} -setup {
set datafile [makeFile {} eofchar]
diff --git a/tests/encoding.test b/tests/encoding.test
index c8daed6..0e80c09 100644
--- a/tests/encoding.test
+++ b/tests/encoding.test
@@ -343,61 +343,61 @@ test encoding-15.6 {UtfToUtfProc emoji character output} {
set y [encoding convertto utf-8 \uDE02\uD83D\uDE02\uD83D]
binary scan $y H* z
list [string length $y] $z
-} {10 edb882f09f9882eda0bd}
+} {10 efbfbdf09f9882efbfbd}
test encoding-15.7 {UtfToUtfProc emoji character output} {
set x \uDE02\uD83D\uD83D
set y [encoding convertto utf-8 \uDE02\uD83D\uD83D]
binary scan $y H* z
list [string length $x] [string length $y] $z
-} {3 9 edb882eda0bdeda0bd}
+} {3 9 efbfbdefbfbdefbfbd}
test encoding-15.8 {UtfToUtfProc emoji character output} {
set x \uDE02\uD83Dé
set y [encoding convertto utf-8 \uDE02\uD83Dé]
binary scan $y H* z
list [string length $x] [string length $y] $z
-} {3 8 edb882eda0bdc3a9}
+} {3 8 efbfbdefbfbdc3a9}
test encoding-15.9 {UtfToUtfProc emoji character output} {
set x \uDE02\uD83DX
set y [encoding convertto utf-8 \uDE02\uD83DX]
binary scan $y H* z
list [string length $x] [string length $y] $z
-} {3 7 edb882eda0bd58}
+} {3 7 efbfbdefbfbd58}
test encoding-15.10 {UtfToUtfProc high surrogate character output} {
set x \uDE02é
set y [encoding convertto utf-8 \uDE02é]
binary scan $y H* z
list [string length $x] [string length $y] $z
-} {2 5 edb882c3a9}
+} {2 5 efbfbdc3a9}
test encoding-15.11 {UtfToUtfProc low surrogate character output} {
set x \uDA02é
set y [encoding convertto utf-8 \uDA02é]
binary scan $y H* z
list [string length $x] [string length $y] $z
-} {2 5 eda882c3a9}
+} {2 5 efbfbdc3a9}
test encoding-15.12 {UtfToUtfProc high surrogate character output} {
set x \uDE02Y
set y [encoding convertto utf-8 \uDE02Y]
binary scan $y H* z
list [string length $x] [string length $y] $z
-} {2 4 edb88259}
+} {2 4 efbfbd59}
test encoding-15.13 {UtfToUtfProc low surrogate character output} {
set x \uDA02Y
set y [encoding convertto utf-8 \uDA02Y]
binary scan $y H* z
list [string length $x] [string length $y] $z
-} {2 4 eda88259}
+} {2 4 efbfbd59}
test encoding-15.14 {UtfToUtfProc high surrogate character output} {
set x \uDE02
set y [encoding convertto utf-8 \uDE02]
binary scan $y H* z
list [string length $x] [string length $y] $z
-} {1 3 edb882}
+} {1 3 efbfbd}
test encoding-15.15 {UtfToUtfProc low surrogate character output} {
set x \uDA02
set y [encoding convertto utf-8 \uDA02]
binary scan $y H* z
list [string length $x] [string length $y] $z
-} {1 3 eda882}
+} {1 3 efbfbd}
test encoding-15.16 {UtfToUtfProc: Invalid 4-byte UTF-8, see [ed29806ba]} {
set x \xF0\xA0\xA1\xC2
set y [encoding convertfrom utf-8 \xF0\xA0\xA1\xC2]
@@ -409,6 +409,26 @@ test encoding-15.17 {UtfToUtfProc emoji character output} {
binary scan $y H* z
list [string length $y] $z
} {4 f09f9882}
+test encoding-15.18 {UtfToUtfProc CESU-8 6-byte sequence} {
+ set y [encoding convertto cesu-8 \U10000]
+ binary scan $y H* z
+ list [string length $y] $z
+} {6 eda080edb080}
+test encoding-15.19 {UtfToUtfProc CESU-8 upper surrogate} {
+ set y [encoding convertto cesu-8 \uD800]
+ binary scan $y H* z
+ list [string length $y] $z
+} {3 eda080}
+test encoding-15.20 {UtfToUtfProc CESU-8 lower surrogate} {
+ set y [encoding convertto cesu-8 \uDC00]
+ binary scan $y H* z
+ list [string length $y] $z
+} {3 edb080}
+test encoding-15.21 {UtfToUtfProc CESU-8 noncharacter} {
+ set y [encoding convertto cesu-8 \uFFFF]
+ binary scan $y H* z
+ list [string length $y] $z
+} {3 efbfbf}
test encoding-16.1 {Utf16ToUtfProc} -body {
set val [encoding convertfrom utf-16 NN]
@@ -434,15 +454,15 @@ test encoding-16.4 {Ucs2ToUtfProc} -body {
test encoding-17.1 {UtfToUtf16Proc} -body {
encoding convertto utf-16 "\U460DC"
} -result "\xD8\xD8\xDC\xDC"
-test encoding-17.2 {UtfToUtf16Proc} -body {
- encoding convertto utf-16 "\uDCDC"
-} -result "\xDC\xDC"
-test encoding-17.3 {UtfToUtf16Proc} -body {
- encoding convertto utf-16 "\uD8D8"
-} -result "\xD8\xD8"
-test encoding-17.4 {UtfToUcs2Proc} -body {
+test encoding-17.2 {UtfToUcs2Proc} -body {
encoding convertfrom utf-16 [encoding convertto ucs-2 "\U460DC"]
} -result "\uFFFD"
+test encoding-17.3 {UtfToUtf16Proc} -body {
+ encoding convertto utf-16be "\uDCDC"
+} -result "\xFF\xFD"
+test encoding-17.4 {UtfToUtf16Proc} -body {
+ encoding convertto utf-16le "\uD8D8"
+} -result "\xFD\xFF"
test encoding-18.1 {TableToUtfProc} {
} {}
@@ -742,7 +762,7 @@ test encoding-28.0 {all encodings load} -body {
llength $name
}
return $count
-} -result [expr {[info exists ::tcl_precision] ? 86 : 85}]
+} -result [expr {[info exists ::tcl_precision] ? 87 : 86}]
runtests
diff --git a/tests/info.test b/tests/info.test
index d9a4f54..ced4435 100644
--- a/tests/info.test
+++ b/tests/info.test
@@ -22,7 +22,7 @@ if {{::tcltest} ni [namespace children]} {
::tcltest::loadTestedCommands
catch [list package require -exact tcl::test [info patchlevel]]
testConstraint zlib [llength [info commands zlib]]
-
+testConstraint nodep [info exists tcl_precision]
# Set up namespaces needed to test operation of "info args", "info body",
# "info default", and "info procs" with imported procedures.
@@ -101,7 +101,7 @@ test info-2.5 {info body option, returning bytecompiled bodies} -body {
# Fix for problem tested for in info-2.5 caused problems when
# procedure body had no string rep (i.e. was not yet bytecode)
# causing an empty string to be returned [Bug #545644]
-test info-2.6 {info body option, returning list bodies} {
+test info-2.6 {info body option, returning list bodies} nodep {
proc foo args [list subst bar]
list [string bytelength [info body foo]] \
[foo; string bytelength [info body foo]]
diff --git a/tests/io.test b/tests/io.test
index ddf2403..e26c97f 100644
--- a/tests/io.test
+++ b/tests/io.test
@@ -2416,7 +2416,7 @@ test io-28.7 {
blocking - finalize {
}
watch {
- chan postevent $chan read
+ chan postevent $chan read
}
initialize {
list initialize finalize watch read write configure blocking
@@ -2437,7 +2437,7 @@ test io-28.7 {
} [namespace current]]]
vwait [namespace current]::done
return success
-} success
+} success
@@ -8478,7 +8478,7 @@ test io-60.1 {writing illegal utf sequences} {fileevent testbytestring} {
# cut of the remainder of the error stack, especially the filename
set result [lreplace $result 3 3 [lindex [split [lindex $result 3] \n] 0]]
list $x $result
-} {1 {gets {} catch {error writing "stdout": invalid argument}}}
+} {1 {gets {} catch {error writing "stdout": illegal byte sequence}}}
test io-61.1 {Reset eof state after changing the eof char} -setup {
set datafile [makeFile {} eofchar]
diff --git a/tests/namespace.test b/tests/namespace.test
index efd00a8..6eabf61 100644
--- a/tests/namespace.test
+++ b/tests/namespace.test
@@ -182,8 +182,8 @@ test namespace-7.6 {recursive Tcl_DeleteNamespace, no active call frames in ns}
} {}
test namespace-7.7 {Bug 1655305} -setup {
interp create child
- # Can't invoke through the ensemble, since deleting the global namespace
- # (indirectly, via deleting ::tcl) deletes the ensemble.
+ # Can't invoke through the ensemble, since deleting ::tcl
+ # (indirectly, via deleting the global namespace) deletes the ensemble.
child eval {rename ::tcl::info::commands ::infocommands}
child hide infocommands
child eval {
@@ -207,10 +207,72 @@ test namespace-7.8 {Bug ba1419303b4c} -setup {
namespace delete ns1
}
} -body {
- # No segmentation fault given --enable-symbols=mem.
+ # No segmentation fault given --enable-symbols.
namespace delete ns1
} -result {}
+
+test namespace-7.9 {
+ Bug e39cb3f462631a99
+
+ A namespace being deleted should not be removed from other namespace paths
+ until the contents of the namespace are entirely removed.
+} -setup {
+
+
+
+
+} -body {
+
+ variable res {}
+
+
+ namespace eval ns1 {
+ proc p1 caller {
+ lappend [namespace parent]::res $caller
+ }
+ }
+
+
+ namespace eval ns1a {
+ namespace path [namespace parent]::ns1
+
+ proc t1 {old new op} {
+ $old t1
+ }
+ }
+
+ namespace eval ns2 {
+ proc p1 caller {
+ lappend [namespace parent]::res $caller
+ }
+ }
+
+ namespace eval ns2a {
+ namespace path [namespace parent]::ns2
+
+ proc t1 {old new op} {
+ [namespace tail $old] t2
+ }
+ }
+
+
+ trace add command ns1::p1 delete ns1a::t1
+ namespace delete ns1
+
+ trace add command ns2::p1 delete ns2a::t1
+ namespace delete ns2
+
+ return $res
+
+} -cleanup {
+ namespace delete ns1a
+ namespace delete ns2a
+ unset res
+} -result {t1 t2}
+
+
+
test namespace-8.1 {TclTeardownNamespace, delete global namespace} {
catch {interp delete test_interp}
interp create test_interp
@@ -2723,7 +2785,11 @@ test namespace-51.12 {name resolution path control} -body {
catch {namespace delete ::test_ns_3}
catch {namespace delete ::test_ns_4}
}
-test namespace-51.13 {name resolution path control} -body {
+test namespace-51.13 {
+ name resolution path control
+ when the trace fires, ns_2 is being deleted but isn't gone yet, and is
+ still visible for the trace
+} -body {
set ::result {}
namespace eval ::test_ns_1 {
proc foo {} {lappend ::result 1}
@@ -2746,8 +2812,7 @@ test namespace-51.13 {name resolution path control} -body {
}
bar
}
- # Should the result be "2 {} {2 3 2 1}" instead?
-} -result {2 {} {2 3 1 1}} -cleanup {
+} -result {2 {} {2 3 2 1}} -cleanup {
catch {namespace delete ::test_ns_1}
catch {namespace delete ::test_ns_2}
catch {namespace delete ::test_ns_3}
@@ -3340,6 +3405,43 @@ test namespace-56.5 {Bug 8b9854c3d8} -setup {
} -result 1
+test namespace-56.6 {
+ Namespace deletion traces on both the original routine and the imported
+ routine should run without any memory error under a debug build.
+} -body {
+ variable res {}
+
+ proc ondelete {old new op} {
+ variable res
+ set tail [namespace tail $old]
+ set up [namespace tail [namespace qualifiers $old]]
+ lappend res [list $up $tail]
+ }
+
+
+ namespace eval ns1 {} {
+ namespace export *
+ proc p1 {} {
+ namespace upvar [namespace parent] res res
+ incr res
+ }
+ trace add command p1 delete ondelete
+ }
+
+ namespace eval ns2 {} {
+ namespace import [namespace parent]::ns1::p1
+ trace add command p1 delete ondelete
+ }
+
+ namespace delete ns1
+ namespace delete ns2
+ after 1
+ return $res
+} -cleanup {
+ unset res
+ rename ondelete {}
+} -result {{ns1 p1} {ns2 p1}}
+
test namespace-57.0 {
an imported alias should be usable in the deletion trace for the alias
diff --git a/tests/pkgMkIndex.test b/tests/pkgMkIndex.test
index df49c32..62bd3d4 100644
--- a/tests/pkgMkIndex.test
+++ b/tests/pkgMkIndex.test
@@ -577,19 +577,21 @@ test pkgMkIndex-10.1 {package in DLL and script} [list exec $dll] {
exec [interpreter] << $cmd
pkgtest::runCreatedIndex {0 {}} -lazy $fullPkgPath pkga[info sharedlibextension] pkga.tcl
} "0 {{pkga:1.0 {tclPkgSetup {pkga[info sharedlibextension] load {pkga_eq pkga_quote}} {pkga.tcl source pkga_neq}}}}"
+
test pkgMkIndex-10.2 {package in DLL hidden by -load} [list exec $dll] {
# Do all [load]ing of shared libraries in another process, so we can
# delete the file and not get stuck because we're holding a reference to
# it.
#
# This test depends on context from prior test, so repeat it.
+
set script \
"[list pkg_mkIndex -lazy $fullPkgPath [file tail $x] pkga.tcl]"
append script \n \
"[list pkg_mkIndex -lazy -load Pkg* $fullPkgPath [file tail $x]]"
exec [interpreter] << $script
pkgtest::runCreatedIndex {0 {}} -lazy -load Pkg* -- $fullPkgPath pkga[info sharedlibextension]
-} {0 {}}
+} "0 {{pkga:1.0 {tclPkgSetup {pkga[info sharedlibextension] load {pkga_eq pkga_quote}}}}}"
if {[testConstraint $dll]} {
file delete -force [file join $fullPkgPath [file tail $x]]
diff --git a/tests/regexp.test b/tests/regexp.test
index e788b7f..6bed21e 100644
--- a/tests/regexp.test
+++ b/tests/regexp.test
@@ -19,6 +19,7 @@ if {"::tcltest" ni [namespace children]} {
unset -nocomplain foo
testConstraint exec [llength [info commands exec]]
+testConstraint nodep [info exists tcl_precision]
# Used for constraining memory leak tests
testConstraint memory [llength [info commands memory]]
@@ -765,7 +766,7 @@ test regexp-19.2 {regsub null replacement} {
string equal $result $expected
} 1
-test regexp-20.1 {regsub shared object shimmering} -body {
+test regexp-20.1 {regsub shared object shimmering} -constraints nodep -body {
# Bug #461322
set a abcdefghijklmnopqurstuvwxyz
set b $a
diff --git a/tests/regexpComp.test b/tests/regexpComp.test
index 76e708d..1587c72 100644
--- a/tests/regexpComp.test
+++ b/tests/regexpComp.test
@@ -16,6 +16,8 @@ if {"::tcltest" ni [namespace children]} {
namespace import -force ::tcltest::*
}
+testConstraint nodep [info exists tcl_precision]
+
# Procedure to evaluate a script within a proc, to test compilation
# functionality
@@ -791,7 +793,7 @@ test regexpComp-19.1 {regsub null replacement} {
}
} "\0a\0hel\0a\0lo\0a\0 14"
-test regexpComp-20.1 {regsub shared object shimmering} {
+test regexpComp-20.1 {regsub shared object shimmering} nodep {
evalInProc {
# Bug #461322
set a abcdefghijklmnopqurstuvwxyz
diff --git a/tests/string.test b/tests/string.test
index c2d47d3..822899c 100644
--- a/tests/string.test
+++ b/tests/string.test
@@ -33,6 +33,7 @@ testConstraint testindexobj [expr {[info commands testindexobj] ne {}}]
testConstraint testevalex [expr {[info commands testevalex] ne {}}]
testConstraint utf16 [expr {[string length \U010000] == 2}]
testConstraint testbytestring [llength [info commands testbytestring]]
+testConstraint nodep [info exists tcl_precision]
# Used for constraining memory leak tests
testConstraint memory [llength [info commands memory]]
@@ -72,9 +73,9 @@ if {$noComp} {
}
-test string-1.1.$noComp {error conditions} {
+test string-1.1.$noComp {error conditions} -body {
list [catch {run {string gorp a b}} msg] $msg
-} {1 {unknown or ambiguous subcommand "gorp": must be bytelength, cat, compare, equal, first, index, insert, is, last, length, map, match, range, repeat, replace, reverse, tolower, totitle, toupper, trim, trimleft, trimright, wordend, or wordstart}}
+} -match glob -result {1 {unknown or ambiguous subcommand "gorp": must be *cat, compare, equal, first, index, insert, is, last, length, map, match, range, repeat, replace, reverse, tolower, totitle, toupper, trim, trimleft, trimright, wordend, or wordstart}}
test string-1.2.$noComp {error conditions} {
list [catch {run {string}} msg] $msg
} {1 {wrong # args: should be "string subcommand ?arg ...?"}}
@@ -525,10 +526,10 @@ test string-6.4.$noComp {string is, too many args} {
} {1 {wrong # args: should be "string is class ?-strict? ?-failindex var? str"}}
test string-6.5.$noComp {string is, class check} {
list [catch {run {string is bogus str}} msg] $msg
-} {1 {bad class "bogus": must be alnum, alpha, ascii, control, boolean, dict, digit, double, entier, false, graph, integer, list, lower, print, punct, space, true, upper, wideinteger, wordchar, or xdigit}}
+} {1 {bad class "bogus": must be alnum, alpha, ascii, control, boolean, dict, digit, double, entier, false, graph, integer, list, lower, print, punct, space, true, upper, unicode, wideinteger, wordchar, or xdigit}}
test string-6.6.$noComp {string is, ambiguous class} {
list [catch {run {string is al str}} msg] $msg
-} {1 {ambiguous class "al": must be alnum, alpha, ascii, control, boolean, dict, digit, double, entier, false, graph, integer, list, lower, print, punct, space, true, upper, wideinteger, wordchar, or xdigit}}
+} {1 {ambiguous class "al": must be alnum, alpha, ascii, control, boolean, dict, digit, double, entier, false, graph, integer, list, lower, print, punct, space, true, upper, unicode, wideinteger, wordchar, or xdigit}}
test string-6.7.$noComp {string is alpha, all ok} {
run {string is alpha -strict -failindex var abc}
} 1
@@ -961,6 +962,28 @@ test string-6.130.1.$noComp {string is entier, false on bad octal} {
test string-6.131.$noComp {string is entier, false on bad hex} {
list [run {string is entier -fail var 0X12345611234123456123456562345612345612345612345612345612345612345612345612345612345345XYZ}] $var
} {0 88}
+test string-6.132.$noComp {string is unicode} {
+ run {string is unicode \U10FFFD\uD7FF\uE000\uFDCF\uFDF0}
+} 1
+test string-6.133.$noComp {string is unicode, upper surrogate} {
+ run {string is unicode \uD800}
+} 0
+test string-6.134.$noComp {string is unicode, lower surrogate} {
+ run {string is unicode \uDFFF}
+} 0
+test string-6.135.$noComp {string is unicode, noncharacter} {
+ run {string is unicode \uFFFE}
+} 0
+test string-6.136.$noComp {string is unicode, noncharacter} {
+ run {string is unicode \uFFFF}
+} 0
+test string-6.137.$noComp {string is unicode, noncharacter} {
+ run {string is unicode \uFDD0}
+} 0
+test string-6.138.$noComp {string is unicode, noncharacter} {
+ run {string is unicode \uFDEF}
+} 0
+
test string-7.1.$noComp {string last, not enough args} {
list [catch {run {string last a}} msg] $msg
@@ -1013,16 +1036,16 @@ test string-7.16.$noComp {string last, start index} {
run {string last Üa ÜadÜad end-1}
} 3
-test string-8.1.$noComp {string bytelength} {
+test string-8.1.$noComp {string bytelength} nodep {
list [catch {run {string bytelength}} msg] $msg
} {1 {wrong # args: should be "string bytelength string"}}
-test string-8.2.$noComp {string bytelength} {
+test string-8.2.$noComp {string bytelength} nodep {
list [catch {run {string bytelength a b}} msg] $msg
} {1 {wrong # args: should be "string bytelength string"}}
-test string-8.3.$noComp {string bytelength} {
+test string-8.3.$noComp {string bytelength} nodep {
run {string bytelength "\xC7"}
} 2
-test string-8.4.$noComp {string bytelength} {
+test string-8.4.$noComp {string bytelength} nodep {
run {string b ""}
} 0
@@ -1817,9 +1840,9 @@ test string-19.3.$noComp {string trimleft, unicode default} {
test string-20.1.$noComp {string trimright errors} {
list [catch {run {string trimright}} msg] $msg
} {1 {wrong # args: should be "string trimright string ?chars?"}}
-test string-20.2.$noComp {string trimright errors} {
+test string-20.2.$noComp {string trimright errors} -body {
list [catch {run {string trimg a}} msg] $msg
-} {1 {unknown or ambiguous subcommand "trimg": must be bytelength, cat, compare, equal, first, index, insert, is, last, length, map, match, range, repeat, replace, reverse, tolower, totitle, toupper, trim, trimleft, trimright, wordend, or wordstart}}
+} -match glob -result {1 {unknown or ambiguous subcommand "trimg": must be *cat, compare, equal, first, index, insert, is, last, length, map, match, range, repeat, replace, reverse, tolower, totitle, toupper, trim, trimleft, trimright, wordend, or wordstart}}
test string-20.3.$noComp {string trimright} {
run {string trimright " XYZ "}
} { XYZ}
@@ -1939,7 +1962,7 @@ test string-21.25.$noComp {string trimright, unicode} {
test string-22.1.$noComp {string wordstart} -body {
list [catch {run {string word a}} msg] $msg
-} -result {1 {unknown or ambiguous subcommand "word": must be bytelength, cat, compare, equal, first, index, insert, is, last, length, map, match, range, repeat, replace, reverse, tolower, totitle, toupper, trim, trimleft, trimright, wordend, or wordstart}}
+} -match glob -result {1 {unknown or ambiguous subcommand "word": must be *cat, compare, equal, first, index, insert, is, last, length, map, match, range, repeat, replace, reverse, tolower, totitle, toupper, trim, trimleft, trimright, wordend, or wordstart}}
test string-22.2.$noComp {string wordstart} -body {
list [catch {run {string wordstart a}} msg] $msg
} -result {1 {wrong # args: should be "string wordstart string index"}}
diff --git a/tests/winDde.test b/tests/winDde.test
index dbadeb4..ad21426 100644
--- a/tests/winDde.test
+++ b/tests/winDde.test
@@ -37,6 +37,7 @@ proc createChildProcess {ddeServerName args} {
file delete -force $::scriptName
set f [open $::scriptName w+]
+ fconfigure $f -encoding utf-8
puts $f [list set ddeServerName $ddeServerName]
puts $f [list load $::ddelib Dde]
puts $f {
@@ -96,7 +97,7 @@ proc createChildProcess {ddeServerName args} {
# run the child server script.
set f [open |[list [interpreter] $::scriptName] r]
- fconfigure $f -buffering line
+ fconfigure $f -buffering line -encoding utf-8
gets $f line
return $f
}
diff --git a/unix/Makefile.in b/unix/Makefile.in
index bd018d2..a304558 100644
--- a/unix/Makefile.in
+++ b/unix/Makefile.in
@@ -209,7 +209,7 @@ TCL_LIB_FLAG = @TCL_LIB_FLAG@
#TCL_LIB_FLAG = -ltcl
# support for embedded libraries on Darwin / Mac OS X
-DYLIB_INSTALL_DIR = ${LIB_RUNTIME_DIR}
+DYLIB_INSTALL_DIR = $(libdir)
#--------------------------------------------------------------------------
# The information below is modified by the configure script when Makefile is
@@ -268,6 +268,7 @@ TRACE_OPTS =
VALGRIND = valgrind
VALGRINDARGS = --tool=memcheck --num-callers=24 \
--leak-resolution=high --leak-check=yes --show-reachable=yes -v \
+ --keep-debuginfo=yes \
--suppressions=$(TOOL_DIR)/valgrind_suppress
#--------------------------------------------------------------------------
@@ -902,18 +903,13 @@ test-tcl: ${TCLTEST_EXE}
$(SHELL_ENV) ./${TCLTEST_EXE} $(TOP_DIR)/tests/all.tcl $(TESTFLAGS)
gdb-test: ${TCLTEST_EXE}
- @echo "set env @LD_LIBRARY_PATH_VAR@=`pwd`:$${@LD_LIBRARY_PATH_VAR@}" > gdb.run
- @echo "set env TCL_LIBRARY=${TCL_BUILDTIME_LIBRARY}" >> gdb.run
- @echo "set args $(TOP_DIR)/tests/all.tcl $(TESTFLAGS) -singleproc 1" >> gdb.run
- $(GDB) ./${TCLTEST_EXE} --command=gdb.run
- @rm gdb.run
+ $(SHELL_ENV) $(GDB) --args ./${TCLTEST_EXE} $(TOP_DIR)/tests/all.tcl \
+ $(TESTFLAGS) -singleproc 1
lldb-test: ${TCLTEST_EXE}
- @echo "settings set target.env-vars @LD_LIBRARY_PATH_VAR@=`pwd`:$${@LD_LIBRARY_PATH_VAR@}" > lldb.run
- @echo "settings set target.env-vars TCL_LIBRARY=${TCL_BUILDTIME_LIBRARY}" >> lldb.run
- $(LLDB) --source lldb.run ./${TCLTEST_EXE} -- $(TOP_DIR)/tests/all.tcl \
+ $(SHELL_ENV) $(LLDB) -- ./${TCLTEST_EXE} $(TOP_DIR)/tests/all.tcl \
$(TESTFLAGS) -singleproc 1
- @rm lldb.run
+
# Useful target to launch a built tcltest with the proper path,...
runtest: ${TCLTEST_EXE}
diff --git a/unix/dltest/pkgooa.c b/unix/dltest/pkgooa.c
index ff1cf1f..5aa48a5 100644
--- a/unix/dltest/pkgooa.c
+++ b/unix/dltest/pkgooa.c
@@ -84,10 +84,13 @@ static TclOOStubs stubsCopy = {
NULL, NULL, NULL, NULL, NULL, NULL, NULL,
NULL, NULL, NULL, NULL, NULL, NULL, NULL,
NULL, NULL, NULL, NULL, NULL, NULL, NULL,
- NULL, NULL, NULL, NULL, NULL, NULL, NULL,
+ NULL, NULL, NULL, NULL, NULL, NULL, NULL
+#ifdef Tcl_MethodIsPrivate
+ ,NULL
+#endif
};
-extern DLLEXPORT int
+DLLEXPORT int
Pkgooa_Init(
Tcl_Interp *interp) /* Interpreter in which the package is to be
* made available. */
diff --git a/unix/dltest/pkgua.c b/unix/dltest/pkgua.c
index 0ab3e23..a822541 100644
--- a/unix/dltest/pkgua.c
+++ b/unix/dltest/pkgua.c
@@ -21,6 +21,7 @@ static int PkguaEqObjCmd(ClientData clientData,
Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]);
static int PkguaQuoteObjCmd(ClientData clientData,
Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]);
+static void CommandDeleted(ClientData clientData);
/*
* In the following hash table we are going to store a struct that holds all
@@ -30,23 +31,32 @@ static int PkguaQuoteObjCmd(ClientData clientData,
* need to keep the various command tokens we have registered, as they are the
* only safe way to unregister our registered commands, even if they have been
* renamed.
- *
- * Note that this code is utterly single-threaded.
*/
-static Tcl_HashTable interpTokenMap;
-static int interpTokenMapInitialised = 0;
+typedef struct ThreadSpecificData {
+ int interpTokenMapInitialised;
+ Tcl_HashTable interpTokenMap;
+} ThreadSpecificData;
+static Tcl_ThreadDataKey dataKey;
#define MAX_REGISTERED_COMMANDS 2
+static void
+CommandDeleted(ClientData clientData)
+{
+ Tcl_Command *cmdToken = (Tcl_Command *)clientData;
+ *cmdToken = NULL;
+}
static void
PkguaInitTokensHashTable(void)
{
- if (interpTokenMapInitialised) {
+ ThreadSpecificData *tsdPtr = (ThreadSpecificData *)Tcl_GetThreadData((&dataKey), sizeof(ThreadSpecificData));
+
+ if (tsdPtr->interpTokenMapInitialised) {
return;
}
- Tcl_InitHashTable(&interpTokenMap, TCL_ONE_WORD_KEYS);
- interpTokenMapInitialised = 1;
+ Tcl_InitHashTable(&tsdPtr->interpTokenMap, TCL_ONE_WORD_KEYS);
+ tsdPtr->interpTokenMapInitialised = 1;
}
static void
@@ -54,12 +64,13 @@ PkguaFreeTokensHashTable(void)
{
Tcl_HashSearch search;
Tcl_HashEntry *entryPtr;
+ ThreadSpecificData *tsdPtr = (ThreadSpecificData *)Tcl_GetThreadData((&dataKey), sizeof(ThreadSpecificData));
- for (entryPtr = Tcl_FirstHashEntry(&interpTokenMap, &search);
+ for (entryPtr = Tcl_FirstHashEntry(&tsdPtr->interpTokenMap, &search);
entryPtr != NULL; entryPtr = Tcl_NextHashEntry(&search)) {
Tcl_Free((char *) Tcl_GetHashValue(entryPtr));
}
- interpTokenMapInitialised = 0;
+ tsdPtr->interpTokenMapInitialised = 0;
}
static Tcl_Command *
@@ -68,13 +79,14 @@ PkguaInterpToTokens(
{
int newEntry;
Tcl_Command *cmdTokens;
+ ThreadSpecificData *tsdPtr = (ThreadSpecificData *)Tcl_GetThreadData((&dataKey), sizeof(ThreadSpecificData));
Tcl_HashEntry *entryPtr =
- Tcl_CreateHashEntry(&interpTokenMap, interp, &newEntry);
+ Tcl_CreateHashEntry(&tsdPtr->interpTokenMap, (char *) interp, &newEntry);
if (newEntry) {
cmdTokens = (Tcl_Command *)
- Tcl_Alloc(sizeof(Tcl_Command) * (MAX_REGISTERED_COMMANDS+1));
- for (newEntry=0 ; newEntry<MAX_REGISTERED_COMMANDS+1 ; ++newEntry) {
+ Tcl_Alloc(sizeof(Tcl_Command) * (MAX_REGISTERED_COMMANDS));
+ for (newEntry=0 ; newEntry<MAX_REGISTERED_COMMANDS ; ++newEntry) {
cmdTokens[newEntry] = NULL;
}
Tcl_SetHashValue(entryPtr, cmdTokens);
@@ -88,8 +100,9 @@ static void
PkguaDeleteTokens(
Tcl_Interp *interp)
{
+ ThreadSpecificData *tsdPtr = (ThreadSpecificData *)Tcl_GetThreadData((&dataKey), sizeof(ThreadSpecificData));
Tcl_HashEntry *entryPtr =
- Tcl_FindHashEntry(&interpTokenMap, interp);
+ Tcl_FindHashEntry(&tsdPtr->interpTokenMap, (char *) interp);
if (entryPtr) {
Tcl_Free((char *) Tcl_GetHashValue(entryPtr));
@@ -199,7 +212,7 @@ Pkgua_Init(
Tcl_Interp *interp) /* Interpreter in which the package is to be
* made available. */
{
- int code, cmdIndex = 0;
+ int code;
Tcl_Command *cmdTokens;
if (Tcl_InitStubs(interp, "8.5-", 0) == NULL) {
@@ -207,7 +220,7 @@ Pkgua_Init(
}
/*
- * Initialise our Hash table, where we store the registered command tokens
+ * Initialize our Hash table, where we store the registered command tokens
* for each interpreter.
*/
@@ -221,12 +234,12 @@ Pkgua_Init(
Tcl_SetVar2(interp, "::pkgua_loaded", NULL, ".", TCL_APPEND_VALUE);
cmdTokens = PkguaInterpToTokens(interp);
- cmdTokens[cmdIndex++] =
- Tcl_CreateObjCommand(interp, "pkgua_eq", PkguaEqObjCmd, NULL,
- NULL);
- cmdTokens[cmdIndex++] =
+ cmdTokens[0] =
+ Tcl_CreateObjCommand(interp, "pkgua_eq", PkguaEqObjCmd, &cmdTokens[0],
+ CommandDeleted);
+ cmdTokens[1] =
Tcl_CreateObjCommand(interp, "pkgua_quote", PkguaQuoteObjCmd,
- NULL, NULL);
+ &cmdTokens[1], CommandDeleted);
return TCL_OK;
}
diff --git a/unix/tclXtTest.c b/unix/tclXtTest.c
index 4ee7cca..882f497 100644
--- a/unix/tclXtTest.c
+++ b/unix/tclXtTest.c
@@ -16,7 +16,6 @@
#include "tcl.h"
static Tcl_ObjCmdProc TesteventloopCmd;
-extern DLLEXPORT Tcl_LibraryInitProc Tclxttest_Init;
/*
* Functions defined in tclXtNotify.c for use by users of the Xt Notifier:
@@ -44,7 +43,7 @@ extern XtAppContext TclSetAppContext(XtAppContext ctx);
*----------------------------------------------------------------------
*/
-int
+DLLEXPORT int
Tclxttest_Init(
Tcl_Interp *interp) /* Interpreter for application. */
{