summaryrefslogtreecommitdiffstats
diff options
context:
space:
mode:
authorjan.nijtmans <nijtmans@users.sourceforge.net>2017-12-06 12:00:24 (GMT)
committerjan.nijtmans <nijtmans@users.sourceforge.net>2017-12-06 12:00:24 (GMT)
commit99e890b52cbd5beb8ce2065d525e88ef8de9ed7f (patch)
treed60fc2de4c8c8a3d0ca5a8e94ede8df6b3bc38c6
parent4eed3070235df260454bc98556ccd8598f413797 (diff)
parent72f0f0b3468809e3a3a26e448b3bd3be8a8398a6 (diff)
downloadtcl-99e890b52cbd5beb8ce2065d525e88ef8de9ed7f.zip
tcl-99e890b52cbd5beb8ce2065d525e88ef8de9ed7f.tar.gz
tcl-99e890b52cbd5beb8ce2065d525e88ef8de9ed7f.tar.bz2
merge core-8-branch
-rw-r--r--doc/Object.32
-rw-r--r--doc/SaveResult.34
-rw-r--r--doc/ToUpper.32
-rw-r--r--doc/UniCharIsAlpha.37
-rw-r--r--doc/Utf.32
-rw-r--r--generic/tcl.decls10
-rw-r--r--generic/tclBasic.c220
-rw-r--r--generic/tclCmdIL.c4
-rw-r--r--generic/tclCmdMZ.c2
-rw-r--r--generic/tclDecls.h25
-rw-r--r--generic/tclEncoding.c8
-rw-r--r--generic/tclEnsemble.c360
-rw-r--r--generic/tclExecute.c2
-rw-r--r--generic/tclIO.c2
-rw-r--r--generic/tclIORTrans.c6
-rw-r--r--generic/tclIOUtil.c2
-rw-r--r--generic/tclInt.decls28
-rw-r--r--generic/tclInt.h31
-rw-r--r--generic/tclIntDecls.h214
-rw-r--r--generic/tclInterp.c4
-rw-r--r--generic/tclLink.c2
-rw-r--r--generic/tclNamesp.c31
-rw-r--r--generic/tclOO.c652
-rw-r--r--generic/tclOOInt.h4
-rw-r--r--generic/tclProc.c48
-rw-r--r--generic/tclScan.c2
-rw-r--r--generic/tclStringObj.c22
-rw-r--r--generic/tclStubInit.c62
-rw-r--r--generic/tclTest.c54
-rw-r--r--generic/tclUtf.c135
-rw-r--r--generic/tclUtil.c10
-rw-r--r--library/init.tcl37
-rw-r--r--tests/cmdIL.test13
-rw-r--r--tests/expr-old.test20
-rw-r--r--tests/interp.test2
-rw-r--r--tests/namespace.test53
-rw-r--r--tests/oo.test36
-rw-r--r--tests/safe.test2
-rw-r--r--tests/utf.test11
-rwxr-xr-xunix/configure18
-rw-r--r--unix/tcl.m410
-rw-r--r--unix/tclConfig.h.in3
-rw-r--r--unix/tclUnixPort.h3
-rw-r--r--unix/tclUnixThrd.c2
-rw-r--r--win/tclWinError.c2
-rw-r--r--win/tclWinSerial.c2
46 files changed, 1234 insertions, 937 deletions
diff --git a/doc/Object.3 b/doc/Object.3
index bf80fe2..eadd041 100644
--- a/doc/Object.3
+++ b/doc/Object.3
@@ -257,7 +257,7 @@ The \fBincr\fR command first gets an integer from \fIx\fR's value
by calling \fBTcl_GetIntFromObj\fR.
This procedure checks whether the value is already an integer value.
Since it is not, it converts the value
-by setting the value's \fIinternalRep.longValue\fR member
+by setting the value's internal representation
to the integer \fB123\fR
and setting the value's \fItypePtr\fR
to point to the integer Tcl_ObjType structure.
diff --git a/doc/SaveResult.3 b/doc/SaveResult.3
index b2270a2..6dd6cb6 100644
--- a/doc/SaveResult.3
+++ b/doc/SaveResult.3
@@ -54,9 +54,9 @@ is called, Tcl will take care of memory management.
.PP
The second triplet stores the snapshot of only the interpreter
result (not its complete state) in memory allocated by the caller.
-These routines are passed a pointer to a \fBTcl_SavedResult\fR structure
+These routines are passed a pointer to \fBTcl_SavedResult\fR
that is used to store enough information to restore the interpreter result.
-This structure can be allocated on the stack of the calling
+\fBTcl_SavedResult\fR can be allocated on the stack of the calling
procedure. These routines do not save the state of any error
information in the interpreter (e.g. the \fB\-errorcode\fR or
\fB\-errorinfo\fR return options, when an error is in progress).
diff --git a/doc/ToUpper.3 b/doc/ToUpper.3
index b933e9c..be614e7 100644
--- a/doc/ToUpper.3
+++ b/doc/ToUpper.3
@@ -33,7 +33,7 @@ int
.SH ARGUMENTS
.AS char *str in/out
.AP int ch in
-The Tcl_UniChar to be converted.
+The Unicode character to be converted.
.AP char *str in/out
Pointer to UTF-8 string to be converted in place.
.BE
diff --git a/doc/UniCharIsAlpha.3 b/doc/UniCharIsAlpha.3
index 2336c34..61490ed 100644
--- a/doc/UniCharIsAlpha.3
+++ b/doc/UniCharIsAlpha.3
@@ -48,19 +48,16 @@ int
.SH ARGUMENTS
.AS int ch
.AP int ch in
-The Tcl_UniChar to be examined.
+The Unicode character to be examined.
.BE
.SH DESCRIPTION
.PP
-All of the routines described examine Tcl_UniChars and return a
+All of the routines described examine Unicode characters and return a
boolean value. A non-zero return value means that the character does
belong to the character class associated with the called routine. The
rest of this document just describes the character classes associated
with the various routines.
-.PP
-Note: A Tcl_UniChar is a Unicode character represented as an unsigned,
-fixed-size quantity.
.SH "CHARACTER CLASSES"
.PP
diff --git a/doc/Utf.3 b/doc/Utf.3
index 378c806..9d0c617 100644
--- a/doc/Utf.3
+++ b/doc/Utf.3
@@ -77,7 +77,7 @@ int
Buffer in which the UTF-8 representation of the Tcl_UniChar is stored. At most
\fBTCL_UTF_MAX\fR bytes are stored in the buffer.
.AP int ch in
-The Tcl_UniChar to be converted or examined.
+The Unicode character to be converted or examined.
.AP Tcl_UniChar *chPtr out
Filled with the Tcl_UniChar represented by the head of the UTF-8 string.
.AP "const char" *src in
diff --git a/generic/tcl.decls b/generic/tcl.decls
index ca4feee..f2850fa 100644
--- a/generic/tcl.decls
+++ b/generic/tcl.decls
@@ -942,10 +942,10 @@ declare 265 {
declare 266 {
void Tcl_ValidateAllMemory(const char *file, int line)
}
-declare 267 {
+declare 267 {deprecated {see TIP #422}} {
void Tcl_AppendResultVA(Tcl_Interp *interp, va_list argList)
}
-declare 268 {
+declare 268 {deprecated {see TIP #422}} {
void Tcl_AppendStringsToObjVA(Tcl_Obj *objPtr, va_list argList)
}
declare 269 {
@@ -973,16 +973,16 @@ declare 274 {
CONST84_RETURN char *Tcl_PkgRequire(Tcl_Interp *interp, const char *name,
const char *version, int exact)
}
-declare 275 {
+declare 275 {deprecated {see TIP #422}} {
void Tcl_SetErrorCodeVA(Tcl_Interp *interp, va_list argList)
}
-declare 276 {
+declare 276 {deprecated {see TIP #422}} {
int Tcl_VarEvalVA(Tcl_Interp *interp, va_list argList)
}
declare 277 {
Tcl_Pid Tcl_WaitPid(Tcl_Pid pid, int *statPtr, int options)
}
-declare 278 {
+declare 278 {deprecated {see TIP #422}} {
TCL_NORETURN void Tcl_PanicVA(const char *format, va_list argList)
}
declare 279 {
diff --git a/generic/tclBasic.c b/generic/tclBasic.c
index fcf60c7..a440661 100644
--- a/generic/tclBasic.c
+++ b/generic/tclBasic.c
@@ -118,6 +118,8 @@ static Tcl_ObjCmdProc ExprEntierFunc;
static Tcl_ObjCmdProc ExprFloorFunc;
static Tcl_ObjCmdProc ExprIntFunc;
static Tcl_ObjCmdProc ExprIsqrtFunc;
+static Tcl_ObjCmdProc ExprMaxFunc;
+static Tcl_ObjCmdProc ExprMinFunc;
static Tcl_ObjCmdProc ExprRandFunc;
static Tcl_ObjCmdProc ExprRoundFunc;
static Tcl_ObjCmdProc ExprSqrtFunc;
@@ -321,6 +323,8 @@ static const BuiltinFuncDef BuiltinFuncTable[] = {
{ "isqrt", ExprIsqrtFunc, NULL },
{ "log", ExprUnaryFunc, (ClientData) log },
{ "log10", ExprUnaryFunc, (ClientData) log10 },
+ { "max", ExprMaxFunc, NULL },
+ { "min", ExprMinFunc, NULL },
{ "pow", ExprBinaryFunc, (ClientData) pow },
{ "rand", ExprRandFunc, NULL },
{ "round", ExprRoundFunc, NULL },
@@ -2098,13 +2102,13 @@ Tcl_CreateCommand(
hPtr = Tcl_CreateHashEntry(&nsPtr->cmdTable, tail, &isNew);
- if (isNew || deleted) {
+ if (isNew || deleted) {
/*
* isNew - No conflict with existing command.
* deleted - We've already deleted a conflicting command
*/
break;
- }
+ }
/* An existing command conflicts. Try to delete it.. */
cmdPtr = Tcl_GetHashValue(hPtr);
@@ -2245,64 +2249,82 @@ Tcl_CreateObjCommand(
* name. */
ClientData clientData, /* Arbitrary value to pass to object
* function. */
- Tcl_CmdDeleteProc *deleteProc)
+ Tcl_CmdDeleteProc *deleteProc
/* If not NULL, gives a function to call when
* this command is deleted. */
+)
{
Interp *iPtr = (Interp *) interp;
- ImportRef *oldRefPtr = NULL;
Namespace *nsPtr;
- Command *cmdPtr;
- Tcl_HashEntry *hPtr;
const char *tail;
- int isNew = 0, deleted = 0;
- ImportedCmdData *dataPtr;
if (iPtr->flags & DELETED) {
/*
* The interpreter is being deleted. Don't create any new commands;
* it's not safe to muck with the interpreter anymore.
*/
-
return (Tcl_Command) NULL;
}
/*
+ * Determine where the command should reside. If its name contains
+ * namespace qualifiers, we put it in the specified namespace;
+ * otherwise, we always put it in the global namespace.
+ */
+
+ if (strstr(cmdName, "::") != NULL) {
+ Namespace *dummy1, *dummy2;
+
+ TclGetNamespaceForQualName(interp, cmdName, NULL,
+ TCL_CREATE_NS_IF_UNKNOWN, &nsPtr, &dummy1, &dummy2, &tail);
+ if ((nsPtr == NULL) || (tail == NULL)) {
+ return (Tcl_Command) NULL;
+ }
+ } else {
+ nsPtr = iPtr->globalNsPtr;
+ tail = cmdName;
+ }
+
+ return TclCreateObjCommandInNs(interp, tail, (Tcl_Namespace *) nsPtr,
+ proc, clientData, deleteProc);
+}
+
+Tcl_Command
+TclCreateObjCommandInNs (
+ Tcl_Interp *interp,
+ const char *cmdName, /* Name of command, without any namespace components */
+ Tcl_Namespace *namespace, /* The namespace to create the command in */
+ Tcl_ObjCmdProc *proc, /* Object-based function to associate with
+ * name. */
+ ClientData clientData, /* Arbitrary value to pass to object
+ * function. */
+ Tcl_CmdDeleteProc *deleteProc
+ /* If not NULL, gives a function to call when
+ * this command is deleted. */
+) {
+ int deleted = 0, isNew = 0;
+ Command *cmdPtr;
+ ImportRef *oldRefPtr = NULL;
+ ImportedCmdData *dataPtr;
+ Tcl_HashEntry *hPtr;
+ Namespace *nsPtr = (Namespace *) namespace;
+ /*
* If the command name we seek to create already exists, we need to
* delete that first. That can be tricky in the presence of traces.
* Loop until we no longer find an existing command in the way, or
* until we've deleted one command and that didn't finish the job.
*/
-
while (1) {
- /*
- * Determine where the command should reside. If its name contains
- * namespace qualifiers, we put it in the specified namespace;
- * otherwise, we always put it in the global namespace.
- */
-
- if (strstr(cmdName, "::") != NULL) {
- Namespace *dummy1, *dummy2;
-
- TclGetNamespaceForQualName(interp, cmdName, NULL,
- TCL_CREATE_NS_IF_UNKNOWN, &nsPtr, &dummy1, &dummy2, &tail);
- if ((nsPtr == NULL) || (tail == NULL)) {
- return (Tcl_Command) NULL;
- }
- } else {
- nsPtr = iPtr->globalNsPtr;
- tail = cmdName;
- }
-
- hPtr = Tcl_CreateHashEntry(&nsPtr->cmdTable, tail, &isNew);
+ hPtr = Tcl_CreateHashEntry(&nsPtr->cmdTable, cmdName, &isNew);
- if (isNew || deleted) {
+ if (isNew || deleted) {
/*
* isNew - No conflict with existing command.
* deleted - We've already deleted a conflicting command
*/
break;
- }
+ }
+
/* An existing command conflicts. Try to delete it.. */
cmdPtr = Tcl_GetHashValue(hPtr);
@@ -2336,7 +2358,13 @@ Tcl_CreateObjCommand(
cmdPtr->flags |= CMD_REDEF_IN_PROGRESS;
}
+ /* Make sure namespace doesn't get deallocated. */
+ cmdPtr->nsPtr->refCount++;
+
Tcl_DeleteCommandFromToken(interp, (Tcl_Command) cmdPtr);
+ nsPtr = (Namespace *) TclEnsureNamespace(interp,
+ (Tcl_Namespace *)cmdPtr->nsPtr);
+ TclNsDecrRefCount(cmdPtr->nsPtr);
if (cmdPtr->flags & CMD_REDEF_IN_PROGRESS) {
oldRefPtr = cmdPtr->importRefPtr;
@@ -2345,7 +2373,6 @@ Tcl_CreateObjCommand(
TclCleanupCommandMacro(cmdPtr);
deleted = 1;
}
-
if (!isNew) {
/*
* If the deletion callback recreated the command, just throw away
@@ -2367,7 +2394,7 @@ Tcl_CreateObjCommand(
* commands.
*/
- TclInvalidateCmdLiteral(interp, tail, nsPtr);
+ TclInvalidateCmdLiteral(interp, cmdName, nsPtr);
/*
* The list of command exported from the namespace might have changed.
@@ -7682,6 +7709,71 @@ ExprWideFunc(
return TCL_OK;
}
+/*
+ * Common implmentation of max() and min().
+ */
+static int
+ExprMaxMinFunc(
+ ClientData clientData, /* Ignored. */
+ Tcl_Interp *interp, /* The interpreter in which to execute the
+ * function. */
+ int objc, /* Actual parameter count. */
+ Tcl_Obj *const *objv, /* Actual parameter vector. */
+ int op) /* Comparison direction */
+{
+ Tcl_Obj *res;
+ double d;
+ int type, i;
+ ClientData ptr;
+
+ if (objc < 2) {
+ MathFuncWrongNumArgs(interp, 2, objc, objv);
+ return TCL_ERROR;
+ }
+ res = objv[1];
+ for (i = 1; i < objc; i++) {
+ if (TclGetNumberFromObj(interp, objv[i], &ptr, &type) != TCL_OK) {
+ return TCL_ERROR;
+ }
+ if (type == TCL_NUMBER_NAN) {
+ /*
+ * Get the error message for NaN.
+ */
+
+ Tcl_GetDoubleFromObj(interp, objv[i], &d);
+ return TCL_ERROR;
+ }
+ if (TclCompareTwoNumbers(objv[i], res) == op) {
+ res = objv[i];
+ }
+ }
+
+ Tcl_SetObjResult(interp, res);
+ return TCL_OK;
+}
+
+static int
+ExprMaxFunc(
+ ClientData clientData, /* Ignored. */
+ Tcl_Interp *interp, /* The interpreter in which to execute the
+ * function. */
+ int objc, /* Actual parameter count. */
+ Tcl_Obj *const *objv) /* Actual parameter vector. */
+{
+ return ExprMaxMinFunc(clientData, interp, objc, objv, MP_GT);
+}
+
+static int
+ExprMinFunc(
+ ClientData clientData, /* Ignored. */
+ Tcl_Interp *interp, /* The interpreter in which to execute the
+ * function. */
+ int objc, /* Actual parameter count. */
+ Tcl_Obj *const *objv) /* Actual parameter vector. */
+{
+ return ExprMaxMinFunc(clientData, interp, objc, objv, MP_LT);
+}
+
static int
ExprRandFunc(
ClientData clientData, /* Ignored. */
@@ -8170,6 +8262,22 @@ Tcl_NRCreateCommand(
cmdPtr->nreProc = nreProc;
return (Tcl_Command) cmdPtr;
}
+
+Tcl_Command
+TclNRCreateCommandInNs (
+ Tcl_Interp *interp,
+ const char *cmdName,
+ Tcl_Namespace *nsPtr,
+ Tcl_ObjCmdProc *proc,
+ Tcl_ObjCmdProc *nreProc,
+ ClientData clientData,
+ Tcl_CmdDeleteProc *deleteProc) {
+ Command *cmdPtr = (Command *)
+ TclCreateObjCommandInNs(interp,cmdName,nsPtr,proc,clientData,deleteProc);
+
+ cmdPtr->nreProc = nreProc;
+ return (Tcl_Command) cmdPtr;
+}
/****************************************************************************
* Stuff for the public api
@@ -8955,9 +9063,9 @@ TclNRCoroutineObjCmd(
{
Command *cmdPtr;
CoroutineData *corPtr;
- const char *fullName, *procName;
- Namespace *nsPtr, *altNsPtr, *cxtNsPtr;
- Tcl_DString ds;
+ const char *procName, *simpleName;
+ Namespace *nsPtr, *altNsPtr, *cxtNsPtr,
+ *inNsPtr = (Namespace *)TclGetCurrentNamespace(interp);
Namespace *lookupNsPtr = iPtr->varFramePtr->nsPtr;
if (objc < 3) {
@@ -8965,34 +9073,21 @@ TclNRCoroutineObjCmd(
return TCL_ERROR;
}
- /*
- * FIXME: this is copy/pasted from Tcl_ProcObjCommand. Should have
- * something in tclUtil.c to find the FQ name.
- */
-
- fullName = TclGetString(objv[1]);
- TclGetNamespaceForQualName(interp, fullName, NULL, 0,
- &nsPtr, &altNsPtr, &cxtNsPtr, &procName);
+ procName = TclGetString(objv[1]);
+ TclGetNamespaceForQualName(interp, procName, inNsPtr, 0,
+ &nsPtr, &altNsPtr, &cxtNsPtr, &simpleName);
if (nsPtr == NULL) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"can't create procedure \"%s\": unknown namespace",
- fullName));
+ procName));
Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "NAMESPACE", NULL);
return TCL_ERROR;
}
- if (procName == NULL) {
+ if (simpleName == NULL) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"can't create procedure \"%s\": bad procedure name",
- fullName));
- Tcl_SetErrorCode(interp, "TCL", "VALUE", "COMMAND", fullName, NULL);
- return TCL_ERROR;
- }
- if ((nsPtr != iPtr->globalNsPtr)
- && (procName != NULL) && (procName[0] == ':')) {
- Tcl_SetObjResult(interp, Tcl_ObjPrintf(
- "can't create procedure \"%s\" in non-global namespace with"
- " name starting with \":\"", procName));
+ procName));
Tcl_SetErrorCode(interp, "TCL", "VALUE", "COMMAND", procName, NULL);
return TCL_ERROR;
}
@@ -9004,16 +9099,9 @@ TclNRCoroutineObjCmd(
corPtr = ckalloc(sizeof(CoroutineData));
- Tcl_DStringInit(&ds);
- if (nsPtr != iPtr->globalNsPtr) {
- Tcl_DStringAppend(&ds, nsPtr->fullName, -1);
- TclDStringAppendLiteral(&ds, "::");
- }
- Tcl_DStringAppend(&ds, procName, -1);
-
- cmdPtr = (Command *) Tcl_NRCreateCommand(interp, Tcl_DStringValue(&ds),
- /*objProc*/ NULL, TclNRInterpCoroutine, corPtr, DeleteCoroutine);
- Tcl_DStringFree(&ds);
+ cmdPtr = (Command *) TclNRCreateCommandInNs(interp, simpleName,
+ (Tcl_Namespace *)nsPtr, /*objProc*/ NULL, TclNRInterpCoroutine,
+ corPtr, DeleteCoroutine);
corPtr->cmdPtr = cmdPtr;
cmdPtr->refCount++;
diff --git a/generic/tclCmdIL.c b/generic/tclCmdIL.c
index 47076ec..b41d312 100644
--- a/generic/tclCmdIL.c
+++ b/generic/tclCmdIL.c
@@ -2945,7 +2945,7 @@ Tcl_LsearchObjCmd(
double patDouble, objDouble;
SortInfo sortInfo;
Tcl_Obj *patObj, **listv, *listPtr, *startPtr, *itemPtr;
- SortStrCmpFn_t strCmpFn = strcmp;
+ SortStrCmpFn_t strCmpFn = TclUtfCmp;
Tcl_RegExp regexp = NULL;
static const char *const options[] = {
"-all", "-ascii", "-bisect", "-decreasing", "-dictionary",
@@ -4263,7 +4263,7 @@ SortCompare(
int order = 0;
if (infoPtr->sortMode == SORTMODE_ASCII) {
- order = strcmp(elemPtr1->collationKey.strValuePtr,
+ order = TclUtfCmp(elemPtr1->collationKey.strValuePtr,
elemPtr2->collationKey.strValuePtr);
} else if (infoPtr->sortMode == SORTMODE_ASCII_NC) {
order = TclUtfCasecmp(elemPtr1->collationKey.strValuePtr,
diff --git a/generic/tclCmdMZ.c b/generic/tclCmdMZ.c
index fedb9ac..59960d2 100644
--- a/generic/tclCmdMZ.c
+++ b/generic/tclCmdMZ.c
@@ -3541,7 +3541,7 @@ TclNRSwitchObjCmd(
OPT_LAST
};
typedef int (*strCmpFn_t)(const char *, const char *);
- strCmpFn_t strCmpFn = strcmp;
+ strCmpFn_t strCmpFn = TclUtfCmp;
mode = OPT_EXACT;
foundmode = 0;
diff --git a/generic/tclDecls.h b/generic/tclDecls.h
index 864cad8..be3dc80 100644
--- a/generic/tclDecls.h
+++ b/generic/tclDecls.h
@@ -814,10 +814,12 @@ EXTERN int Tcl_DumpActiveMemory(const char *fileName);
/* 266 */
EXTERN void Tcl_ValidateAllMemory(const char *file, int line);
/* 267 */
-EXTERN void Tcl_AppendResultVA(Tcl_Interp *interp,
+TCL_DEPRECATED("see TIP #422")
+void Tcl_AppendResultVA(Tcl_Interp *interp,
va_list argList);
/* 268 */
-EXTERN void Tcl_AppendStringsToObjVA(Tcl_Obj *objPtr,
+TCL_DEPRECATED("see TIP #422")
+void Tcl_AppendStringsToObjVA(Tcl_Obj *objPtr,
va_list argList);
/* 269 */
EXTERN char * Tcl_HashStats(Tcl_HashTable *tablePtr);
@@ -840,14 +842,17 @@ EXTERN CONST84_RETURN char * Tcl_PkgRequire(Tcl_Interp *interp,
const char *name, const char *version,
int exact);
/* 275 */
-EXTERN void Tcl_SetErrorCodeVA(Tcl_Interp *interp,
+TCL_DEPRECATED("see TIP #422")
+void Tcl_SetErrorCodeVA(Tcl_Interp *interp,
va_list argList);
/* 276 */
-EXTERN int Tcl_VarEvalVA(Tcl_Interp *interp, va_list argList);
+TCL_DEPRECATED("see TIP #422")
+int Tcl_VarEvalVA(Tcl_Interp *interp, va_list argList);
/* 277 */
EXTERN Tcl_Pid Tcl_WaitPid(Tcl_Pid pid, int *statPtr, int options);
/* 278 */
-EXTERN TCL_NORETURN void Tcl_PanicVA(const char *format, va_list argList);
+TCL_DEPRECATED("see TIP #422")
+TCL_NORETURN void Tcl_PanicVA(const char *format, va_list argList);
/* 279 */
EXTERN void Tcl_GetVersion(int *major, int *minor,
int *patchLevel, int *type);
@@ -2135,18 +2140,18 @@ typedef struct TclStubs {
void (*tcl_WrongNumArgs) (Tcl_Interp *interp, int objc, Tcl_Obj *const objv[], const char *message); /* 264 */
int (*tcl_DumpActiveMemory) (const char *fileName); /* 265 */
void (*tcl_ValidateAllMemory) (const char *file, int line); /* 266 */
- void (*tcl_AppendResultVA) (Tcl_Interp *interp, va_list argList); /* 267 */
- void (*tcl_AppendStringsToObjVA) (Tcl_Obj *objPtr, va_list argList); /* 268 */
+ TCL_DEPRECATED_API("see TIP #422") void (*tcl_AppendResultVA) (Tcl_Interp *interp, va_list argList); /* 267 */
+ TCL_DEPRECATED_API("see TIP #422") void (*tcl_AppendStringsToObjVA) (Tcl_Obj *objPtr, va_list argList); /* 268 */
char * (*tcl_HashStats) (Tcl_HashTable *tablePtr); /* 269 */
CONST84_RETURN char * (*tcl_ParseVar) (Tcl_Interp *interp, const char *start, CONST84 char **termPtr); /* 270 */
CONST84_RETURN char * (*tcl_PkgPresent) (Tcl_Interp *interp, const char *name, const char *version, int exact); /* 271 */
CONST84_RETURN char * (*tcl_PkgPresentEx) (Tcl_Interp *interp, const char *name, const char *version, int exact, void *clientDataPtr); /* 272 */
int (*tcl_PkgProvide) (Tcl_Interp *interp, const char *name, const char *version); /* 273 */
CONST84_RETURN char * (*tcl_PkgRequire) (Tcl_Interp *interp, const char *name, const char *version, int exact); /* 274 */
- void (*tcl_SetErrorCodeVA) (Tcl_Interp *interp, va_list argList); /* 275 */
- int (*tcl_VarEvalVA) (Tcl_Interp *interp, va_list argList); /* 276 */
+ TCL_DEPRECATED_API("see TIP #422") void (*tcl_SetErrorCodeVA) (Tcl_Interp *interp, va_list argList); /* 275 */
+ TCL_DEPRECATED_API("see TIP #422") int (*tcl_VarEvalVA) (Tcl_Interp *interp, va_list argList); /* 276 */
Tcl_Pid (*tcl_WaitPid) (Tcl_Pid pid, int *statPtr, int options); /* 277 */
- TCL_NORETURN1 void (*tcl_PanicVA) (const char *format, va_list argList); /* 278 */
+ TCL_DEPRECATED_API("see TIP #422") TCL_NORETURN1 void (*tcl_PanicVA) (const char *format, va_list argList); /* 278 */
void (*tcl_GetVersion) (int *major, int *minor, int *patchLevel, int *type); /* 279 */
void (*tcl_InitMemory) (Tcl_Interp *interp); /* 280 */
Tcl_Channel (*tcl_StackChannel) (Tcl_Interp *interp, const Tcl_ChannelType *typePtr, ClientData instanceData, int mask, Tcl_Channel prevChan); /* 281 */
diff --git a/generic/tclEncoding.c b/generic/tclEncoding.c
index 1f48a1c..e1e26d3 100644
--- a/generic/tclEncoding.c
+++ b/generic/tclEncoding.c
@@ -18,7 +18,7 @@ typedef size_t (LengthProc)(const char *src);
* convert between various character sets and UTF-8.
*/
-typedef struct Encoding {
+typedef struct {
char *name; /* Name of encoding. Malloced because (1) hash
* table entry that owns this encoding may be
* freed prior to this encoding being freed,
@@ -57,7 +57,7 @@ typedef struct Encoding {
* encoding.
*/
-typedef struct TableEncodingData {
+typedef struct {
int fallback; /* Character (in this encoding) to substitute
* when this encoding cannot represent a UTF-8
* character. */
@@ -91,7 +91,7 @@ typedef struct TableEncodingData {
* for switching character sets.
*/
-typedef struct EscapeSubTable {
+typedef struct {
unsigned sequenceLen; /* Length of following string. */
char sequence[16]; /* Escape code that marks this encoding. */
char name[32]; /* Name for encoding. */
@@ -100,7 +100,7 @@ typedef struct EscapeSubTable {
* yet. */
} EscapeSubTable;
-typedef struct EscapeEncodingData {
+typedef struct {
int fallback; /* Character (in this encoding) to substitute
* when this encoding cannot represent a UTF-8
* character. */
diff --git a/generic/tclEnsemble.c b/generic/tclEnsemble.c
index f3e8187..580ea5c 100644
--- a/generic/tclEnsemble.c
+++ b/generic/tclEnsemble.c
@@ -146,10 +146,12 @@ TclNamespaceEnsembleCmd(
Tcl_Obj *const objv[])
{
Tcl_Namespace *namespacePtr;
- Namespace *nsPtr = (Namespace *) TclGetCurrentNamespace(interp);
+ Namespace *nsPtr = (Namespace *) TclGetCurrentNamespace(interp), *cxtPtr,
+ *foundNsPtr, *altFoundNsPtr, *actualCxtPtr;
Tcl_Command token;
Tcl_DictSearch search;
Tcl_Obj *listObj;
+ const char *simpleName;
int index, done;
if (nsPtr == NULL || nsPtr->flags & NS_DYING) {
@@ -195,13 +197,8 @@ TclNamespaceEnsembleCmd(
objv += 2;
objc -= 2;
- /*
- * Work out what name to use for the command to create. If supplied,
- * it is either fully specified or relative to the current namespace.
- * If not supplied, it is exactly the name of the current namespace.
- */
-
- name = nsPtr->fullName;
+ name = nsPtr->name;
+ cxtPtr = (Namespace *) nsPtr->parentPtr;
/*
* Parse the option list, applying type checks as we go. Note that we
@@ -221,6 +218,7 @@ TclNamespaceEnsembleCmd(
switch ((enum EnsCreateOpts) index) {
case CRT_CMD:
name = TclGetString(objv[1]);
+ cxtPtr = nsPtr;
continue;
case CRT_SUBCMDS:
if (TclListObjLength(interp, objv[1], &len) != TCL_OK) {
@@ -337,6 +335,10 @@ TclNamespaceEnsembleCmd(
}
}
+ TclGetNamespaceForQualName(interp, name, cxtPtr,
+ TCL_CREATE_NS_IF_UNKNOWN, &foundNsPtr, &altFoundNsPtr, &actualCxtPtr,
+ &simpleName);
+
/*
* Create the ensemble. Note that this might delete another ensemble
* linked to the same namespace, so we must be careful. However, we
@@ -344,8 +346,9 @@ TclNamespaceEnsembleCmd(
* we've created it (and after any deletions have occurred.)
*/
- token = Tcl_CreateEnsemble(interp, name, NULL,
- (permitPrefix ? TCL_ENSEMBLE_PREFIX : 0));
+ token = TclCreateEnsembleInNs(interp, simpleName,
+ (Tcl_Namespace *) foundNsPtr, (Tcl_Namespace *) nsPtr,
+ (permitPrefix ? TCL_ENSEMBLE_PREFIX : 0));
Tcl_SetEnsembleSubcommandList(interp, token, subcmdObj);
Tcl_SetEnsembleMappingDict(interp, token, mapObj);
Tcl_SetEnsembleUnknownHandler(interp, token, unknownObj);
@@ -636,48 +639,38 @@ TclNamespaceEnsembleCmd(
/*
*----------------------------------------------------------------------
*
- * Tcl_CreateEnsemble --
+ * TclCreateEnsembleInNs --
*
- * Create a simple ensemble attached to the given namespace.
- *
- * Results:
- * The token for the command created.
- *
- * Side effects:
- * The ensemble is created and marked for compilation.
+ * Like Tcl_CreateEnsemble, but additionally accepts as an argument the
+ * name of the namespace to create the command in.
*
*----------------------------------------------------------------------
*/
Tcl_Command
-Tcl_CreateEnsemble(
+TclCreateEnsembleInNs(
Tcl_Interp *interp,
- const char *name,
- Tcl_Namespace *namespacePtr,
- int flags)
-{
- Namespace *nsPtr = (Namespace *) namespacePtr;
- EnsembleConfig *ensemblePtr = ckalloc(sizeof(EnsembleConfig));
- Tcl_Obj *nameObj = NULL;
- if (nsPtr == NULL) {
- nsPtr = (Namespace *) TclGetCurrentNamespace(interp);
- }
-
- /*
- * Make the name of the ensemble into a fully qualified name. This might
- * allocate a temporary object.
- */
+ const char *name, /* Simple name of command to create (no */
+ /* namespace components). */
+ Tcl_Namespace /* Name of namespace to create the command in. */
+ *nameNsPtr,
+ Tcl_Namespace
+ *ensembleNsPtr, /* Name of the namespace for the ensemble. */
+ int flags
+ )
+{
+ Namespace *nsPtr = (Namespace *) ensembleNsPtr;
+ EnsembleConfig *ensemblePtr;
+ Tcl_Command token;
- if (!(name[0] == ':' && name[1] == ':')) {
- nameObj = NewNsObj((Tcl_Namespace *) nsPtr);
- if (nsPtr->parentPtr == NULL) {
- Tcl_AppendStringsToObj(nameObj, name, NULL);
- } else {
- Tcl_AppendStringsToObj(nameObj, "::", name, NULL);
- }
- Tcl_IncrRefCount(nameObj);
- name = TclGetString(nameObj);
+ ensemblePtr = ckalloc(sizeof(EnsembleConfig));
+ token = TclNRCreateCommandInNs(interp, name,
+ (Tcl_Namespace *) nameNsPtr, NsEnsembleImplementationCmd,
+ NsEnsembleImplementationCmdNR, ensemblePtr, DeleteEnsembleConfig);
+ if (token == NULL) {
+ ckfree(ensemblePtr);
+ return NULL;
}
ensemblePtr->nsPtr = nsPtr;
@@ -690,9 +683,7 @@ Tcl_CreateEnsemble(
ensemblePtr->numParameters = 0;
ensemblePtr->parameterList = NULL;
ensemblePtr->unknownHandler = NULL;
- ensemblePtr->token = Tcl_NRCreateCommand(interp, name,
- NsEnsembleImplementationCmd, NsEnsembleImplementationCmdNR,
- ensemblePtr, DeleteEnsembleConfig);
+ ensemblePtr->token = token;
ensemblePtr->next = (EnsembleConfig *) nsPtr->ensembles;
nsPtr->ensembles = (Tcl_Ensemble *) ensemblePtr;
@@ -709,11 +700,52 @@ Tcl_CreateEnsemble(
((Command *) ensemblePtr->token)->compileProc = TclCompileEnsemble;
}
- if (nameObj != NULL) {
- TclDecrRefCount(nameObj);
- }
return ensemblePtr->token;
+
+}
+
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * Tcl_CreateEnsemble
+ *
+ * Create a simple ensemble attached to the given namespace.
+ *
+ * Deprecated by TclCreateEnsembleInNs.
+ *
+ * Value
+ *
+ * The token for the command created.
+ *
+ * Effect
+ * The ensemble is created and marked for compilation.
+ *
+ *
+ *----------------------------------------------------------------------
+ */
+
+Tcl_Command
+Tcl_CreateEnsemble(
+ Tcl_Interp *interp,
+ const char *name,
+ Tcl_Namespace *namespacePtr,
+ int flags)
+{
+ Namespace *nsPtr = (Namespace *)namespacePtr, *foundNsPtr, *altNsPtr,
+ *actualNsPtr;
+ const char * simpleName;
+
+ if (nsPtr == NULL) {
+ nsPtr = (Namespace *) TclGetCurrentNamespace(interp);
+ }
+
+ TclGetNamespaceForQualName(interp, name, nsPtr, TCL_CREATE_NS_IF_UNKNOWN,
+ &foundNsPtr, &altNsPtr, &actualNsPtr, &simpleName);
+ return TclCreateEnsembleInNs(interp, simpleName,
+ (Tcl_Namespace *) foundNsPtr, (Tcl_Namespace *) nsPtr, flags);
}
+
/*
*----------------------------------------------------------------------
@@ -1885,6 +1917,7 @@ NsEnsembleImplementationCmdNR(
TclSkipTailcall(interp);
Tcl_ListObjGetElements(NULL, copyPtr, &copyObjc, &copyObjv);
+ ((Interp *)interp)->lookupNsPtr = ensemblePtr->nsPtr;
return TclNREvalObjv(interp, copyObjc, copyObjv, TCL_EVAL_INVOKE, NULL);
}
@@ -2399,13 +2432,31 @@ MakeCachedEnsembleCommand(
*/
static void
+ClearTable(
+ EnsembleConfig *ensemblePtr)
+{
+ Tcl_HashTable *hash = &ensemblePtr->subcommandTable;
+
+ if (hash->numEntries != 0) {
+ Tcl_HashSearch search;
+ Tcl_HashEntry *hPtr = Tcl_FirstHashEntry(hash, &search);
+
+ while (hPtr != NULL) {
+ Tcl_Obj *prefixObj = Tcl_GetHashValue(hPtr);
+ Tcl_DecrRefCount(prefixObj);
+ hPtr = Tcl_NextHashEntry(&search);
+ }
+ ckfree((char *) ensemblePtr->subcommandArrayPtr);
+ }
+ Tcl_DeleteHashTable(hash);
+}
+
+static void
DeleteEnsembleConfig(
ClientData clientData)
{
EnsembleConfig *ensemblePtr = clientData;
Namespace *nsPtr = ensemblePtr->nsPtr;
- Tcl_HashSearch search;
- Tcl_HashEntry *hEnt;
/*
* Unlink from the ensemble chain if it has not been marked as having been
@@ -2439,17 +2490,7 @@ DeleteEnsembleConfig(
* Kill the pointer-containing fields.
*/
- if (ensemblePtr->subcommandTable.numEntries != 0) {
- ckfree(ensemblePtr->subcommandArrayPtr);
- }
- hEnt = Tcl_FirstHashEntry(&ensemblePtr->subcommandTable, &search);
- while (hEnt != NULL) {
- Tcl_Obj *prefixObj = Tcl_GetHashValue(hEnt);
-
- Tcl_DecrRefCount(prefixObj);
- hEnt = Tcl_NextHashEntry(&search);
- }
- Tcl_DeleteHashTable(&ensemblePtr->subcommandTable);
+ ClearTable(ensemblePtr);
if (ensemblePtr->subcmdList != NULL) {
Tcl_DecrRefCount(ensemblePtr->subcmdList);
}
@@ -2505,100 +2546,101 @@ BuildEnsembleConfig(
int i, j, isNew;
Tcl_HashTable *hash = &ensemblePtr->subcommandTable;
Tcl_HashEntry *hPtr;
-
- if (hash->numEntries != 0) {
- /*
- * Remove pre-existing table.
- */
-
- ckfree(ensemblePtr->subcommandArrayPtr);
- hPtr = Tcl_FirstHashEntry(hash, &search);
- while (hPtr != NULL) {
- Tcl_Obj *prefixObj = Tcl_GetHashValue(hPtr);
-
- Tcl_DecrRefCount(prefixObj);
- hPtr = Tcl_NextHashEntry(&search);
- }
- Tcl_DeleteHashTable(hash);
- Tcl_InitHashTable(hash, TCL_STRING_KEYS);
- }
-
- /*
- * See if we've got an export list. If so, we will only export exactly
- * those commands, which may be either implemented by the prefix in the
- * subcommandDict or mapped directly onto the namespace's commands.
- */
-
- if (ensemblePtr->subcmdList != NULL) {
- Tcl_Obj **subcmdv, *target, *cmdObj, *cmdPrefixObj;
- int subcmdc;
-
- TclListObjGetElements(NULL, ensemblePtr->subcmdList, &subcmdc,
- &subcmdv);
- for (i=0 ; i<subcmdc ; i++) {
- const char *name = TclGetString(subcmdv[i]);
-
- hPtr = Tcl_CreateHashEntry(hash, name, &isNew);
-
- /*
- * Skip non-unique cases.
- */
-
- if (!isNew) {
- continue;
- }
-
- /*
- * Look in our dictionary (if present) for the command.
- */
-
- if (ensemblePtr->subcommandDict != NULL) {
- Tcl_DictObjGet(NULL, ensemblePtr->subcommandDict, subcmdv[i],
- &target);
- if (target != NULL) {
- Tcl_SetHashValue(hPtr, target);
- Tcl_IncrRefCount(target);
- continue;
- }
- }
-
- /*
- * Not there, so map onto the namespace. Note in this case that we
- * do not guarantee that the command is actually there; that is
- * the programmer's responsibility (or [::unknown] of course).
- */
-
- cmdObj = NewNsObj((Tcl_Namespace *) ensemblePtr->nsPtr);
- if (ensemblePtr->nsPtr->parentPtr != NULL) {
- Tcl_AppendStringsToObj(cmdObj, "::", name, NULL);
- } else {
- Tcl_AppendStringsToObj(cmdObj, name, NULL);
- }
- cmdPrefixObj = Tcl_NewListObj(1, &cmdObj);
- Tcl_SetHashValue(hPtr, cmdPrefixObj);
- Tcl_IncrRefCount(cmdPrefixObj);
- }
- } else if (ensemblePtr->subcommandDict != NULL) {
- /*
- * No subcmd list, but we do have a mapping dictionary so we should
- * use the keys of that. Convert the dictionary's contents into the
- * form required for the ensemble's internal hashtable.
- */
-
- Tcl_DictSearch dictSearch;
- Tcl_Obj *keyObj, *valueObj;
- int done;
-
- Tcl_DictObjFirst(NULL, ensemblePtr->subcommandDict, &dictSearch,
- &keyObj, &valueObj, &done);
- while (!done) {
- const char *name = TclGetString(keyObj);
-
- hPtr = Tcl_CreateHashEntry(hash, name, &isNew);
- Tcl_SetHashValue(hPtr, valueObj);
- Tcl_IncrRefCount(valueObj);
- Tcl_DictObjNext(&dictSearch, &keyObj, &valueObj, &done);
- }
+ Tcl_Obj *mapDict = ensemblePtr->subcommandDict;
+ Tcl_Obj *subList = ensemblePtr->subcmdList;
+
+ ClearTable(ensemblePtr);
+ Tcl_InitHashTable(hash, TCL_STRING_KEYS);
+
+ if (subList) {
+ int subc;
+ Tcl_Obj **subv, *target, *cmdObj, *cmdPrefixObj;
+ char *name;
+
+ /*
+ * There is a list of exactly what subcommands go in the table.
+ * Must determine the target for each.
+ */
+
+ Tcl_ListObjGetElements(NULL, subList, &subc, &subv);
+ if (subList == mapDict) {
+ /*
+ * Strange case where explicit list of subcommands is same value
+ * as the dict mapping to targets.
+ */
+
+ for (i = 0; i < subc; i += 2) {
+ name = TclGetString(subv[i]);
+ hPtr = Tcl_CreateHashEntry(hash, name, &isNew);
+ if (!isNew) {
+ cmdObj = (Tcl_Obj *)Tcl_GetHashValue(hPtr);
+ Tcl_DecrRefCount(cmdObj);
+ }
+ Tcl_SetHashValue(hPtr, subv[i+1]);
+ Tcl_IncrRefCount(subv[i+1]);
+
+ name = TclGetString(subv[i+1]);
+ hPtr = Tcl_CreateHashEntry(hash, name, &isNew);
+ if (isNew) {
+ cmdObj = Tcl_NewStringObj(name, -1);
+ cmdPrefixObj = Tcl_NewListObj(1, &cmdObj);
+ Tcl_SetHashValue(hPtr, cmdPrefixObj);
+ Tcl_IncrRefCount(cmdPrefixObj);
+ }
+ }
+ } else {
+ /* Usual case where we can freely act on the list and dict. */
+
+ for (i = 0; i < subc; i++) {
+ name = TclGetString(subv[i]);
+ hPtr = Tcl_CreateHashEntry(hash, name, &isNew);
+ if (!isNew) {
+ continue;
+ }
+
+ /* Lookup target in the dictionary */
+ if (mapDict) {
+ Tcl_DictObjGet(NULL, mapDict, subv[i], &target);
+ if (target) {
+ Tcl_SetHashValue(hPtr, target);
+ Tcl_IncrRefCount(target);
+ continue;
+ }
+ }
+
+ /*
+ * target was not in the dictionary so map onto the namespace.
+ * Note in this case that we do not guarantee that the
+ * command is actually there; that is the programmer's
+ * responsibility (or [::unknown] of course).
+ */
+ cmdObj = Tcl_NewStringObj(name, -1);
+ cmdPrefixObj = Tcl_NewListObj(1, &cmdObj);
+ Tcl_SetHashValue(hPtr, cmdPrefixObj);
+ Tcl_IncrRefCount(cmdPrefixObj);
+ }
+ }
+ } else if (mapDict) {
+ /*
+ * No subcmd list, but we do have a mapping dictionary so we should
+ * use the keys of that. Convert the dictionary's contents into the
+ * form required for the ensemble's internal hashtable.
+ */
+
+ Tcl_DictSearch dictSearch;
+ Tcl_Obj *keyObj, *valueObj;
+ int done;
+
+ Tcl_DictObjFirst(NULL, ensemblePtr->subcommandDict, &dictSearch,
+ &keyObj, &valueObj, &done);
+ while (!done) {
+ char *name = TclGetString(keyObj);
+
+ hPtr = Tcl_CreateHashEntry(hash, name, &isNew);
+ Tcl_SetHashValue(hPtr, valueObj);
+ Tcl_IncrRefCount(valueObj);
+ Tcl_DictObjNext(&dictSearch, &keyObj, &valueObj, &done);
+ }
} else {
/*
* Discover what commands are actually exported by the namespace.
@@ -2634,11 +2676,7 @@ BuildEnsembleConfig(
if (isNew) {
Tcl_Obj *cmdObj, *cmdPrefixObj;
- TclNewObj(cmdObj);
- Tcl_AppendStringsToObj(cmdObj,
- ensemblePtr->nsPtr->fullName,
- (ensemblePtr->nsPtr->parentPtr ? "::" : ""),
- nsCmdName, NULL);
+ cmdObj = Tcl_NewStringObj(nsCmdName, -1);
cmdPrefixObj = Tcl_NewListObj(1, &cmdObj);
Tcl_SetHashValue(hPtr, cmdPrefixObj);
Tcl_IncrRefCount(cmdPrefixObj);
diff --git a/generic/tclExecute.c b/generic/tclExecute.c
index f2f78a0..2fed944 100644
--- a/generic/tclExecute.c
+++ b/generic/tclExecute.c
@@ -689,8 +689,6 @@ static ByteCode * CompileExprObj(Tcl_Interp *interp, Tcl_Obj *objPtr);
static void DeleteExecStack(ExecStack *esPtr);
static void DupExprCodeInternalRep(Tcl_Obj *srcPtr,
Tcl_Obj *copyPtr);
-MODULE_SCOPE int TclCompareTwoNumbers(Tcl_Obj *valuePtr,
- Tcl_Obj *value2Ptr);
static Tcl_Obj * ExecuteExtendedBinaryMathOp(Tcl_Interp *interp,
int opcode, Tcl_Obj **constants,
Tcl_Obj *valuePtr, Tcl_Obj *value2Ptr);
diff --git a/generic/tclIO.c b/generic/tclIO.c
index df04794..81fd298 100644
--- a/generic/tclIO.c
+++ b/generic/tclIO.c
@@ -9032,6 +9032,7 @@ ZeroTransferTimerProc(
*----------------------------------------------------------------------
*/
+#if !defined(TCL_NO_DEPRECATED)
int
TclCopyChannelOld(
Tcl_Interp *interp, /* Current interpreter. */
@@ -9043,6 +9044,7 @@ TclCopyChannelOld(
return TclCopyChannel(interp, inChan, outChan, (Tcl_WideInt) toRead,
cmdPtr);
}
+#endif
int
TclCopyChannel(
diff --git a/generic/tclIORTrans.c b/generic/tclIORTrans.c
index f198c69..fe2e458 100644
--- a/generic/tclIORTrans.c
+++ b/generic/tclIORTrans.c
@@ -87,7 +87,7 @@ static const Tcl_ChannelType tclRTransformType = {
* layers upon reading from the channel, plus the functions to manage such.
*/
-typedef struct _ResultBuffer_ {
+typedef struct {
unsigned char *buf; /* Reference to the buffer area. */
int allocated; /* Allocated size of the buffer area. */
int used; /* Number of bytes in the buffer,
@@ -253,7 +253,7 @@ typedef enum {
* sharing problems.
*/
-typedef struct ForwardParamBase {
+typedef struct {
int code; /* O: Ok/Fail of the cmd handler */
char *msgStr; /* O: Error message for handler failure */
int mustFree; /* O: True if msgStr is allocated, false if
@@ -298,7 +298,7 @@ typedef struct ForwardingResult ForwardingResult;
* General event structure, with reference to operation specific data.
*/
-typedef struct ForwardingEvent {
+typedef struct {
Tcl_Event event; /* Basic event data, has to be first item */
ForwardingResult *resultPtr;
ForwardedOperation op; /* Forwarded driver operation */
diff --git a/generic/tclIOUtil.c b/generic/tclIOUtil.c
index 4f2288e..8fb3aa8 100644
--- a/generic/tclIOUtil.c
+++ b/generic/tclIOUtil.c
@@ -245,7 +245,7 @@ static Tcl_ThreadDataKey fsDataKey;
* code.
*/
-typedef struct FsDivertLoad {
+typedef struct {
Tcl_LoadHandle loadHandle;
Tcl_FSUnloadFileProc *unloadProcPtr;
Tcl_Obj *divertedFile;
diff --git a/generic/tclInt.decls b/generic/tclInt.decls
index f29e483..93dbf07 100644
--- a/generic/tclInt.decls
+++ b/generic/tclInt.decls
@@ -453,26 +453,26 @@ declare 111 {
Tcl_ResolveCompiledVarProc *compiledVarProc)
}
declare 112 {
- int Tcl_AppendExportList(Tcl_Interp *interp, Tcl_Namespace *nsPtr,
+ int TclAppendExportList(Tcl_Interp *interp, Tcl_Namespace *nsPtr,
Tcl_Obj *objPtr)
}
declare 113 {
- Tcl_Namespace *Tcl_CreateNamespace(Tcl_Interp *interp, const char *name,
+ Tcl_Namespace *TclCreateNamespace(Tcl_Interp *interp, const char *name,
ClientData clientData, Tcl_NamespaceDeleteProc *deleteProc)
}
declare 114 {
- void Tcl_DeleteNamespace(Tcl_Namespace *nsPtr)
+ void TclDeleteNamespace(Tcl_Namespace *nsPtr)
}
declare 115 {
- int Tcl_Export(Tcl_Interp *interp, Tcl_Namespace *nsPtr,
+ int TclExport(Tcl_Interp *interp, Tcl_Namespace *nsPtr,
const char *pattern, int resetListFirst)
}
declare 116 {
- Tcl_Command Tcl_FindCommand(Tcl_Interp *interp, const char *name,
+ Tcl_Command TclFindCommand(Tcl_Interp *interp, const char *name,
Tcl_Namespace *contextNsPtr, int flags)
}
declare 117 {
- Tcl_Namespace *Tcl_FindNamespace(Tcl_Interp *interp, const char *name,
+ Tcl_Namespace *TclFindNamespace(Tcl_Interp *interp, const char *name,
Tcl_Namespace *contextNsPtr, int flags)
}
declare 118 {
@@ -488,28 +488,28 @@ declare 120 {
Tcl_Namespace *contextNsPtr, int flags)
}
declare 121 {
- int Tcl_ForgetImport(Tcl_Interp *interp, Tcl_Namespace *nsPtr,
+ int TclForgetImport(Tcl_Interp *interp, Tcl_Namespace *nsPtr,
const char *pattern)
}
declare 122 {
- Tcl_Command Tcl_GetCommandFromObj(Tcl_Interp *interp, Tcl_Obj *objPtr)
+ Tcl_Command TclGetCommandFromObj(Tcl_Interp *interp, Tcl_Obj *objPtr)
}
declare 123 {
- void Tcl_GetCommandFullName(Tcl_Interp *interp, Tcl_Command command,
+ void TclGetCommandFullName(Tcl_Interp *interp, Tcl_Command command,
Tcl_Obj *objPtr)
}
declare 124 {
- Tcl_Namespace *Tcl_GetCurrentNamespace(Tcl_Interp *interp)
+ Tcl_Namespace *TclGetCurrentNamespace_(Tcl_Interp *interp)
}
declare 125 {
- Tcl_Namespace *Tcl_GetGlobalNamespace(Tcl_Interp *interp)
+ Tcl_Namespace *TclGetGlobalNamespace_(Tcl_Interp *interp)
}
declare 126 {
void Tcl_GetVariableFullName(Tcl_Interp *interp, Tcl_Var variable,
Tcl_Obj *objPtr)
}
declare 127 {
- int Tcl_Import(Tcl_Interp *interp, Tcl_Namespace *nsPtr,
+ int TclImport(Tcl_Interp *interp, Tcl_Namespace *nsPtr,
const char *pattern, int allowOverwrite)
}
declare 128 {
@@ -724,10 +724,10 @@ declare 177 {
const char *operation, const char *reason)
}
declare 178 {
- void Tcl_SetStartupScript(Tcl_Obj *pathPtr, const char *encodingName)
+ void TclSetStartupScript(Tcl_Obj *pathPtr, const char *encodingName)
}
declare 179 {
- Tcl_Obj *Tcl_GetStartupScript(const char **encodingNamePtr)
+ Tcl_Obj *TclGetStartupScript(const char **encodingNamePtr)
}
# REMOVED
diff --git a/generic/tclInt.h b/generic/tclInt.h
index 90ceb40..ec45989 100644
--- a/generic/tclInt.h
+++ b/generic/tclInt.h
@@ -2893,6 +2893,8 @@ MODULE_SCOPE int TclChanCaughtErrorBypass(Tcl_Interp *interp,
Tcl_Channel chan);
MODULE_SCOPE Tcl_ObjCmdProc TclChannelNamesCmd;
MODULE_SCOPE Tcl_NRPostProc TclClearRootEnsemble;
+MODULE_SCOPE int TclCompareTwoNumbers(Tcl_Obj *valuePtr,
+ Tcl_Obj *value2Ptr);
MODULE_SCOPE ContLineLoc *TclContinuationsEnter(Tcl_Obj *objPtr, int num,
int *loc);
MODULE_SCOPE void TclContinuationsEnterDerived(Tcl_Obj *objPtr,
@@ -2902,6 +2904,19 @@ MODULE_SCOPE void TclContinuationsCopy(Tcl_Obj *objPtr,
Tcl_Obj *originObjPtr);
MODULE_SCOPE int TclConvertElement(const char *src, int length,
char *dst, int flags);
+MODULE_SCOPE Tcl_Command TclCreateObjCommandInNs (
+ Tcl_Interp *interp,
+ const char *cmdName,
+ Tcl_Namespace *nsPtr,
+ Tcl_ObjCmdProc *proc,
+ ClientData clientData,
+ Tcl_CmdDeleteProc *deleteProc);
+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 int TclFindDictElement(Tcl_Interp *interp,
const char *dict, int dictLength,
@@ -2930,6 +2945,10 @@ MODULE_SCOPE char * TclDStringAppendDString(Tcl_DString *dsPtr,
MODULE_SCOPE Tcl_Obj * TclDStringToObj(Tcl_DString *dsPtr);
MODULE_SCOPE Tcl_Obj *const * TclFetchEnsembleRoot(Tcl_Interp *interp,
Tcl_Obj *const *objv, int objc, int *objcPtr);
+Tcl_Namespace * TclEnsureNamespace(
+ Tcl_Interp *interp,
+ Tcl_Namespace *namespacePtr);
+
MODULE_SCOPE void TclFinalizeAllocSubsystem(void);
MODULE_SCOPE void TclFinalizeAsync(void);
MODULE_SCOPE void TclFinalizeDoubleConversion(void);
@@ -2956,6 +2975,15 @@ MODULE_SCOPE double TclFloor(const mp_int *a);
MODULE_SCOPE void TclFormatNaN(double value, char *buffer);
MODULE_SCOPE int TclFSFileAttrIndex(Tcl_Obj *pathPtr,
const char *attributeName, int *indexPtr);
+MODULE_SCOPE Tcl_Command TclNRCreateCommandInNs (
+ Tcl_Interp *interp,
+ const char *cmdName,
+ Tcl_Namespace *nsPtr,
+ Tcl_ObjCmdProc *proc,
+ Tcl_ObjCmdProc *nreProc,
+ ClientData clientData,
+ Tcl_CmdDeleteProc *deleteProc);
+
MODULE_SCOPE int TclNREvalFile(Tcl_Interp *interp, Tcl_Obj *pathPtr,
const char *encodingName);
MODULE_SCOPE void TclFSUnloadTempFile(Tcl_LoadHandle loadHandle);
@@ -3176,6 +3204,7 @@ MODULE_SCOPE int TclTrimLeft(const char *bytes, int numBytes,
const char *trim, int numTrim);
MODULE_SCOPE int TclTrimRight(const char *bytes, int numBytes,
const char *trim, int numTrim);
+MODULE_SCOPE int TclUtfCmp(const char *cs, const char *ct);
MODULE_SCOPE int TclUtfCasecmp(const char *cs, const char *ct);
MODULE_SCOPE int TclUtfCount(int ch);
MODULE_SCOPE Tcl_Obj * TclpNativeToNormalized(ClientData clientData);
@@ -4403,7 +4432,7 @@ MODULE_SCOPE void TclDbInitNewObj(Tcl_Obj *objPtr, const char *file,
*/
#define TclUtfToUniChar(str, chPtr) \
- ((((unsigned char) *(str)) < 0xC0) ? \
+ ((((unsigned char) *(str)) < 0x80) ? \
((*(chPtr) = (unsigned char) *(str)), 1) \
: Tcl_UtfToUniChar(str, chPtr))
diff --git a/generic/tclIntDecls.h b/generic/tclIntDecls.h
index 4a5fe5a..1d1fd7f 100644
--- a/generic/tclIntDecls.h
+++ b/generic/tclIntDecls.h
@@ -28,21 +28,21 @@
# endif
#endif
-/* [Bug #803489] Tcl_FindNamespace problem in the Stubs table */
-#undef Tcl_CreateNamespace
-#undef Tcl_DeleteNamespace
-#undef Tcl_AppendExportList
-#undef Tcl_Export
-#undef Tcl_Import
-#undef Tcl_ForgetImport
-#undef Tcl_GetCurrentNamespace
-#undef Tcl_GetGlobalNamespace
-#undef Tcl_FindNamespace
-#undef Tcl_FindCommand
-#undef Tcl_GetCommandFromObj
-#undef Tcl_GetCommandFullName
-#undef Tcl_SetStartupScript
-#undef Tcl_GetStartupScript
+#if !defined(TCL_NO_DEPRECATED) && (TCL_MAJOR_VERSION < 9)
+/* Those macro's are especially for Itcl 3.4 compatibility */
+# define tclCreateNamespace tcl_CreateNamespace
+# define tclDeleteNamespace tcl_DeleteNamespace
+# define tclAppendExportList tcl_AppendExportList
+# define tclExport tcl_Export
+# define tclImport tcl_Import
+# define tclForgetImport tcl_ForgetImport
+# define tclGetCurrentNamespace_ tcl_GetCurrentNamespace
+# define tclGetGlobalNamespace_ tcl_GetGlobalNamespace
+# define tclFindNamespace tcl_FindNamespace
+# define tclFindCommand tcl_FindCommand
+# define tclGetCommandFromObj tcl_GetCommandFromObj
+# define tclGetCommandFullName tcl_GetCommandFullName
+#endif /* !defined(TCL_NO_DEPRECATED) */
/*
* WARNING: This file is automatically generated by the tools/genStubs.tcl
@@ -287,22 +287,22 @@ EXTERN void Tcl_AddInterpResolvers(Tcl_Interp *interp,
Tcl_ResolveVarProc *varProc,
Tcl_ResolveCompiledVarProc *compiledVarProc);
/* 112 */
-EXTERN int Tcl_AppendExportList(Tcl_Interp *interp,
+EXTERN int TclAppendExportList(Tcl_Interp *interp,
Tcl_Namespace *nsPtr, Tcl_Obj *objPtr);
/* 113 */
-EXTERN Tcl_Namespace * Tcl_CreateNamespace(Tcl_Interp *interp,
+EXTERN Tcl_Namespace * TclCreateNamespace(Tcl_Interp *interp,
const char *name, ClientData clientData,
Tcl_NamespaceDeleteProc *deleteProc);
/* 114 */
-EXTERN void Tcl_DeleteNamespace(Tcl_Namespace *nsPtr);
+EXTERN void TclDeleteNamespace(Tcl_Namespace *nsPtr);
/* 115 */
-EXTERN int Tcl_Export(Tcl_Interp *interp, Tcl_Namespace *nsPtr,
+EXTERN int TclExport(Tcl_Interp *interp, Tcl_Namespace *nsPtr,
const char *pattern, int resetListFirst);
/* 116 */
-EXTERN Tcl_Command Tcl_FindCommand(Tcl_Interp *interp, const char *name,
+EXTERN Tcl_Command TclFindCommand(Tcl_Interp *interp, const char *name,
Tcl_Namespace *contextNsPtr, int flags);
/* 117 */
-EXTERN Tcl_Namespace * Tcl_FindNamespace(Tcl_Interp *interp,
+EXTERN Tcl_Namespace * TclFindNamespace(Tcl_Interp *interp,
const char *name,
Tcl_Namespace *contextNsPtr, int flags);
/* 118 */
@@ -317,23 +317,23 @@ EXTERN Tcl_Var Tcl_FindNamespaceVar(Tcl_Interp *interp,
const char *name,
Tcl_Namespace *contextNsPtr, int flags);
/* 121 */
-EXTERN int Tcl_ForgetImport(Tcl_Interp *interp,
+EXTERN int TclForgetImport(Tcl_Interp *interp,
Tcl_Namespace *nsPtr, const char *pattern);
/* 122 */
-EXTERN Tcl_Command Tcl_GetCommandFromObj(Tcl_Interp *interp,
+EXTERN Tcl_Command TclGetCommandFromObj(Tcl_Interp *interp,
Tcl_Obj *objPtr);
/* 123 */
-EXTERN void Tcl_GetCommandFullName(Tcl_Interp *interp,
+EXTERN void TclGetCommandFullName(Tcl_Interp *interp,
Tcl_Command command, Tcl_Obj *objPtr);
/* 124 */
-EXTERN Tcl_Namespace * Tcl_GetCurrentNamespace(Tcl_Interp *interp);
+EXTERN Tcl_Namespace * TclGetCurrentNamespace_(Tcl_Interp *interp);
/* 125 */
-EXTERN Tcl_Namespace * Tcl_GetGlobalNamespace(Tcl_Interp *interp);
+EXTERN Tcl_Namespace * TclGetGlobalNamespace_(Tcl_Interp *interp);
/* 126 */
EXTERN void Tcl_GetVariableFullName(Tcl_Interp *interp,
Tcl_Var variable, Tcl_Obj *objPtr);
/* 127 */
-EXTERN int Tcl_Import(Tcl_Interp *interp, Tcl_Namespace *nsPtr,
+EXTERN int TclImport(Tcl_Interp *interp, Tcl_Namespace *nsPtr,
const char *pattern, int allowOverwrite);
/* 128 */
EXTERN void Tcl_PopCallFrame(Tcl_Interp *interp);
@@ -465,10 +465,10 @@ EXTERN void TclVarErrMsg(Tcl_Interp *interp, const char *part1,
const char *part2, const char *operation,
const char *reason);
/* 178 */
-EXTERN void Tcl_SetStartupScript(Tcl_Obj *pathPtr,
+EXTERN void TclSetStartupScript(Tcl_Obj *pathPtr,
const char *encodingName);
/* 179 */
-EXTERN Tcl_Obj * Tcl_GetStartupScript(const char **encodingNamePtr);
+EXTERN Tcl_Obj * TclGetStartupScript(const char **encodingNamePtr);
/* Slot 180 is reserved */
/* Slot 181 is reserved */
/* 182 */
@@ -767,22 +767,22 @@ typedef struct TclIntStubs {
int (*tclUpdateReturnInfo) (Interp *iPtr); /* 109 */
int (*tclSockMinimumBuffers) (void *sock, int size); /* 110 */
void (*tcl_AddInterpResolvers) (Tcl_Interp *interp, const char *name, Tcl_ResolveCmdProc *cmdProc, Tcl_ResolveVarProc *varProc, Tcl_ResolveCompiledVarProc *compiledVarProc); /* 111 */
- int (*tcl_AppendExportList) (Tcl_Interp *interp, Tcl_Namespace *nsPtr, Tcl_Obj *objPtr); /* 112 */
- Tcl_Namespace * (*tcl_CreateNamespace) (Tcl_Interp *interp, const char *name, ClientData clientData, Tcl_NamespaceDeleteProc *deleteProc); /* 113 */
- void (*tcl_DeleteNamespace) (Tcl_Namespace *nsPtr); /* 114 */
- int (*tcl_Export) (Tcl_Interp *interp, Tcl_Namespace *nsPtr, const char *pattern, int resetListFirst); /* 115 */
- Tcl_Command (*tcl_FindCommand) (Tcl_Interp *interp, const char *name, Tcl_Namespace *contextNsPtr, int flags); /* 116 */
- Tcl_Namespace * (*tcl_FindNamespace) (Tcl_Interp *interp, const char *name, Tcl_Namespace *contextNsPtr, int flags); /* 117 */
+ int (*tclAppendExportList) (Tcl_Interp *interp, Tcl_Namespace *nsPtr, Tcl_Obj *objPtr); /* 112 */
+ Tcl_Namespace * (*tclCreateNamespace) (Tcl_Interp *interp, const char *name, ClientData clientData, Tcl_NamespaceDeleteProc *deleteProc); /* 113 */
+ void (*tclDeleteNamespace) (Tcl_Namespace *nsPtr); /* 114 */
+ int (*tclExport) (Tcl_Interp *interp, Tcl_Namespace *nsPtr, const char *pattern, int resetListFirst); /* 115 */
+ Tcl_Command (*tclFindCommand) (Tcl_Interp *interp, const char *name, Tcl_Namespace *contextNsPtr, int flags); /* 116 */
+ Tcl_Namespace * (*tclFindNamespace) (Tcl_Interp *interp, const char *name, Tcl_Namespace *contextNsPtr, int flags); /* 117 */
int (*tcl_GetInterpResolvers) (Tcl_Interp *interp, const char *name, Tcl_ResolverInfo *resInfo); /* 118 */
int (*tcl_GetNamespaceResolvers) (Tcl_Namespace *namespacePtr, Tcl_ResolverInfo *resInfo); /* 119 */
Tcl_Var (*tcl_FindNamespaceVar) (Tcl_Interp *interp, const char *name, Tcl_Namespace *contextNsPtr, int flags); /* 120 */
- int (*tcl_ForgetImport) (Tcl_Interp *interp, Tcl_Namespace *nsPtr, const char *pattern); /* 121 */
- Tcl_Command (*tcl_GetCommandFromObj) (Tcl_Interp *interp, Tcl_Obj *objPtr); /* 122 */
- void (*tcl_GetCommandFullName) (Tcl_Interp *interp, Tcl_Command command, Tcl_Obj *objPtr); /* 123 */
- Tcl_Namespace * (*tcl_GetCurrentNamespace) (Tcl_Interp *interp); /* 124 */
- Tcl_Namespace * (*tcl_GetGlobalNamespace) (Tcl_Interp *interp); /* 125 */
+ int (*tclForgetImport) (Tcl_Interp *interp, Tcl_Namespace *nsPtr, const char *pattern); /* 121 */
+ Tcl_Command (*tclGetCommandFromObj) (Tcl_Interp *interp, Tcl_Obj *objPtr); /* 122 */
+ void (*tclGetCommandFullName) (Tcl_Interp *interp, Tcl_Command command, Tcl_Obj *objPtr); /* 123 */
+ Tcl_Namespace * (*tclGetCurrentNamespace_) (Tcl_Interp *interp); /* 124 */
+ Tcl_Namespace * (*tclGetGlobalNamespace_) (Tcl_Interp *interp); /* 125 */
void (*tcl_GetVariableFullName) (Tcl_Interp *interp, Tcl_Var variable, Tcl_Obj *objPtr); /* 126 */
- int (*tcl_Import) (Tcl_Interp *interp, Tcl_Namespace *nsPtr, const char *pattern, int allowOverwrite); /* 127 */
+ int (*tclImport) (Tcl_Interp *interp, Tcl_Namespace *nsPtr, const char *pattern, int allowOverwrite); /* 127 */
void (*tcl_PopCallFrame) (Tcl_Interp *interp); /* 128 */
int (*tcl_PushCallFrame) (Tcl_Interp *interp, Tcl_CallFrame *framePtr, Tcl_Namespace *nsPtr, int isProcCallFrame); /* 129 */
int (*tcl_RemoveInterpResolvers) (Tcl_Interp *interp, const char *name); /* 130 */
@@ -833,8 +833,8 @@ typedef struct TclIntStubs {
int (*tclCallVarTraces) (Interp *iPtr, Var *arrayPtr, Var *varPtr, const char *part1, const char *part2, int flags, int leaveErrMsg); /* 175 */
void (*tclCleanupVar) (Var *varPtr, Var *arrayPtr); /* 176 */
void (*tclVarErrMsg) (Tcl_Interp *interp, const char *part1, const char *part2, const char *operation, const char *reason); /* 177 */
- void (*tcl_SetStartupScript) (Tcl_Obj *pathPtr, const char *encodingName); /* 178 */
- Tcl_Obj * (*tcl_GetStartupScript) (const char **encodingNamePtr); /* 179 */
+ void (*tclSetStartupScript) (Tcl_Obj *pathPtr, const char *encodingName); /* 178 */
+ Tcl_Obj * (*tclGetStartupScript) (const char **encodingNamePtr); /* 179 */
void (*reserved180)(void);
void (*reserved181)(void);
TCL_DEPRECATED_API("") struct tm * (*tclpLocaltime) (const time_t *clock); /* 182 */
@@ -1099,38 +1099,38 @@ extern const TclIntStubs *tclIntStubsPtr;
(tclIntStubsPtr->tclSockMinimumBuffers) /* 110 */
#define Tcl_AddInterpResolvers \
(tclIntStubsPtr->tcl_AddInterpResolvers) /* 111 */
-#define Tcl_AppendExportList \
- (tclIntStubsPtr->tcl_AppendExportList) /* 112 */
-#define Tcl_CreateNamespace \
- (tclIntStubsPtr->tcl_CreateNamespace) /* 113 */
-#define Tcl_DeleteNamespace \
- (tclIntStubsPtr->tcl_DeleteNamespace) /* 114 */
-#define Tcl_Export \
- (tclIntStubsPtr->tcl_Export) /* 115 */
-#define Tcl_FindCommand \
- (tclIntStubsPtr->tcl_FindCommand) /* 116 */
-#define Tcl_FindNamespace \
- (tclIntStubsPtr->tcl_FindNamespace) /* 117 */
+#define TclAppendExportList \
+ (tclIntStubsPtr->tclAppendExportList) /* 112 */
+#define TclCreateNamespace \
+ (tclIntStubsPtr->tclCreateNamespace) /* 113 */
+#define TclDeleteNamespace \
+ (tclIntStubsPtr->tclDeleteNamespace) /* 114 */
+#define TclExport \
+ (tclIntStubsPtr->tclExport) /* 115 */
+#define TclFindCommand \
+ (tclIntStubsPtr->tclFindCommand) /* 116 */
+#define TclFindNamespace \
+ (tclIntStubsPtr->tclFindNamespace) /* 117 */
#define Tcl_GetInterpResolvers \
(tclIntStubsPtr->tcl_GetInterpResolvers) /* 118 */
#define Tcl_GetNamespaceResolvers \
(tclIntStubsPtr->tcl_GetNamespaceResolvers) /* 119 */
#define Tcl_FindNamespaceVar \
(tclIntStubsPtr->tcl_FindNamespaceVar) /* 120 */
-#define Tcl_ForgetImport \
- (tclIntStubsPtr->tcl_ForgetImport) /* 121 */
-#define Tcl_GetCommandFromObj \
- (tclIntStubsPtr->tcl_GetCommandFromObj) /* 122 */
-#define Tcl_GetCommandFullName \
- (tclIntStubsPtr->tcl_GetCommandFullName) /* 123 */
-#define Tcl_GetCurrentNamespace \
- (tclIntStubsPtr->tcl_GetCurrentNamespace) /* 124 */
-#define Tcl_GetGlobalNamespace \
- (tclIntStubsPtr->tcl_GetGlobalNamespace) /* 125 */
+#define TclForgetImport \
+ (tclIntStubsPtr->tclForgetImport) /* 121 */
+#define TclGetCommandFromObj \
+ (tclIntStubsPtr->tclGetCommandFromObj) /* 122 */
+#define TclGetCommandFullName \
+ (tclIntStubsPtr->tclGetCommandFullName) /* 123 */
+#define TclGetCurrentNamespace_ \
+ (tclIntStubsPtr->tclGetCurrentNamespace_) /* 124 */
+#define TclGetGlobalNamespace_ \
+ (tclIntStubsPtr->tclGetGlobalNamespace_) /* 125 */
#define Tcl_GetVariableFullName \
(tclIntStubsPtr->tcl_GetVariableFullName) /* 126 */
-#define Tcl_Import \
- (tclIntStubsPtr->tcl_Import) /* 127 */
+#define TclImport \
+ (tclIntStubsPtr->tclImport) /* 127 */
#define Tcl_PopCallFrame \
(tclIntStubsPtr->tcl_PopCallFrame) /* 128 */
#define Tcl_PushCallFrame \
@@ -1221,10 +1221,10 @@ extern const TclIntStubs *tclIntStubsPtr;
(tclIntStubsPtr->tclCleanupVar) /* 176 */
#define TclVarErrMsg \
(tclIntStubsPtr->tclVarErrMsg) /* 177 */
-#define Tcl_SetStartupScript \
- (tclIntStubsPtr->tcl_SetStartupScript) /* 178 */
-#define Tcl_GetStartupScript \
- (tclIntStubsPtr->tcl_GetStartupScript) /* 179 */
+#define TclSetStartupScript \
+ (tclIntStubsPtr->tclSetStartupScript) /* 178 */
+#define TclGetStartupScript \
+ (tclIntStubsPtr->tclGetStartupScript) /* 179 */
/* Slot 180 is reserved */
/* Slot 181 is reserved */
#define TclpLocaltime \
@@ -1361,58 +1361,28 @@ extern const TclIntStubs *tclIntStubsPtr;
#undef TCL_STORAGE_CLASS
#define TCL_STORAGE_CLASS DLLIMPORT
-#undef TclGetStartupScriptFileName
-#undef TclSetStartupScriptFileName
-#undef TclGetStartupScriptPath
-#undef TclSetStartupScriptPath
-#undef TclBackgroundException
-
#if defined(USE_TCL_STUBS)
-# undef Tcl_SetStartupScript
-# define Tcl_SetStartupScript \
- (tclStubsPtr->tcl_SetStartupScript) /* 622 */
-# undef Tcl_GetStartupScript
-# define Tcl_GetStartupScript \
- (tclStubsPtr->tcl_GetStartupScript) /* 623 */
-# undef Tcl_CreateNamespace
-# define Tcl_CreateNamespace \
- (tclStubsPtr->tcl_CreateNamespace) /* 506 */
-# undef Tcl_DeleteNamespace
-# define Tcl_DeleteNamespace \
- (tclStubsPtr->tcl_DeleteNamespace) /* 507 */
-# undef Tcl_AppendExportList
-# define Tcl_AppendExportList \
- (tclStubsPtr->tcl_AppendExportList) /* 508 */
-# undef Tcl_Export
-# define Tcl_Export \
- (tclStubsPtr->tcl_Export) /* 509 */
-# undef Tcl_Import
-# define Tcl_Import \
- (tclStubsPtr->tcl_Import) /* 510 */
-# undef Tcl_ForgetImport
-# define Tcl_ForgetImport \
- (tclStubsPtr->tcl_ForgetImport) /* 511 */
-# undef Tcl_GetCurrentNamespace
-# define Tcl_GetCurrentNamespace \
- (tclStubsPtr->tcl_GetCurrentNamespace) /* 512 */
-# undef Tcl_GetGlobalNamespace
-# define Tcl_GetGlobalNamespace \
- (tclStubsPtr->tcl_GetGlobalNamespace) /* 513 */
-# undef Tcl_FindNamespace
-# define Tcl_FindNamespace \
- (tclStubsPtr->tcl_FindNamespace) /* 514 */
-# undef Tcl_FindCommand
-# define Tcl_FindCommand \
- (tclStubsPtr->tcl_FindCommand) /* 515 */
-# undef Tcl_GetCommandFromObj
-# define Tcl_GetCommandFromObj \
- (tclStubsPtr->tcl_GetCommandFromObj) /* 516 */
-# undef Tcl_GetCommandFullName
-# define Tcl_GetCommandFullName \
- (tclStubsPtr->tcl_GetCommandFullName) /* 517 */
+# undef TclGetStartupScriptFileName
+# undef TclSetStartupScriptFileName
+# undef TclGetStartupScriptPath
+# undef TclSetStartupScriptPath
+# undef TclBackgroundException
+# undef TclSetStartupScript
+# undef TclGetStartupScript
+# undef TclCreateNamespace
+# undef TclDeleteNamespace
+# undef TclAppendExportList
+# undef TclExport
+# undef TclImport
+# undef TclForgetImport
+# undef TclGetCurrentNamespace_
+# undef TclGetGlobalNamespace_
+# undef TclFindNamespace
+# undef TclFindCommand
+# undef TclGetCommandFromObj
+# undef TclGetCommandFullName
+# undef TclCopyChannelOld
+# undef TclSockMinimumBuffersOld
#endif
-#undef TclCopyChannelOld
-#undef TclSockMinimumBuffersOld
-
#endif /* _TCLINTDECLS */
diff --git a/generic/tclInterp.c b/generic/tclInterp.c
index d9dfd37..d4bf465 100644
--- a/generic/tclInterp.c
+++ b/generic/tclInterp.c
@@ -3208,10 +3208,6 @@ Tcl_MakeSafe(
(void) Tcl_EvalEx(interp,
"namespace eval ::tcl {namespace eval mathfunc {}}", -1, 0);
- (void) Tcl_CreateAlias(interp, "::tcl::mathfunc::min", master,
- "::tcl::mathfunc::min", 0, NULL);
- (void) Tcl_CreateAlias(interp, "::tcl::mathfunc::max", master,
- "::tcl::mathfunc::max", 0, NULL);
}
iPtr->flags |= SAFE_INTERP;
diff --git a/generic/tclLink.c b/generic/tclLink.c
index 7366acc..53187d7 100644
--- a/generic/tclLink.c
+++ b/generic/tclLink.c
@@ -654,7 +654,7 @@ static Tcl_ObjType invalidRealType = {
NULL, /* freeIntRepProc */
NULL, /* dupIntRepProc */
NULL, /* updateStringProc */
- SetInvalidRealFromAny /* setFromAnyProc */
+ NULL /* setFromAnyProc */
};
static int
diff --git a/generic/tclNamesp.c b/generic/tclNamesp.c
index e1bad0e..d661856 100644
--- a/generic/tclNamesp.c
+++ b/generic/tclNamesp.c
@@ -2424,6 +2424,35 @@ TclGetNamespaceForQualName(
/*
*----------------------------------------------------------------------
*
+ * TclEnsureNamespace --
+ *
+ * Provide a namespace that is not deleted.
+ *
+ * Value
+ *
+ * namespacePtr, if it is not scheduled for deletion, or a pointer to a
+ * new namespace with the same name otherwise.
+ *
+ * Effect
+ * None.
+ *
+ *----------------------------------------------------------------------
+ */
+Tcl_Namespace *
+TclEnsureNamespace(
+ Tcl_Interp *interp,
+ Tcl_Namespace *namespacePtr)
+{
+ Namespace *nsPtr = (Namespace *) namespacePtr;
+ if (!(nsPtr->flags & NS_DYING)) {
+ return namespacePtr;
+ }
+ return Tcl_CreateNamespace(interp, nsPtr->fullName, NULL, NULL);
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
* Tcl_FindNamespace --
*
* Searches for a namespace.
@@ -2638,7 +2667,7 @@ Tcl_FindCommand(
Namespace *nsPtr[2];
register int search;
- TclGetNamespaceForQualName(interp, name, (Namespace *) contextNsPtr,
+ TclGetNamespaceForQualName(interp, name, cxtNsPtr,
flags, &nsPtr[0], &nsPtr[1], &cxtNsPtr, &simpleName);
/*
diff --git a/generic/tclOO.c b/generic/tclOO.c
index e48158c..84380e0 100644
--- a/generic/tclOO.c
+++ b/generic/tclOO.c
@@ -4,6 +4,7 @@
* This file contains the object-system core (NB: not Tcl_Obj, but ::oo)
*
* Copyright (c) 2005-2012 by Donal K. Fellows
+ * Copyright (c) 2017 by Nathan Coulter
*
* See the file "license.terms" for information on usage and redistribution of
* this file, and for a DISCLAIMER OF ALL WARRANTIES.
@@ -58,7 +59,7 @@ static const struct {
static Class * AllocClass(Tcl_Interp *interp, Object *useThisObj);
static Object * AllocObject(Tcl_Interp *interp, const char *nameStr,
- const char *nsNameStr);
+ Namespace *nsPtr, const char *nsNameStr);
static void ClearMixins(Class *clsPtr);
static void ClearSuperclasses(Class *clsPtr);
static int CloneClassMethod(Tcl_Interp *interp, Class *clsPtr,
@@ -82,7 +83,6 @@ static void ObjectRenamedTrace(ClientData clientData,
const char *newName, int flags);
static void ReleaseClassContents(Tcl_Interp *interp,Object *oPtr);
static inline void SquelchCachedName(Object *oPtr);
-static void SquelchedNsFirst(ClientData clientData);
static int PublicObjectCmd(ClientData clientData,
Tcl_Interp *interp, int objc,
@@ -380,9 +380,9 @@ InitFoundation(
*/
fPtr->objectCls = AllocClass(interp,
- AllocObject(interp, "::oo::object", NULL));
+ AllocObject(interp, "object", (Namespace *)fPtr->ooNs, NULL));
fPtr->classCls = AllocClass(interp,
- AllocObject(interp, "::oo::class", NULL));
+ AllocObject(interp, "class", (Namespace *)fPtr->ooNs, NULL));
fPtr->objectCls->thisPtr->selfCls = fPtr->classCls;
fPtr->objectCls->thisPtr->flags |= ROOT_OBJECT;
fPtr->objectCls->flags |= ROOT_OBJECT;
@@ -552,6 +552,8 @@ AllocObject(
* if the OO system should pick the object
* name itself (equal to the namespace
* name). */
+ Namespace *nsPtr, /* The namespace to create the object in,
+ or NULL if *nameStr is NULL */
const char *nsNameStr) /* The name of the namespace to create, or
* NULL if the OO system should pick a unique
* name itself. If this is non-NULL but names
@@ -580,8 +582,7 @@ AllocObject(
*/
if (nsNameStr != NULL) {
- oPtr->namespacePtr = Tcl_CreateNamespace(interp, nsNameStr, oPtr,
- ObjectNamespaceDeleted);
+ oPtr->namespacePtr = Tcl_CreateNamespace(interp, nsNameStr, oPtr, NULL);
if (oPtr->namespacePtr != NULL) {
creationEpoch = ++fPtr->tsdPtr->nsCount;
goto configNamespace;
@@ -593,8 +594,7 @@ AllocObject(
char objName[10 + TCL_INTEGER_SPACE];
sprintf(objName, "::oo::Obj%d", ++fPtr->tsdPtr->nsCount);
- oPtr->namespacePtr = Tcl_CreateNamespace(interp, objName, oPtr,
- ObjectNamespaceDeleted);
+ oPtr->namespacePtr = Tcl_CreateNamespace(interp, objName, oPtr, NULL);
if (oPtr->namespacePtr != NULL) {
creationEpoch = fPtr->tsdPtr->nsCount;
break;
@@ -634,7 +634,7 @@ AllocObject(
* access variables in it. [Bug 2950259]
*/
- ((Namespace *) oPtr->namespacePtr)->earlyDeleteProc = SquelchedNsFirst;
+ ((Namespace *) oPtr->namespacePtr)->earlyDeleteProc = ObjectNamespaceDeleted;
/*
* Fill in the rest of the non-zero/NULL parts of the structure.
@@ -653,23 +653,11 @@ AllocObject(
*/
if (!nameStr) {
- oPtr->command = Tcl_CreateObjCommand(interp,
- oPtr->namespacePtr->fullName, PublicObjectCmd, oPtr, NULL);
- } else if (nameStr[0] == ':' && nameStr[1] == ':') {
- oPtr->command = Tcl_CreateObjCommand(interp, nameStr,
- PublicObjectCmd, oPtr, NULL);
- } else {
- Tcl_DString buffer;
-
- Tcl_DStringInit(&buffer);
- Tcl_DStringAppend(&buffer,
- Tcl_GetCurrentNamespace(interp)->fullName, -1);
- TclDStringAppendLiteral(&buffer, "::");
- Tcl_DStringAppend(&buffer, nameStr, -1);
- oPtr->command = Tcl_CreateObjCommand(interp,
- Tcl_DStringValue(&buffer), PublicObjectCmd, oPtr, NULL);
- Tcl_DStringFree(&buffer);
+ nameStr = oPtr->namespacePtr->name;
+ nsPtr = (Namespace *)oPtr->namespacePtr;
}
+ oPtr->command = TclCreateObjCommandInNs(interp, nameStr,
+ (Tcl_Namespace *)nsPtr, PublicObjectCmd, oPtr, NULL);
/*
* Add the NRE command and trace directly. While this breaks a number of
@@ -755,30 +743,6 @@ MyDeleted(
/*
* ----------------------------------------------------------------------
*
- * SquelchedNsFirst --
- *
- * This callback is triggered when the object's namespace is deleted by
- * any mechanism. It deletes the object's public command if it has not
- * already been deleted, so ensuring that destructors get run at an
- * appropriate time. [Bug 2950259]
- *
- * ----------------------------------------------------------------------
- */
-
-static void
-SquelchedNsFirst(
- ClientData clientData)
-{
- Object *oPtr = clientData;
-
- if (oPtr->command) {
- Tcl_DeleteCommandFromToken(oPtr->fPtr->interp, oPtr->command);
- }
-}
-
-/*
- * ----------------------------------------------------------------------
- *
* ObjectRenamedTrace --
*
* This callback is triggered when the object is deleted by any
@@ -798,8 +762,6 @@ ObjectRenamedTrace(
int flags) /* Why was the object deleted? */
{
Object *oPtr = clientData;
- Foundation *fPtr = oPtr->fPtr;
-
/*
* If this is a rename and not a delete of the object, we just flush the
* cache of the object name.
@@ -811,87 +773,35 @@ ObjectRenamedTrace(
}
/*
- * Oh dear, the object really is being deleted. Handle this by running the
- * destructors and deleting the object's namespace, which in turn causes
- * the real object structures to be deleted.
- *
- * Note that it is possible for the namespace to be deleted before the
- * command. Because of that case, we must take care here to mark the
- * command as being deleted so that if we return here we don't run into
- * reentrancy problems.
- *
- * We also do not run destructors on the core class objects when the
- * interpreter is being deleted; their incestuous nature causes problems
- * in that case when the destructor is partially deleted before the uses
- * of it have gone. [Bug 2949397]
- */
-
- AddRef(oPtr);
- AddRef(fPtr->classCls);
- AddRef(fPtr->objectCls);
- AddRef(fPtr->classCls->thisPtr);
- AddRef(fPtr->objectCls->thisPtr);
- oPtr->command = NULL;
-
- if (!(oPtr->flags & DESTRUCTOR_CALLED) && !Tcl_InterpDeleted(interp)) {
- CallContext *contextPtr =
- TclOOGetCallContext(oPtr, NULL, DESTRUCTOR, NULL);
- int result;
- Tcl_InterpState state;
-
- oPtr->flags |= DESTRUCTOR_CALLED;
- if (contextPtr != NULL) {
- contextPtr->callPtr->flags |= DESTRUCTOR;
- contextPtr->skip = 0;
- state = Tcl_SaveInterpState(interp, TCL_OK);
- result = Tcl_NRCallObjProc(interp, TclOOInvokeContext,
- contextPtr, 0, NULL);
- if (result != TCL_OK) {
- Tcl_BackgroundException(interp, result);
- }
- Tcl_RestoreInterpState(interp, state);
- TclOODeleteContext(contextPtr);
- }
- }
-
- /*
- * OK, the destructor's been run. Time to splat the class data (if any)
- * and nuke the namespace (which triggers the final crushing of the object
- * structure itself).
- *
- * The class of objects needs some special care; if it is deleted (and
- * we're not killing the whole interpreter) we force the delete of the
- * class of classes now as well. Due to the incestuous nature of those two
- * classes, if one goes the other must too and yet the tangle can
- * sometimes not go away automatically; we force it here. [Bug 2962664]
- */
-
- if (!Tcl_InterpDeleted(interp) && IsRootObject(oPtr)
- && !Deleted(fPtr->classCls->thisPtr)) {
- Tcl_DeleteCommandFromToken(interp, fPtr->classCls->thisPtr->command);
- }
-
- if (oPtr->classPtr != NULL) {
- AddRef(oPtr->classPtr);
- ReleaseClassContents(interp, oPtr);
- }
-
- /*
* The namespace is only deleted if it hasn't already been deleted. [Bug
- * 2950259]
+ * 2950259]. If the namespace has already been deleted, then
+ * ObjectNamespaceDeleted() has already cleaned up this command.
*/
- if (oPtr->namespacePtr && ((Namespace *) oPtr->namespacePtr)->earlyDeleteProc != NULL) {
- Tcl_DeleteNamespace(oPtr->namespacePtr);
- }
- if (oPtr->classPtr) {
- DelRef(oPtr->classPtr);
+ if (oPtr->namespacePtr == NULL) {
+ /*
+ * ObjectNamespaceDeleted() has already done all the cleanup, but
+ * detected that the command was in the process of being deleted, and
+ * left the pointer allocated for us.
+ */
+ DelRef(oPtr);
+ } else {
+ if (((Namespace *) oPtr->namespacePtr)->earlyDeleteProc == NULL) {
+ /*
+ * ObjectNamespaceDeleted() called us, and still has some work to
+ * do, so we leave the pointer allocated for it to finish, and then
+ * it will deallocate the pointer.
+ */
+ } else {
+ Tcl_DeleteNamespace(oPtr->namespacePtr);
+ /*
+ * ObjectNamespaceDeleted() doesn't know it was us that just
+ * called, so it left the pointer allocated.
+ */
+ DelRef(oPtr);
+ }
}
- DelRef(fPtr->classCls->thisPtr);
- DelRef(fPtr->objectCls->thisPtr);
- DelRef(fPtr->classCls);
- DelRef(fPtr->objectCls);
- DelRef(oPtr);
+ return;
}
/*
@@ -963,7 +873,9 @@ ReleaseClassContents(
int i;
Class *clsPtr = oPtr->classPtr, *mixinSubclassPtr, *subclassPtr;
Object *instancePtr;
+ Method *mPtr;
Foundation *fPtr = oPtr->fPtr;
+ Tcl_Obj *variableObj;
/*
* Sanity check!
@@ -1001,28 +913,30 @@ ReleaseClassContents(
}
if (!IsRootClass(oPtr)) {
FOREACH(instancePtr, clsPtr->instances) {
- int j;
- if (instancePtr->selfCls == clsPtr) {
- instancePtr->flags |= CLASS_GONE;
- }
- for(j=0 ; j<instancePtr->mixins.num ; j++) {
- Class *mixin = instancePtr->mixins.list[j];
- Class *nextMixin = NULL;
- if (mixin == clsPtr) {
- 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;
+ if (instancePtr != oPtr) {
+ int j;
+ if (instancePtr->selfCls == clsPtr) {
+ instancePtr->flags |= CLASS_GONE;
+ }
+ for(j=0 ; j<instancePtr->mixins.num ; j++) {
+ Class *mixin = instancePtr->mixins.list[j];
+ Class *nextMixin = NULL;
+ if (mixin == clsPtr) {
+ 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;
}
- instancePtr->mixins.num -= 1;
}
- }
- if (instancePtr != NULL && !IsRoot(instancePtr)) {
- AddRef(instancePtr);
+ if (instancePtr != NULL && !IsRoot(instancePtr)) {
+ AddRef(instancePtr);
+ }
}
}
}
@@ -1032,13 +946,15 @@ ReleaseClassContents(
*/
FOREACH(mixinSubclassPtr, clsPtr->mixinSubs) {
- if (!Deleted(mixinSubclassPtr->thisPtr)) {
- Tcl_DeleteCommandFromToken(interp,
- mixinSubclassPtr->thisPtr->command);
+ if (mixinSubclassPtr != clsPtr) {
+ if (!Deleted(mixinSubclassPtr->thisPtr)) {
+ Tcl_DeleteCommandFromToken(interp,
+ mixinSubclassPtr->thisPtr->command);
+ }
+ ClearMixins(mixinSubclassPtr);
+ DelRef(mixinSubclassPtr->thisPtr);
+ DelRef(mixinSubclassPtr);
}
- ClearMixins(mixinSubclassPtr);
- DelRef(mixinSubclassPtr->thisPtr);
- DelRef(mixinSubclassPtr);
}
if (clsPtr->mixinSubs.list != NULL) {
ckfree(clsPtr->mixinSubs.list);
@@ -1073,19 +989,21 @@ ReleaseClassContents(
if (!IsRootClass(oPtr)) {
FOREACH(instancePtr, clsPtr->instances) {
- if (instancePtr == NULL || IsRoot(instancePtr)) {
- continue;
- }
- if (!Deleted(instancePtr)) {
- Tcl_DeleteCommandFromToken(interp, instancePtr->command);
- /*
- * Tcl_DeleteCommandFromToken() may have done to whole
- * job for us. Roll back and check again.
- */
- i--;
- continue;
+ if (instancePtr != oPtr) {
+ if (instancePtr == NULL || IsRoot(instancePtr)) {
+ continue;
+ }
+ if (!Deleted(instancePtr)) {
+ Tcl_DeleteCommandFromToken(interp, instancePtr->command);
+ /*
+ * Tcl_DeleteCommandFromToken() may have done to whole
+ * job for us. Roll back and check again.
+ */
+ i--;
+ continue;
+ }
+ DelRef(instancePtr);
}
- DelRef(instancePtr);
}
}
if (clsPtr->instances.list != NULL) {
@@ -1154,6 +1072,30 @@ ReleaseClassContents(
ckfree(clsPtr->metadataPtr);
clsPtr->metadataPtr = NULL;
}
+
+ ClearMixins(clsPtr);
+ ClearSuperclasses(clsPtr);
+
+ FOREACH_HASH_VALUE(mPtr, &clsPtr->classMethods) {
+ TclOODelMethodRef(mPtr);
+ }
+ Tcl_DeleteHashTable(&clsPtr->classMethods);
+ TclOODelMethodRef(clsPtr->constructorPtr);
+ TclOODelMethodRef(clsPtr->destructorPtr);
+
+ FOREACH(variableObj, clsPtr->variables) {
+ TclDecrRefCount(variableObj);
+ }
+ if (i) {
+ ckfree(clsPtr->variables.list);
+ }
+
+ /* Tell oPtr that it's class is gone so that it doesn't try to remove
+ * itself from it's classe's list of instances
+ */
+ oPtr->flags |= CLASS_GONE;
+ DelRef(clsPtr);
+
}
/*
@@ -1175,31 +1117,71 @@ ObjectNamespaceDeleted(
* being deleted. */
{
Object *oPtr = clientData;
+ Foundation *fPtr = oPtr->fPtr;
FOREACH_HASH_DECLS;
- Class *clsPtr = oPtr->classPtr, *mixinPtr;
+ Class *mixinPtr;
Method *mPtr;
Tcl_Obj *filterObj, *variableObj;
- int deleteAlreadyInProgress = 0, i;
+ Tcl_Interp *interp = oPtr->fPtr->interp;
+ int finished = 0, i;
+
+
+ AddRef(fPtr->classCls);
+ AddRef(fPtr->objectCls);
+ AddRef(fPtr->classCls->thisPtr);
+ AddRef(fPtr->objectCls->thisPtr);
/*
- * Instruct everyone to no longer use any allocated fields of the object.
- * Also delete the commands that refer to the object at this point (if
- * they still exist) because otherwise their references to the object
- * point into freed memory, allowing crashes.
+ * We do not run destructors on the core class objects when the
+ * interpreter is being deleted; their incestuous nature causes problems
+ * in that case when the destructor is partially deleted before the uses
+ * of it have gone. [Bug 2949397]
*/
- if (oPtr->command) {
- if ((((Command *)oPtr->command)->flags && CMD_IS_DELETED)) {
- /*
- * Namespace deletion must have been triggered by a trace on command
- * deletion , meaning that ObjectRenamedTrace() is eventually going
- * to be called .
- */
- deleteAlreadyInProgress = 1;
+ if (!(oPtr->flags & DESTRUCTOR_CALLED) && !Tcl_InterpDeleted(interp)) {
+ CallContext *contextPtr =
+ TclOOGetCallContext(oPtr, NULL, DESTRUCTOR, NULL);
+ int result;
+
+ Tcl_InterpState state;
+
+ oPtr->flags |= DESTRUCTOR_CALLED;
+ if (contextPtr != NULL) {
+ contextPtr->callPtr->flags |= DESTRUCTOR;
+ contextPtr->skip = 0;
+ state = Tcl_SaveInterpState(interp, TCL_OK);
+ result = Tcl_NRCallObjProc(interp, TclOOInvokeContext,
+ contextPtr, 0, NULL);
+ if (result != TCL_OK) {
+ Tcl_BackgroundException(interp, result);
+ }
+ Tcl_RestoreInterpState(interp, state);
+ TclOODeleteContext(contextPtr);
}
+ }
+
+ /*
+ * Instruct everyone to no longer use any allocated fields of the object.
+ * Also delete the command that refers to the object at this point (if
+ * it still exists) because otherwise its pointer to the object
+ * points into freed memory.
+ */
+ if ((((Command *)oPtr->command)->flags && CMD_IS_DELETED)) {
+ /*
+ * Something has already started the command deletion process. We can
+ * go ahead and clean up the the namespace,
+ */
+ } else {
+ /*
+ * The namespace must have been deleted directly. Delete the command
+ * as well.
+ */
Tcl_DeleteCommandFromToken(oPtr->fPtr->interp, oPtr->command);
+ finished = 1;
}
+ oPtr->command = NULL;
+
if (oPtr->myCommand) {
Tcl_DeleteCommandFromToken(oPtr->fPtr->interp, oPtr->myCommand);
}
@@ -1214,7 +1196,7 @@ ObjectNamespaceDeleted(
}
FOREACH(mixinPtr, oPtr->mixins) {
- if (mixinPtr) {
+ if (mixinPtr && mixinPtr != oPtr->classPtr) {
TclOORemoveFromInstances(oPtr, mixinPtr);
}
}
@@ -1263,77 +1245,51 @@ ObjectNamespaceDeleted(
}
/*
- * If this was a class, there's additional deletion work to do.
+ * Because an object can be a class that is an instance of itself, the
+ * A class object's class structure should only be cleaned after most of
+ * the cleanup on the object is done.
*/
- if (clsPtr != NULL) {
- Tcl_ObjectMetadataType *metadataTypePtr;
- ClientData value;
-
- if (clsPtr->metadataPtr != NULL) {
- FOREACH_HASH(metadataTypePtr, value, clsPtr->metadataPtr) {
- metadataTypePtr->deleteProc(value);
- }
- Tcl_DeleteHashTable(clsPtr->metadataPtr);
- ckfree(clsPtr->metadataPtr);
- clsPtr->metadataPtr = NULL;
- }
- FOREACH(filterObj, clsPtr->filters) {
- TclDecrRefCount(filterObj);
- }
- if (i) {
- ckfree(clsPtr->filters.list);
- clsPtr->filters.num = 0;
- }
-
- ClearMixins(clsPtr);
-
- ClearSuperclasses(clsPtr);
-
- if (clsPtr->subclasses.list) {
- ckfree(clsPtr->subclasses.list);
- clsPtr->subclasses.list = NULL;
- clsPtr->subclasses.num = 0;
- }
- if (clsPtr->instances.list) {
- ckfree(clsPtr->instances.list);
- clsPtr->instances.list = NULL;
- clsPtr->instances.num = 0;
- }
- if (clsPtr->mixinSubs.list) {
- ckfree(clsPtr->mixinSubs.list);
- clsPtr->mixinSubs.list = NULL;
- clsPtr->mixinSubs.num = 0;
- }
-
- FOREACH_HASH_VALUE(mPtr, &clsPtr->classMethods) {
- TclOODelMethodRef(mPtr);
- }
- Tcl_DeleteHashTable(&clsPtr->classMethods);
- TclOODelMethodRef(clsPtr->constructorPtr);
- TclOODelMethodRef(clsPtr->destructorPtr);
-
- FOREACH(variableObj, clsPtr->variables) {
- TclDecrRefCount(variableObj);
- }
- if (i) {
- ckfree(clsPtr->variables.list);
- }
+ /*
+ * The class of objects needs some special care; if it is deleted (and
+ * we're not killing the whole interpreter) we force the delete of the
+ * class of classes now as well. Due to the incestuous nature of those two
+ * classes, if one goes the other must too and yet the tangle can
+ * sometimes not go away automatically; we force it here. [Bug 2962664]
+ */
+ if (!Tcl_InterpDeleted(interp) && IsRootObject(oPtr)
+ && !Deleted(fPtr->classCls->thisPtr)) {
+ Tcl_DeleteCommandFromToken(interp, fPtr->classCls->thisPtr->command);
+ }
- DelRef(clsPtr);
+ if (oPtr->classPtr != NULL) {
+ ReleaseClassContents(interp, oPtr);
}
+
/*
* Delete the object structure itself.
*/
- if (deleteAlreadyInProgress) {
- oPtr->classPtr = NULL;
- oPtr->namespacePtr = NULL;
- } else {
+ oPtr->classPtr = NULL;
+ oPtr->namespacePtr = NULL;
+
+ DelRef(fPtr->classCls->thisPtr);
+ DelRef(fPtr->objectCls->thisPtr);
+ DelRef(fPtr->classCls);
+ DelRef(fPtr->objectCls);
+ if (finished) {
+ /*
+ * ObjectRenamedTrace called us, and not the other way around.
+ */
DelRef(oPtr);
+ } else {
+ /*
+ * ObjectRenamedTrace will call DelRef(oPtr).
+ */
}
+ return;
}
@@ -1427,7 +1383,7 @@ TclOOAddToInstances(
void
TclOORemoveFromSubclasses(
Class *subPtr, /* The subclass to remove. */
- Class *superPtr) /* The superclass to (possibly) remove the
+ Class *superPtr) /* The superclass to possibly remove the
* subclass reference from. */
{
int i;
@@ -1498,7 +1454,7 @@ TclOOAddToSubclasses(
void
TclOORemoveFromMixinSubs(
Class *subPtr, /* The subclass to remove. */
- Class *superPtr) /* The superclass to (possibly) remove the
+ Class *superPtr) /* The superclass to possibly remove the
* subclass reference from. */
{
int i;
@@ -1572,7 +1528,7 @@ AllocClass(
* class. */
Object *useThisObj) /* Object that is to act as the class
* representation, or NULL if a new object
- * (with automatic name) is to be used. */
+ * with automatic name is to be used. */
{
Foundation *fPtr = GetFoundation(interp);
Class *clsPtr = ckalloc(sizeof(Class));
@@ -1583,7 +1539,7 @@ AllocClass(
memset(clsPtr, 0, sizeof(Class));
if (useThisObj == NULL) {
- clsPtr->thisPtr = AllocObject(interp, NULL, NULL);
+ clsPtr->thisPtr = AllocObject(interp, NULL, NULL, NULL);
} else {
clsPtr->thisPtr = useThisObj;
}
@@ -1644,7 +1600,6 @@ AllocClass(
*
* ----------------------------------------------------------------------
*/
-
Tcl_Object
Tcl_NewObjectInstance(
Tcl_Interp *interp, /* Interpreter context. */
@@ -1661,54 +1616,15 @@ Tcl_NewObjectInstance(
* constructor. */
{
register Class *classPtr = (Class *) cls;
- Foundation *fPtr = GetFoundation(interp);
Object *oPtr;
+ ClientData clientData[4];
- /*
- * Check if we're going to create an object over an existing command;
- * that's not allowed.
- */
-
- if (nameStr && Tcl_FindCommand(interp, nameStr, NULL,
- TCL_NAMESPACE_ONLY)) {
- Tcl_SetObjResult(interp, Tcl_ObjPrintf(
- "can't create object \"%s\": command already exists with"
- " that name", nameStr));
- Tcl_SetErrorCode(interp, "TCL", "OO", "OVERWRITE_OBJECT", NULL);
- return NULL;
- }
-
- /*
- * Create the object.
- */
-
- oPtr = AllocObject(interp, nameStr, nsNameStr);
- oPtr->selfCls = classPtr;
- TclOOAddToInstances(oPtr, classPtr);
-
- /*
- * Check to see if we're really creating a class. If so, allocate the
- * class structure as well.
- */
-
- if (TclOOIsReachable(fPtr->classCls, classPtr)) {
- /*
- * Is a class, so attach a class structure. Note that the AllocClass
- * function splices the structure into the object, so we don't have
- * to. Once that's done, we need to repatch the object to have the
- * right class since AllocClass interferes with that.
- */
-
- AllocClass(interp, oPtr);
- oPtr->selfCls = classPtr;
- TclOOAddToSubclasses(oPtr->classPtr, fPtr->objectCls);
- } else {
- oPtr->classPtr = NULL;
- }
+ oPtr = TclNewObjectInstanceCommon(interp, classPtr, nameStr, nsNameStr);
+ if (oPtr == NULL) {return NULL;}
/*
- * Run constructors, except when objc < 0 (a special flag case used for
- * object cloning only).
+ * Run constructors, except when objc < 0, which is a special flag case
+ * used for object cloning only.
*/
if (objc >= 0) {
@@ -1735,36 +1651,16 @@ Tcl_NewObjectInstance(
TclResetRewriteEnsemble(interp, 1);
}
- /*
- * It's an error if the object was whacked in the constructor.
- * Force this if it isn't already an error (don't want to lose
- * errors by accident...) [Bug 2903011]
- */
+ clientData[0] = contextPtr;
+ clientData[1] = oPtr;
+ clientData[2] = state;
+ clientData[3] = &oPtr;
- if (result != TCL_ERROR && Deleted(oPtr)) {
- Tcl_SetObjResult(interp, Tcl_NewStringObj(
- "object deleted in constructor", -1));
- Tcl_SetErrorCode(interp, "TCL", "OO", "STILLBORN", NULL);
- result = TCL_ERROR;
- }
- TclOODeleteContext(contextPtr);
+ AddRef(oPtr);
+ result = FinalizeAlloc(clientData, interp, result);
if (result != TCL_OK) {
- Tcl_DiscardInterpState(state);
-
- /*
- * Take care to not delete a deleted object; that would be
- * bad. [Bug 2903011] Also take care to make sure that we have
- * the name of the command before we delete it. [Bug
- * 9dd1bd7a74]
- */
-
- if (!Deleted(oPtr)) {
- (void) TclOOObjectName(interp, oPtr);
- Tcl_DeleteCommandFromToken(interp, oPtr->command);
- }
return NULL;
}
- Tcl_RestoreInterpState(interp, state);
}
}
@@ -1789,50 +1685,12 @@ TclNRNewObjectInstance(
* successful allocation. */
{
register Class *classPtr = (Class *) cls;
- Foundation *fPtr = GetFoundation(interp);
CallContext *contextPtr;
Tcl_InterpState state;
Object *oPtr;
- /*
- * Check if we're going to create an object over an existing command;
- * that's not allowed.
- */
-
- if (nameStr && Tcl_FindCommand(interp, nameStr, NULL,
- TCL_NAMESPACE_ONLY)) {
- Tcl_SetObjResult(interp, Tcl_ObjPrintf(
- "can't create object \"%s\": command already exists with"
- " that name", nameStr));
- Tcl_SetErrorCode(interp, "TCL", "OO", "OVERWRITE_OBJECT", NULL);
- return TCL_ERROR;
- }
-
- /*
- * Create the object.
- */
-
- oPtr = AllocObject(interp, nameStr, nsNameStr);
- oPtr->selfCls = classPtr;
- TclOOAddToInstances(oPtr, classPtr);
-
- /*
- * Check to see if we're really creating a class. If so, allocate the
- * class structure as well.
- */
-
- if (TclOOIsReachable(fPtr->classCls, classPtr)) {
- /*
- * Is a class, so attach a class structure. Note that the AllocClass
- * function splices the structure into the object, so we don't have
- * to. Once that's done, we need to repatch the object to have the
- * right class since AllocClass interferes with that.
- */
-
- AllocClass(interp, oPtr);
- oPtr->selfCls = classPtr;
- TclOOAddToSubclasses(oPtr->classPtr, fPtr->objectCls);
- }
+ oPtr = TclNewObjectInstanceCommon(interp, classPtr, nameStr, nsNameStr);
+ if (oPtr == NULL) {return TCL_ERROR;}
/*
* Run constructors, except when objc < 0 (a special flag case used for
@@ -1854,7 +1712,7 @@ TclNRNewObjectInstance(
contextPtr->skip = skip;
/*
- * Adjust the ensmble tracking record if necessary. [Bug 3514761]
+ * Adjust the ensemble tracking record if necessary. [Bug 3514761]
*/
if (TclInitRewriteEnsemble(interp, skip, skip, objv)) {
@@ -1872,6 +1730,83 @@ TclNRNewObjectInstance(
return TclOOInvokeContext(contextPtr, interp, objc, objv);
}
+
+Object *
+TclNewObjectInstanceCommon(
+ Tcl_Interp *interp,
+ Class *classPtr,
+ const char *nameStr,
+ const char *nsNameStr)
+{
+ Tcl_HashEntry *hPtr;
+ Foundation *fPtr = GetFoundation(interp);
+ Object *oPtr;
+ const char *simpleName = NULL;
+ Namespace *nsPtr = NULL, *dummy,
+ *inNsPtr = (Namespace *)TclGetCurrentNamespace(interp);
+ int isNew;
+
+ if (nameStr) {
+ TclGetNamespaceForQualName(interp, nameStr, inNsPtr, TCL_CREATE_NS_IF_UNKNOWN,
+ &nsPtr, &dummy, &dummy, &simpleName);
+
+ /*
+ * Disallow creation of an object over an existing command.
+ */
+
+ hPtr = Tcl_CreateHashEntry(&nsPtr->cmdTable, simpleName, &isNew);
+ if (isNew) {
+ /* Just kidding */
+ Tcl_DeleteHashEntry(hPtr);
+ } else {
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "can't create object \"%s\": command already exists with"
+ " that name", nameStr));
+ Tcl_SetErrorCode(interp, "TCL", "OO", "OVERWRITE_OBJECT", NULL);
+ return NULL;
+ }
+ }
+
+ /*
+ * Create the object.
+ */
+
+ /*
+ * The command for the object could have the same name as the command
+ * associated with classPtr, so protect the structure from deallocation
+ * here.
+ */
+ AddRef(classPtr);
+
+ oPtr = AllocObject(interp, simpleName, nsPtr, nsNameStr);
+ DelRef(classPtr);
+ oPtr->selfCls = classPtr;
+ TclOOAddToInstances(oPtr, classPtr);
+
+ /*
+ * Check to see if we're really creating a class. If so, allocate the
+ * class structure as well.
+ */
+
+ if (TclOOIsReachable(fPtr->classCls, classPtr)) {
+ /*
+ * Is a class, so attach a class structure. Note that the AllocClass
+ * function splices the structure into the object, so we don't have
+ * to. Once that's done, we need to repatch the object to have the
+ * right class since AllocClass interferes with that.
+ */
+
+ AllocClass(interp, oPtr);
+ oPtr->selfCls = classPtr;
+ TclOOAddToSubclasses(oPtr->classPtr, fPtr->objectCls);
+ } else {
+ oPtr->classPtr = NULL;
+ }
+ return oPtr;
+}
+
+
+
static int
FinalizeAlloc(
ClientData data[],
@@ -1884,9 +1819,8 @@ FinalizeAlloc(
Tcl_Object *objectPtr = data[3];
/*
- * It's an error if the object was whacked in the constructor. Force this
- * if it isn't already an error (don't want to lose errors by accident...)
- * [Bug 2903011]
+ * Ensure an error if the object was deleted in the constructor.
+ * Don't want to lose errors by accident. [Bug 2903011]
*/
if (result != TCL_ERROR && Deleted(oPtr)) {
diff --git a/generic/tclOOInt.h b/generic/tclOOInt.h
index 11ba698..83b4d58 100644
--- a/generic/tclOOInt.h
+++ b/generic/tclOOInt.h
@@ -495,6 +495,10 @@ MODULE_SCOPE int TclNRNewObjectInstance(Tcl_Interp *interp,
const char *nsNameStr, int objc,
Tcl_Obj *const *objv, int skip,
Tcl_Object *objectPtr);
+MODULE_SCOPE Object * TclNewObjectInstanceCommon(Tcl_Interp *interp,
+ Class *classPtr,
+ const char *nameStr,
+ const char *nsNameStr);
MODULE_SCOPE int TclOODefineSlots(Foundation *fPtr);
MODULE_SCOPE void TclOODeleteChain(CallChain *callPtr);
MODULE_SCOPE void TclOODeleteChainCache(Tcl_HashTable *tablePtr);
diff --git a/generic/tclProc.c b/generic/tclProc.c
index 6a0ed75..8f8a4d5 100644
--- a/generic/tclProc.c
+++ b/generic/tclProc.c
@@ -124,11 +124,10 @@ Tcl_ProcObjCmd(
{
register Interp *iPtr = (Interp *) interp;
Proc *procPtr;
- const char *fullName;
- const char *procName, *procArgs, *procBody;
+ const char *procName;
+ const char *simpleName, *procArgs, *procBody;
Namespace *nsPtr, *altNsPtr, *cxtNsPtr;
Tcl_Command cmd;
- Tcl_DString ds;
if (objc != 4) {
Tcl_WrongNumArgs(interp, 1, objv, "name args body");
@@ -141,29 +140,21 @@ Tcl_ProcObjCmd(
* namespace.
*/
- fullName = TclGetString(objv[1]);
- TclGetNamespaceForQualName(interp, fullName, NULL, 0,
- &nsPtr, &altNsPtr, &cxtNsPtr, &procName);
+ procName = TclGetString(objv[1]);
+ TclGetNamespaceForQualName(interp, procName, NULL, 0,
+ &nsPtr, &altNsPtr, &cxtNsPtr, &simpleName);
if (nsPtr == NULL) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"can't create procedure \"%s\": unknown namespace",
- fullName));
+ procName));
Tcl_SetErrorCode(interp, "TCL", "VALUE", "COMMAND", NULL);
return TCL_ERROR;
}
- if (procName == NULL) {
+ if (simpleName == NULL) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"can't create procedure \"%s\": bad procedure name",
- fullName));
- Tcl_SetErrorCode(interp, "TCL", "VALUE", "COMMAND", NULL);
- return TCL_ERROR;
- }
- if ((nsPtr != iPtr->globalNsPtr)
- && (procName != NULL) && (procName[0] == ':')) {
- Tcl_SetObjResult(interp, Tcl_ObjPrintf(
- "can't create procedure \"%s\" in non-global namespace with"
- " name starting with \":\"", procName));
+ procName));
Tcl_SetErrorCode(interp, "TCL", "VALUE", "COMMAND", NULL);
return TCL_ERROR;
}
@@ -172,31 +163,16 @@ Tcl_ProcObjCmd(
* Create the data structure to represent the procedure.
*/
- if (TclCreateProc(interp, nsPtr, procName, objv[2], objv[3],
+ if (TclCreateProc(interp, nsPtr, simpleName, objv[2], objv[3],
&procPtr) != TCL_OK) {
Tcl_AddErrorInfo(interp, "\n (creating proc \"");
- Tcl_AddErrorInfo(interp, procName);
+ Tcl_AddErrorInfo(interp, simpleName);
Tcl_AddErrorInfo(interp, "\")");
return TCL_ERROR;
}
- /*
- * Now create a command for the procedure. This will initially be in the
- * current namespace unless the procedure's name included namespace
- * qualifiers. To create the new command in the right namespace, we
- * generate a fully qualified name for it.
- */
-
- Tcl_DStringInit(&ds);
- if (nsPtr != iPtr->globalNsPtr) {
- Tcl_DStringAppend(&ds, nsPtr->fullName, -1);
- TclDStringAppendLiteral(&ds, "::");
- }
- Tcl_DStringAppend(&ds, procName, -1);
-
- cmd = Tcl_NRCreateCommand(interp, Tcl_DStringValue(&ds), TclObjInterpProc,
- TclNRInterpProc, procPtr, TclProcDeleteProc);
- Tcl_DStringFree(&ds);
+ cmd = TclNRCreateCommandInNs(interp, simpleName, (Tcl_Namespace *) nsPtr,
+ TclObjInterpProc, TclNRInterpProc, procPtr, TclProcDeleteProc);
/*
* Now initialize the new procedure's cmdPtr field. This will be used
diff --git a/generic/tclScan.c b/generic/tclScan.c
index 7f71262..e0798df 100644
--- a/generic/tclScan.c
+++ b/generic/tclScan.c
@@ -889,7 +889,7 @@ Tcl_ScanObjCmd(
i = (int)sch;
#if TCL_UTF_MAX == 4
if (!offset) {
- offset = Tcl_UtfToUniChar(string, &sch);
+ offset = TclUtfToUniChar(string, &sch);
i = (((i<<10) & 0x0FFC00) + 0x10000) + (sch & 0x3FF);
}
#endif
diff --git a/generic/tclStringObj.c b/generic/tclStringObj.c
index 547f7c6..85cac83 100644
--- a/generic/tclStringObj.c
+++ b/generic/tclStringObj.c
@@ -418,12 +418,16 @@ Tcl_GetCharLength(
}
/*
- * Optimize the case where we're really dealing with a bytearray object
- * without string representation; we don't need to convert to a string to
- * perform the get-length operation.
+ * Optimize the case where we're really dealing with a bytearray object;
+ * we don't need to convert to a string to perform the get-length operation.
+ *
+ * NOTE that we do not need the bytearray to be "pure". A ByteArray value
+ * with a string rep cannot be trusted to represent the same value as the
+ * string rep, but it *can* be trusted to have the same character length
+ * as the string rep, which is all this routine cares about.
*/
- if (TclIsPureByteArray(objPtr)) {
+ if (objPtr->typePtr == &tclByteArrayType) {
int length;
(void) Tcl_GetByteArrayFromObj(objPtr, &length);
@@ -1869,20 +1873,20 @@ Tcl_AppendFormatToObj(
} else if (ch == 'I') {
if ((format[1] == '6') && (format[2] == '4')) {
format += (step + 2);
- step = Tcl_UtfToUniChar(format, &ch);
+ step = TclUtfToUniChar(format, &ch);
#ifndef TCL_WIDE_INT_IS_LONG
useWide = 1;
#endif
} else if ((format[1] == '3') && (format[2] == '2')) {
format += (step + 2);
- step = Tcl_UtfToUniChar(format, &ch);
+ step = TclUtfToUniChar(format, &ch);
} else {
format += step;
- step = Tcl_UtfToUniChar(format, &ch);
+ step = TclUtfToUniChar(format, &ch);
}
} else if ((ch == 't') || (ch == 'z')) {
format += step;
- step = Tcl_UtfToUniChar(format, &ch);
+ step = TclUtfToUniChar(format, &ch);
#ifndef TCL_WIDE_INT_IS_LONG
if (sizeof(size_t) > sizeof(int)) {
useWide = 1;
@@ -1890,7 +1894,7 @@ Tcl_AppendFormatToObj(
#endif
} else if ((ch == 'q') ||(ch == 'j')) {
format += step;
- step = Tcl_UtfToUniChar(format, &ch);
+ step = TclUtfToUniChar(format, &ch);
#ifndef TCL_WIDE_INT_IS_LONG
useWide = 1;
#endif
diff --git a/generic/tclStubInit.c b/generic/tclStubInit.c
index c8b4dce..2b6ece4 100644
--- a/generic/tclStubInit.c
+++ b/generic/tclStubInit.c
@@ -366,6 +366,26 @@ static int formatInt(char *buffer, int n){
# define TclBackgroundException 0
# undef TclpReaddir
# define TclpReaddir 0
+# define TclSetStartupScript 0
+# define TclGetStartupScript 0
+# define TclCreateNamespace 0
+# define TclDeleteNamespace 0
+# define TclAppendExportList 0
+# define TclExport 0
+# define TclImport 0
+# define TclForgetImport 0
+# define TclGetCurrentNamespace_ 0
+# define TclGetGlobalNamespace_ 0
+# define TclFindNamespace 0
+# define TclFindCommand 0
+# define TclGetCommandFromObj 0
+# define TclGetCommandFullName 0
+# define TclCopyChannelOld 0
+# define Tcl_AppendResultVA 0
+# define Tcl_AppendStringsToObjVA 0
+# define Tcl_SetErrorCodeVA 0
+# define Tcl_PanicVA 0
+# define Tcl_VarEvalVA 0
# undef TclpGetDate
# define TclpGetDate 0
# undef TclpLocaltime
@@ -378,6 +398,20 @@ static int formatInt(char *buffer, int n){
# define Tcl_SeekOld seekOld
# define Tcl_TellOld tellOld
# define TclBackgroundException Tcl_BackgroundException
+# define TclSetStartupScript Tcl_SetStartupScript
+# define TclGetStartupScript Tcl_GetStartupScript
+# define TclCreateNamespace Tcl_CreateNamespace
+# define TclDeleteNamespace Tcl_DeleteNamespace
+# define TclAppendExportList Tcl_AppendExportList
+# define TclExport Tcl_Export
+# define TclImport Tcl_Import
+# define TclForgetImport Tcl_ForgetImport
+# define TclGetCurrentNamespace_ Tcl_GetCurrentNamespace
+# define TclGetGlobalNamespace_ Tcl_GetGlobalNamespace
+# define TclFindNamespace Tcl_FindNamespace
+# define TclFindCommand Tcl_FindCommand
+# define TclGetCommandFromObj Tcl_GetCommandFromObj
+# define TclGetCommandFullName Tcl_GetCommandFullName
# define TclpLocaltime_unix TclpLocaltime
# define TclpGmtime_unix TclpGmtime
@@ -530,22 +564,22 @@ static const TclIntStubs tclIntStubs = {
TclUpdateReturnInfo, /* 109 */
TclSockMinimumBuffers, /* 110 */
Tcl_AddInterpResolvers, /* 111 */
- Tcl_AppendExportList, /* 112 */
- Tcl_CreateNamespace, /* 113 */
- Tcl_DeleteNamespace, /* 114 */
- Tcl_Export, /* 115 */
- Tcl_FindCommand, /* 116 */
- Tcl_FindNamespace, /* 117 */
+ TclAppendExportList, /* 112 */
+ TclCreateNamespace, /* 113 */
+ TclDeleteNamespace, /* 114 */
+ TclExport, /* 115 */
+ TclFindCommand, /* 116 */
+ TclFindNamespace, /* 117 */
Tcl_GetInterpResolvers, /* 118 */
Tcl_GetNamespaceResolvers, /* 119 */
Tcl_FindNamespaceVar, /* 120 */
- Tcl_ForgetImport, /* 121 */
- Tcl_GetCommandFromObj, /* 122 */
- Tcl_GetCommandFullName, /* 123 */
- Tcl_GetCurrentNamespace, /* 124 */
- Tcl_GetGlobalNamespace, /* 125 */
+ TclForgetImport, /* 121 */
+ TclGetCommandFromObj, /* 122 */
+ TclGetCommandFullName, /* 123 */
+ TclGetCurrentNamespace_, /* 124 */
+ TclGetGlobalNamespace_, /* 125 */
Tcl_GetVariableFullName, /* 126 */
- Tcl_Import, /* 127 */
+ TclImport, /* 127 */
Tcl_PopCallFrame, /* 128 */
Tcl_PushCallFrame, /* 129 */
Tcl_RemoveInterpResolvers, /* 130 */
@@ -596,8 +630,8 @@ static const TclIntStubs tclIntStubs = {
TclCallVarTraces, /* 175 */
TclCleanupVar, /* 176 */
TclVarErrMsg, /* 177 */
- Tcl_SetStartupScript, /* 178 */
- Tcl_GetStartupScript, /* 179 */
+ TclSetStartupScript, /* 178 */
+ TclGetStartupScript, /* 179 */
0, /* 180 */
0, /* 181 */
TclpLocaltime, /* 182 */
diff --git a/generic/tclTest.c b/generic/tclTest.c
index 834cd79..7fb1f29 100644
--- a/generic/tclTest.c
+++ b/generic/tclTest.c
@@ -424,6 +424,12 @@ static Tcl_FSMatchInDirectoryProc SimpleMatchInDirectory;
static int TestNumUtfCharsCmd(ClientData clientData,
Tcl_Interp *interp, int objc,
Tcl_Obj *const objv[]);
+static int TestFindFirstCmd(ClientData clientData,
+ Tcl_Interp *interp, int objc,
+ Tcl_Obj *const objv[]);
+static int TestFindLastCmd(ClientData clientData,
+ Tcl_Interp *interp, int objc,
+ Tcl_Obj *const objv[]);
static int TestHashSystemHashCmd(ClientData clientData,
Tcl_Interp *interp, int objc,
Tcl_Obj *const objv[]);
@@ -692,6 +698,10 @@ Tcltest_Init(
TestsetobjerrorcodeCmd, NULL, NULL);
Tcl_CreateObjCommand(interp, "testnumutfchars",
TestNumUtfCharsCmd, NULL, NULL);
+ Tcl_CreateObjCommand(interp, "testfindfirst",
+ TestFindFirstCmd, NULL, NULL);
+ Tcl_CreateObjCommand(interp, "testfindlast",
+ TestFindLastCmd, NULL, NULL);
Tcl_CreateCommand(interp, "testsetplatform", TestsetplatformCmd,
NULL, NULL);
Tcl_CreateCommand(interp, "testsocket", TestSocketCmd,
@@ -6885,6 +6895,50 @@ TestNumUtfCharsCmd(
return TCL_OK;
}
+/*
+ * Used to check correct operation of Tcl_UtfFindFirst
+ */
+
+static int
+TestFindFirstCmd(
+ ClientData clientData,
+ Tcl_Interp *interp,
+ int objc,
+ Tcl_Obj *const objv[])
+{
+ if (objc > 1) {
+ int len = -1;
+
+ if (objc > 2) {
+ (void) Tcl_GetIntFromObj(interp, objv[2], &len);
+ }
+ Tcl_SetObjResult(interp, Tcl_NewStringObj(Tcl_UtfFindFirst(Tcl_GetString(objv[1]), len), -1));
+ }
+ return TCL_OK;
+}
+
+/*
+ * Used to check correct operation of Tcl_UtfFindLast
+ */
+
+static int
+TestFindLastCmd(
+ ClientData clientData,
+ Tcl_Interp *interp,
+ int objc,
+ Tcl_Obj *const objv[])
+{
+ if (objc > 1) {
+ int len = -1;
+
+ if (objc > 2) {
+ (void) Tcl_GetIntFromObj(interp, objv[2], &len);
+ }
+ Tcl_SetObjResult(interp, Tcl_NewStringObj(Tcl_UtfFindLast(Tcl_GetString(objv[1]), len), -1));
+ }
+ return TCL_OK;
+}
+
#if defined(HAVE_CPUID) || defined(_WIN32)
/*
*----------------------------------------------------------------------
diff --git a/generic/tclUtf.c b/generic/tclUtf.c
index 25cc2d1..43636b4 100644
--- a/generic/tclUtf.c
+++ b/generic/tclUtf.c
@@ -94,7 +94,7 @@ static const unsigned char totalBytes[256] = {
int
TclUtfCount(
- int ch) /* The Tcl_UniChar whose size is returned. */
+ int ch) /* The Unicode character whose size is returned. */
{
if ((unsigned)(ch - 1) < (UNICODE_SELF - 1)) {
return 1;
@@ -398,7 +398,7 @@ Tcl_UtfToUniCharDString(
* appended to this previously initialized
* DString. */
{
- Tcl_UniChar ch, *w, *wString;
+ Tcl_UniChar ch = 0, *w, *wString;
const char *p, *end;
int oldLength;
@@ -522,13 +522,13 @@ Tcl_NumUtfChars(
*
* Tcl_UtfFindFirst --
*
- * Returns a pointer to the first occurance of the given Tcl_UniChar in
- * the NULL-terminated UTF-8 string. The NULL terminator is considered
+ * Returns a pointer to the first occurance of the given Unicode character
+ * in the NULL-terminated UTF-8 string. The NULL terminator is considered
* part of the UTF-8 string. Equivalent to Plan 9 utfrune().
*
* Results:
- * As above. If the Tcl_UniChar does not exist in the given string, the
- * return value is NULL.
+ * As above. If the Unicode character does not exist in the given string,
+ * the return value is NULL.
*
* Side effects:
* None.
@@ -539,14 +539,21 @@ Tcl_NumUtfChars(
const char *
Tcl_UtfFindFirst(
const char *src, /* The UTF-8 string to be searched. */
- int ch) /* The Tcl_UniChar to search for. */
+ int ch) /* The Unicode character to search for. */
{
- int len;
+ int len, fullchar;
Tcl_UniChar find = 0;
while (1) {
len = TclUtfToUniChar(src, &find);
- if (find == ch) {
+ fullchar = find;
+#if TCL_UTF_MAX == 4
+ if (!len) {
+ len += TclUtfToUniChar(src, &find);
+ fullchar = (((fullchar & 0x3ff) << 10) | (find & 0x3ff)) + 0x10000;
+ }
+#endif
+ if (fullchar == ch) {
return src;
}
if (*src == '\0') {
@@ -561,12 +568,12 @@ Tcl_UtfFindFirst(
*
* Tcl_UtfFindLast --
*
- * Returns a pointer to the last occurance of the given Tcl_UniChar in
- * the NULL-terminated UTF-8 string. The NULL terminator is considered
+ * Returns a pointer to the last occurance of the given Unicode character
+ * in the NULL-terminated UTF-8 string. The NULL terminator is considered
* part of the UTF-8 string. Equivalent to Plan 9 utfrrune().
*
* Results:
- * As above. If the Tcl_UniChar does not exist in the given string, the
+ * As above. If the Unicode character does not exist in the given string, the
* return value is NULL.
*
* Side effects:
@@ -578,16 +585,23 @@ Tcl_UtfFindFirst(
const char *
Tcl_UtfFindLast(
const char *src, /* The UTF-8 string to be searched. */
- int ch) /* The Tcl_UniChar to search for. */
+ int ch) /* The Unicode character to search for. */
{
- int len;
+ int len, fullchar;
Tcl_UniChar find = 0;
const char *last;
last = NULL;
while (1) {
len = TclUtfToUniChar(src, &find);
- if (find == ch) {
+ fullchar = find;
+#if TCL_UTF_MAX == 4
+ if (!len) {
+ len += TclUtfToUniChar(src, &find);
+ fullchar = (((fullchar & 0x3ff) << 10) | (find & 0x3ff)) + 0x10000;
+ }
+#endif
+ if (fullchar == ch) {
last = src;
}
if (*src == '\0') {
@@ -687,7 +701,7 @@ Tcl_UtfPrev(
*
* Tcl_UniCharAtIndex --
*
- * Returns the Unicode character represented at the specified character
+ * Returns the Tcl_UniChar represented at the specified character
* (not byte) position in the UTF-8 string.
*
* Results:
@@ -706,8 +720,7 @@ Tcl_UniCharAtIndex(
{
Tcl_UniChar ch = 0;
- while (index >= 0) {
- index--;
+ while (index-- >= 0) {
src += TclUtfToUniChar(src, &ch);
}
return ch;
@@ -737,8 +750,7 @@ Tcl_UtfAtIndex(
{
Tcl_UniChar ch = 0;
- while (index > 0) {
- index--;
+ while (index-- > 0) {
src += TclUtfToUniChar(src, &ch);
}
return src;
@@ -1053,6 +1065,16 @@ Tcl_UtfNcmp(
cs += TclUtfToUniChar(cs, &ch1);
ct += TclUtfToUniChar(ct, &ch2);
if (ch1 != ch2) {
+#if TCL_UTF_MAX == 4
+ /* Surrogates always report higher than non-surrogates */
+ if (((ch1 & 0xFC00) == 0xD800)) {
+ if ((ch2 & 0xFC00) != 0xD800) {
+ return ch1;
+ }
+ } else if ((ch2 & 0xFC00) == 0xD800) {
+ return -ch2;
+ }
+#endif
return (ch1 - ch2);
}
}
@@ -1084,6 +1106,7 @@ Tcl_UtfNcasecmp(
unsigned long numChars) /* Number of UTF chars to compare. */
{
Tcl_UniChar ch1 = 0, ch2 = 0;
+
while (numChars-- > 0) {
/*
* n must be interpreted as chars, not bytes.
@@ -1093,6 +1116,16 @@ Tcl_UtfNcasecmp(
cs += TclUtfToUniChar(cs, &ch1);
ct += TclUtfToUniChar(ct, &ch2);
if (ch1 != ch2) {
+#if TCL_UTF_MAX == 4
+ /* Surrogates always report higher than non-surrogates */
+ if (((ch1 & 0xFC00) == 0xD800)) {
+ if ((ch2 & 0xFC00) != 0xD800) {
+ return ch1;
+ }
+ } else if ((ch2 & 0xFC00) == 0xD800) {
+ return -ch2;
+ }
+#endif
ch1 = Tcl_UniCharToLower(ch1);
ch2 = Tcl_UniCharToLower(ch2);
if (ch1 != ch2) {
@@ -1102,11 +1135,57 @@ Tcl_UtfNcasecmp(
}
return 0;
}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * Tcl_UtfCmp --
+ *
+ * Compare UTF chars of string cs to string ct case sensitively.
+ * Replacement for strcmp in Tcl core, in places where UTF-8 should
+ * be handled.
+ *
+ * Results:
+ * Return <0 if cs < ct, 0 if cs == ct, or >0 if cs > ct.
+ *
+ * Side effects:
+ * None.
+ *
+ *----------------------------------------------------------------------
+ */
+
+int
+TclUtfCmp(
+ const char *cs, /* UTF string to compare to ct. */
+ const char *ct) /* UTF string cs is compared to. */
+{
+ Tcl_UniChar ch1 = 0, ch2 = 0;
+
+ while (*cs && *ct) {
+ cs += TclUtfToUniChar(cs, &ch1);
+ ct += TclUtfToUniChar(ct, &ch2);
+ if (ch1 != ch2) {
+#if TCL_UTF_MAX == 4
+ /* Surrogates always report higher than non-surrogates */
+ if (((ch1 & 0xFC00) == 0xD800)) {
+ if ((ch2 & 0xFC00) != 0xD800) {
+ return ch1;
+ }
+ } else if ((ch2 & 0xFC00) == 0xD800) {
+ return -ch2;
+ }
+#endif
+ return ch1 - ch2;
+ }
+ }
+ return UCHAR(*cs) - UCHAR(*ct);
+}
+
/*
*----------------------------------------------------------------------
*
- * Tcl_UtfNcasecmp --
+ * TclUtfCasecmp --
*
* Compare UTF chars of string cs to string ct case insensitively.
* Replacement for strcasecmp in Tcl core, in places where UTF-8 should
@@ -1126,12 +1205,22 @@ TclUtfCasecmp(
const char *cs, /* UTF string to compare to ct. */
const char *ct) /* UTF string cs is compared to. */
{
- while (*cs && *ct) {
- Tcl_UniChar ch1, ch2;
+ Tcl_UniChar ch1 = 0, ch2 = 0;
+ while (*cs && *ct) {
cs += TclUtfToUniChar(cs, &ch1);
ct += TclUtfToUniChar(ct, &ch2);
if (ch1 != ch2) {
+#if TCL_UTF_MAX == 4
+ /* Surrogates always report higher than non-surrogates */
+ if (((ch1 & 0xFC00) == 0xD800)) {
+ if ((ch2 & 0xFC00) != 0xD800) {
+ return ch1;
+ }
+ } else if ((ch2 & 0xFC00) == 0xD800) {
+ return -ch2;
+ }
+#endif
ch1 = Tcl_UniCharToLower(ch1);
ch2 = Tcl_UniCharToLower(ch2);
if (ch1 != ch2) {
diff --git a/generic/tclUtil.c b/generic/tclUtil.c
index c12b2d4..6cfad12 100644
--- a/generic/tclUtil.c
+++ b/generic/tclUtil.c
@@ -1665,6 +1665,7 @@ TclTrimRight(
{
const char *p = bytes + numBytes;
int pInc;
+ Tcl_UniChar ch1 = 0, ch2 = 0;
if ((bytes[numBytes] != '\0') || (trim[numTrim] != '\0')) {
Tcl_Panic("TclTrimRight works only on null-terminated strings");
@@ -1683,7 +1684,6 @@ TclTrimRight(
*/
do {
- Tcl_UniChar ch1;
const char *q = trim;
int bytesLeft = numTrim;
@@ -1695,7 +1695,6 @@ TclTrimRight(
*/
do {
- Tcl_UniChar ch2;
int qInc = TclUtfToUniChar(q, &ch2);
if (ch1 == ch2) {
@@ -1745,6 +1744,7 @@ TclTrimLeft(
int numTrim) /* ...and its length in bytes */
{
const char *p = bytes;
+ Tcl_UniChar ch1 = 0, ch2 = 0;
if ((bytes[numBytes] != '\0') || (trim[numTrim] != '\0')) {
Tcl_Panic("TclTrimLeft works only on null-terminated strings");
@@ -1763,7 +1763,6 @@ TclTrimLeft(
*/
do {
- Tcl_UniChar ch1;
int pInc = TclUtfToUniChar(p, &ch1);
const char *q = trim;
int bytesLeft = numTrim;
@@ -1773,7 +1772,6 @@ TclTrimLeft(
*/
do {
- Tcl_UniChar ch2;
int qInc = TclUtfToUniChar(q, &ch2);
if (ch1 == ch2) {
@@ -2107,7 +2105,7 @@ Tcl_StringCaseMatch(
{
int p, charLen;
const char *pstart = pattern;
- Tcl_UniChar ch1, ch2;
+ Tcl_UniChar ch1 = 0, ch2 = 0;
while (1) {
p = *pattern;
@@ -2217,7 +2215,7 @@ Tcl_StringCaseMatch(
*/
if (p == '[') {
- Tcl_UniChar startChar, endChar;
+ Tcl_UniChar startChar = 0, endChar = 0;
pattern++;
if (UCHAR(*str) < 0x80) {
diff --git a/library/init.tcl b/library/init.tcl
index 87d9f14..4424087 100644
--- a/library/init.tcl
+++ b/library/init.tcl
@@ -73,43 +73,6 @@ namespace eval tcl {
encoding dirs $Path
}
}
-
- # TIP #255 min and max functions
- namespace eval mathfunc {
- proc min {args} {
- if {![llength $args]} {
- return -code error \
- "too few arguments to math function \"min\""
- }
- set val Inf
- foreach arg $args {
- # This will handle forcing the numeric value without
- # ruining the internal type of a numeric object
- if {[catch {expr {double($arg)}} err]} {
- return -code error $err
- }
- if {$arg < $val} {set val $arg}
- }
- return $val
- }
- proc max {args} {
- if {![llength $args]} {
- return -code error \
- "too few arguments to math function \"max\""
- }
- set val -Inf
- foreach arg $args {
- # This will handle forcing the numeric value without
- # ruining the internal type of a numeric object
- if {[catch {expr {double($arg)}} err]} {
- return -code error $err
- }
- if {$arg > $val} {set val $arg}
- }
- return $val
- }
- namespace export min max
- }
}
namespace eval tcl::Pkg {}
diff --git a/tests/cmdIL.test b/tests/cmdIL.test
index 70ac6bb..df59e6e 100644
--- a/tests/cmdIL.test
+++ b/tests/cmdIL.test
@@ -19,6 +19,7 @@ catch [list package require -exact Tcltest [info patchlevel]]
# Used for constraining memory leak tests
testConstraint memory [llength [info commands memory]]
testConstraint testobj [llength [info commands testobj]]
+testConstraint fullutf [expr {[format %c 0x010000] != "\ufffd"}]
test cmdIL-1.1 {Tcl_LsortObjCmd procedure} -returnCodes error -body {
lsort
@@ -147,6 +148,18 @@ test cmdIL-1.36 {lsort -stride and -index: Bug 2918962} {
{{b i g} 12345} {{d e m o} 34512}
}
} {{{b i g} 12345} {{d e m o} 34512} {{c o d e} 54321} {{b l a h} 94729}}
+test cmdIL-1.37 {Tcl_LsortObjCmd procedure, Bug 8e1e31eac0fd6b6c} {
+ lsort -ascii [list \0 \x7f \x80 \uffff]
+} [list \0 \x7f \x80 \uffff]
+test cmdIL-1.38 {Tcl_LsortObjCmd procedure, Bug 8e1e31eac0fd6b6c} {
+ lsort -ascii -nocase [list \0 \x7f \x80 \uffff]
+} [list \0 \x7f \x80 \uffff]
+test cmdIL-1.39 {Tcl_LsortObjCmd procedure, Bug 8e1e31eac0fd6b6c} fullutf {
+ lsort -ascii [list \0 \x7f \x80 \U01ffff \uffff]
+} [list \0 \x7f \x80 \uffff \U01ffff]
+test cmdIL-1.40 {Tcl_LsortObjCmd procedure, Bug 8e1e31eac0fd6b6c} fullutf {
+ lsort -ascii -nocase [list \0 \x7f \x80 \U01ffff \uffff]
+} [list \0 \x7f \x80 \uffff \U01ffff]
# Can't think of any good tests for the MergeSort and MergeLists procedures,
# except a bunch of random lists to sort.
diff --git a/tests/expr-old.test b/tests/expr-old.test
index 3adfb63..8c159b2 100644
--- a/tests/expr-old.test
+++ b/tests/expr-old.test
@@ -1159,8 +1159,8 @@ test expr-old-40.2 {min math function} -body {
expr {min(0.0)}
} -result 0.0
test expr-old-40.3 {min math function} -body {
- list [catch {expr {min()}} msg] $msg
-} -result {1 {too few arguments to math function "min"}}
+ expr {min()}
+} -returnCodes error -result {too few arguments for math function "min"}
test expr-old-40.4 {min math function} -body {
expr {min(wide(-1) << 30, 4.5, -10)}
} -result [expr {wide(-1) << 30}]
@@ -1170,6 +1170,12 @@ test expr-old-40.5 {min math function} -body {
test expr-old-40.6 {min math function} -body {
expr {min(300, "0xFF")}
} -result 255
+test expr-old-40.7 {min math function} -body {
+ expr min(1[string repeat 0 10000], 1e300)
+} -result 1e+300
+test expr-old-40.8 {min math function} -body {
+ expr {min(0, "a")}
+} -returnCodes error -match glob -result *
test expr-old-41.1 {max math function} -body {
expr {max(0)}
@@ -1178,8 +1184,8 @@ test expr-old-41.2 {max math function} -body {
expr {max(0.0)}
} -result 0.0
test expr-old-41.3 {max math function} -body {
- list [catch {expr {max()}} msg] $msg
-} -result {1 {too few arguments to math function "max"}}
+ expr {max()}
+} -returnCodes error -result {too few arguments for math function "max"}
test expr-old-41.4 {max math function} -body {
expr {max(wide(1) << 30, 4.5, -10)}
} -result [expr {wide(1) << 30}]
@@ -1189,6 +1195,12 @@ test expr-old-41.5 {max math function} -body {
test expr-old-41.6 {max math function} -body {
expr {max(200, "0xFF")}
} -result 255
+test expr-old-41.7 {max math function} -body {
+ expr max(1[string repeat 0 10000], 1e300)
+} -result 1[string repeat 0 10000]
+test expr-old-41.8 {max math function} -body {
+ expr {max(0, "a")}
+} -returnCodes error -match glob -result *
# Special test for Pentium arithmetic bug of 1994:
diff --git a/tests/interp.test b/tests/interp.test
index 1389304..4ea04e3 100644
--- a/tests/interp.test
+++ b/tests/interp.test
@@ -1847,7 +1847,7 @@ test interp-23.2 {testing hiding vs aliases: safe interp} -setup {
lappend l [lsort [interp aliases a]] [lsort [interp hidden a]]
} -cleanup {
interp delete a
-} -result [list $hidden_cmds {::tcl::mathfunc::max ::tcl::mathfunc::min bar clock} $hidden_cmds {::tcl::mathfunc::max ::tcl::mathfunc::min bar clock} [lsort [concat $hidden_cmds bar]] {::tcl::mathfunc::max ::tcl::mathfunc::min clock} $hidden_cmds]
+} -result [list $hidden_cmds {bar clock} $hidden_cmds {bar clock} [lsort [concat $hidden_cmds bar]] {clock} $hidden_cmds]
test interp-24.1 {result resetting on error} -setup {
catch {interp delete a}
diff --git a/tests/namespace.test b/tests/namespace.test
index f6f817b..9fa9331 100644
--- a/tests/namespace.test
+++ b/tests/namespace.test
@@ -1784,8 +1784,11 @@ test namespace-42.7 {ensembles: nested} -body {
list [ns x0 z] [ns x1] [ns x2] [ns x3]
} -cleanup {
namespace delete ns
-} -result {{1 ::ns::x0::z} 1 2 3}
-test namespace-42.8 {ensembles: [Bug 1670091]} -setup {
+} -result {{1 z} 1 2 3}
+test namespace-42.8 {
+ ensembles: [Bug 1670091], panic due to pointer to a deallocated List
+ struct.
+} -setup {
proc demo args {}
variable target [list [namespace which demo] x]
proc trial args {variable target; string length $target}
@@ -1800,6 +1803,34 @@ test namespace-42.8 {ensembles: [Bug 1670091]} -setup {
rename foo {}
} -result {}
+test namespace-42.9 {
+ ensembles: [Bug 4f6a1ebd64], segmentation fault due to pointer to a
+ deallocated List struct.
+} -setup {
+ namespace eval n {namespace ensemble create}
+ set lst [dict create one ::two]
+ namespace ensemble configure n -subcommands $lst -map $lst
+} -body {
+ n one
+} -cleanup {
+ namespace delete n
+ unset -nocomplain lst
+} -returnCodes error -match glob -result {invalid command name*}
+
+test namespace-42.10 {
+ ensembles: [Bug 4f6a1ebd64] segmentation fault due to pointer to a
+ deallocated List struct (this time with duplicate of one in "dict").
+} -setup {
+ namespace eval n {namespace ensemble create}
+ set lst [list one ::two one ::three]
+ namespace ensemble configure n -subcommands $lst -map $lst
+} -body {
+ n one
+} -cleanup {
+ namespace delete n
+ unset -nocomplain lst
+} -returnCodes error -match glob -result {invalid command name *three*}
+
test namespace-43.1 {ensembles: dict-driven} {
namespace eval ns {
namespace export x*
@@ -1920,7 +1951,7 @@ test namespace-44.5 {ensemble: errors} -setup {
foobar foobarcon
} -cleanup {
rename foobar {}
-} -returnCodes error -result {invalid command name "::foobarconfigure"}
+} -returnCodes error -result {invalid command name "foobarconfigure"}
test namespace-44.6 {ensemble: errors} -returnCodes error -body {
namespace ensemble create gorp
} -result {wrong # args: should be "namespace ensemble create ?option value ...?"}
@@ -2084,7 +2115,7 @@ test namespace-47.1 {ensemble: unknown handler} {
lappend result [catch {ns c d e} msg] $msg
lappend result [catch {ns Magic foo bar spong wibble} msg] $msg
list $result [lsort [info commands ::ns::*]] $log [namespace delete ns]
-} {{0 2 0 2 0 2 0 2 1 {unknown or protected subcommand "Magic"}} {::ns::Magic ::ns::a ::ns::b ::ns::c} {{making a} {running ::ns::a b c} {running ::ns::a b c} {making b} {running ::ns::b c d} {making c} {running ::ns::c d e} {unknown Magic - args = foo bar spong wibble}} {}}
+} {{0 2 0 2 0 2 0 2 1 {unknown or protected subcommand "Magic"}} {::ns::Magic ::ns::a ::ns::b ::ns::c} {{making a} {running a b c} {running a b c} {making b} {running b c d} {making c} {running c d e} {unknown Magic - args = foo bar spong wibble}} {}}
test namespace-47.2 {ensemble: unknown handler} {
namespace eval ns {
namespace export {[a-z]*}
@@ -3183,7 +3214,7 @@ test namespace-53.10 {ensembles: nested rewrite} -setup {
1 {wrong # args: should be "ns z1 x a1"}\
1 {wrong # args: should be "ns z2 x a1 a2"}\
1 {wrong # args: should be "ns z2 x a1 a2"}\
- 1 {wrong # args: should be "::ns::x::z0"}\
+ 1 {wrong # args: should be "z0"}\
0 {1 v}\
1 {wrong # args: should be "ns v x z2 a2"}\
0 {2 v v2}}
@@ -3267,6 +3298,18 @@ test namespace-56.3 {bug f97d4ee020: mutually-entangled deletion} {
}
}
} {::testing::abc::def ::testing::abc::ghi}
+
+test namespace-56.4 {bug 16fe1b5807: names starting with ":"} {
+namespace eval : {
+ namespace ensemble create
+ namespace export *
+ proc p1 {} {
+ return 16fe1b5807
+ }
+}
+
+: p1
+} 16fe1b5807
# cleanup
catch {rename cmd1 {}}
diff --git a/tests/oo.test b/tests/oo.test
index b6af1ee..b9c5067 100644
--- a/tests/oo.test
+++ b/tests/oo.test
@@ -128,6 +128,9 @@ test oo-1.3 {basic test of OO functionality: no classes} {
test oo-1.4 {basic test of OO functionality} -body {
oo::object create {}
} -returnCodes 1 -result {object name must not be empty}
+test oo-1.4.1 {fully-qualified nested name} -body {
+ oo::object create ::one::two::three
+} -result {::one::two::three}
test oo-1.5 {basic test of OO functionality} -body {
oo::object doesnotexist
} -returnCodes 1 -result {unknown method "doesnotexist": must be create, destroy or new}
@@ -1498,7 +1501,7 @@ test oo-11.5 {OO: cleanup} {
test oo-11.6 {
OO: cleanup ReleaseClassContents() where class is mixed into one of its
instances
-} {
+} -body {
oo::class create obj1
::oo::define obj1 {self mixin [self]}
@@ -1506,12 +1509,14 @@ test oo-11.6 {
::oo::objdefine obj2 {mixin [self]}
::oo::copy obj2 obj3
- trace add command obj3 delete [list obj3 dying]
+ rename obj3 {}
rename obj2 {}
# No segmentation fault
return done
-} done
+} -cleanup {
+ rename obj1 {}
+} -result done
test oo-12.1 {OO: filters} {
oo::class create Aclass
@@ -3864,6 +3869,31 @@ test oo-35.5 {Bug 1a56550e96: introspectors must traverse mixin links correctly}
} -cleanup {
base destroy
} -result {{c d e} {c d e}}
+test oo-35.6 {
+ Bug : teardown of an object that is a class that is an instance of itself
+} -setup {
+ oo::class create obj
+
+ oo::copy obj obj1 obj1
+ oo::objdefine obj1 {
+ mixin obj1 obj
+ }
+ oo::copy obj1 obj2
+ oo::objdefine obj2 {
+ mixin obj2 obj1
+ }
+} -body {
+ rename obj2 {}
+ rename obj1 {}
+ # doesn't crash
+ return done
+} -cleanup {
+ rename obj {}
+} -result done
+
+
+
+
test oo-36.1 {TIP #470: introspection within oo::define} {
oo::define oo::object self
} ::oo::object
diff --git a/tests/safe.test b/tests/safe.test
index e43ce12..33ee166 100644
--- a/tests/safe.test
+++ b/tests/safe.test
@@ -74,7 +74,7 @@ test safe-2.3 {creating safe interpreters, should have no unexpected aliases} -s
lsort [a aliases]
} -cleanup {
interp delete a
-} -result {::tcl::mathfunc::max ::tcl::mathfunc::min clock}
+} -result {clock}
test safe-3.1 {calling safe::interpInit is safe} -setup {
catch {safe::interpDelete a}
diff --git a/tests/utf.test b/tests/utf.test
index 45f9c0c..d0fa7be 100644
--- a/tests/utf.test
+++ b/tests/utf.test
@@ -86,6 +86,9 @@ test utf-3.1 {Tcl_UtfCharComplete} {
} {}
testConstraint testnumutfchars [llength [info commands testnumutfchars]]
+testConstraint testfindfirst [llength [info commands testfindfirst]]
+testConstraint testfindlast [llength [info commands testfindlast]]
+
test utf-4.1 {Tcl_NumUtfChars: zero length} testnumutfchars {
testnumutfchars ""
} {0}
@@ -118,8 +121,12 @@ test utf-4.10 {Tcl_NumUtfChars: #u0000, calc len, overcomplete} {testnumutfchars
testnumutfchars [testbytestring "\x00"] 2
} {2}
-test utf-5.1 {Tcl_UtfFindFirsts} {
-} {}
+test utf-5.1 {Tcl_UtfFindFirst} {testfindfirst testbytestring} {
+ testfindfirst [testbytestring "abcbc"] 98
+} {bcbc}
+test utf-5.1 {Tcl_UtfFindLast} {testfindlast testbytestring} {
+ testfindlast [testbytestring "abcbc"] 98
+} {bc}
test utf-6.1 {Tcl_UtfNext} {
} {}
diff --git a/unix/configure b/unix/configure
index 51d694f..e3e1b42 100755
--- a/unix/configure
+++ b/unix/configure
@@ -3733,16 +3733,6 @@ $as_echo "#define NO_DIRENT_H 1" >>confdefs.h
fi
- ac_fn_c_check_header_mongrel "$LINENO" "values.h" "ac_cv_header_values_h" "$ac_includes_default"
-if test "x$ac_cv_header_values_h" = xyes; then :
-
-else
-
-$as_echo "#define NO_VALUES_H 1" >>confdefs.h
-
-fi
-
-
ac_fn_c_check_header_mongrel "$LINENO" "stdlib.h" "ac_cv_header_stdlib_h" "$ac_includes_default"
if test "x$ac_cv_header_stdlib_h" = xyes; then :
tcl_ok=1
@@ -5309,7 +5299,7 @@ $as_echo "$ac_cv_cygwin" >&6; }
LDFLAGS="$LDFLAGS -Wl,--export-dynamic"
SHLIB_CFLAGS="-fPIC"
SHLIB_SUFFIX=".so"
- SHLIB_LD='${CC} -shared ${CFLAGS} ${LDFLAGS}'
+ SHLIB_LD='${CC} ${CFLAGS} ${LDFLAGS} -shared'
DL_OBJS="tclLoadDl.o"
DL_LIBS="-lroot"
{ $as_echo "$as_me:${as_lineno-$LINENO}: checking for inet_ntoa in -lnetwork" >&5
@@ -5631,7 +5621,7 @@ fi
# get rid of the warnings.
#CFLAGS_OPTIMIZE="${CFLAGS_OPTIMIZE} -D__NO_STRING_INLINES -D__NO_MATH_INLINES"
- SHLIB_LD='${CC} -shared ${CFLAGS} ${LDFLAGS}'
+ SHLIB_LD='${CC} ${CFLAGS} ${LDFLAGS} -shared'
DL_OBJS="tclLoadDl.o"
DL_LIBS="-ldl"
LDFLAGS="$LDFLAGS -Wl,--export-dynamic"
@@ -5718,7 +5708,7 @@ fi
SHLIB_CFLAGS="-fpic"
;;
esac
- SHLIB_LD='${CC} -shared ${SHLIB_CFLAGS}'
+ SHLIB_LD='${CC} ${SHLIB_CFLAGS} -shared'
SHLIB_SUFFIX=".so"
DL_OBJS="tclLoadDl.o"
DL_LIBS=""
@@ -5745,7 +5735,7 @@ fi
NetBSD-*)
# NetBSD has ELF and can use 'cc -shared' to build shared libs
SHLIB_CFLAGS="-fPIC"
- SHLIB_LD='${CC} -shared ${SHLIB_CFLAGS}'
+ SHLIB_LD='${CC} ${SHLIB_CFLAGS} -shared'
SHLIB_SUFFIX=".so"
DL_OBJS="tclLoadDl.o"
DL_LIBS=""
diff --git a/unix/tcl.m4 b/unix/tcl.m4
index 9aa3eb2..fa7601e 100644
--- a/unix/tcl.m4
+++ b/unix/tcl.m4
@@ -1250,7 +1250,7 @@ AC_DEFUN([SC_CONFIG_CFLAGS], [
LDFLAGS="$LDFLAGS -Wl,--export-dynamic"
SHLIB_CFLAGS="-fPIC"
SHLIB_SUFFIX=".so"
- SHLIB_LD='${CC} -shared ${CFLAGS} ${LDFLAGS}'
+ SHLIB_LD='${CC} ${CFLAGS} ${LDFLAGS} -shared'
DL_OBJS="tclLoadDl.o"
DL_LIBS="-lroot"
AC_CHECK_LIB(network, inet_ntoa, [LIBS="$LIBS -lnetwork"])
@@ -1394,7 +1394,7 @@ AC_DEFUN([SC_CONFIG_CFLAGS], [
# get rid of the warnings.
#CFLAGS_OPTIMIZE="${CFLAGS_OPTIMIZE} -D__NO_STRING_INLINES -D__NO_MATH_INLINES"
- SHLIB_LD='${CC} -shared ${CFLAGS} ${LDFLAGS}'
+ SHLIB_LD='${CC} ${CFLAGS} ${LDFLAGS} -shared'
DL_OBJS="tclLoadDl.o"
DL_LIBS="-ldl"
LDFLAGS="$LDFLAGS -Wl,--export-dynamic"
@@ -1444,7 +1444,7 @@ AC_DEFUN([SC_CONFIG_CFLAGS], [
SHLIB_CFLAGS="-fpic"
;;
esac
- SHLIB_LD='${CC} -shared ${SHLIB_CFLAGS}'
+ SHLIB_LD='${CC} ${SHLIB_CFLAGS} -shared'
SHLIB_SUFFIX=".so"
DL_OBJS="tclLoadDl.o"
DL_LIBS=""
@@ -1467,7 +1467,7 @@ AC_DEFUN([SC_CONFIG_CFLAGS], [
NetBSD-*)
# NetBSD has ELF and can use 'cc -shared' to build shared libs
SHLIB_CFLAGS="-fPIC"
- SHLIB_LD='${CC} -shared ${SHLIB_CFLAGS}'
+ SHLIB_LD='${CC} ${SHLIB_CFLAGS} -shared'
SHLIB_SUFFIX=".so"
DL_OBJS="tclLoadDl.o"
DL_LIBS=""
@@ -2040,7 +2040,6 @@ dnl # preprocessing tests use only CPPFLAGS.
#
# Defines some of the following vars:
# NO_DIRENT_H
-# NO_VALUES_H
# NO_STDLIB_H
# NO_STRING_H
# NO_SYS_WAIT_H
@@ -2078,7 +2077,6 @@ closedir(d);
AC_DEFINE(NO_DIRENT_H, 1, [Do we have <dirent.h>?])
fi
- AC_CHECK_HEADER(values.h, , [AC_DEFINE(NO_VALUES_H, 1, [Do we have <values.h>?])])
AC_CHECK_HEADER(stdlib.h, tcl_ok=1, tcl_ok=0)
AC_EGREP_HEADER(strtol, stdlib.h, , tcl_ok=0)
AC_EGREP_HEADER(strtoul, stdlib.h, , tcl_ok=0)
diff --git a/unix/tclConfig.h.in b/unix/tclConfig.h.in
index 28ce012..4902083 100644
--- a/unix/tclConfig.h.in
+++ b/unix/tclConfig.h.in
@@ -331,9 +331,6 @@
/* Do we have a usable 'union wait'? */
#undef NO_UNION_WAIT
-/* Do we have <values.h>? */
-#undef NO_VALUES_H
-
/* Do we have wait3() */
#undef NO_WAIT3
diff --git a/unix/tclUnixPort.h b/unix/tclUnixPort.h
index 8b766d6..d464f05 100644
--- a/unix/tclUnixPort.h
+++ b/unix/tclUnixPort.h
@@ -182,9 +182,6 @@ extern int TclUnixSetBlockingMode(int fd, int mode);
*/
#include <float.h>
-#ifndef NO_VALUES_H
-# include <values.h>
-#endif
#ifndef FLT_MAX
# ifdef MAXFLOAT
diff --git a/unix/tclUnixThrd.c b/unix/tclUnixThrd.c
index f475aed..6fa837c 100644
--- a/unix/tclUnixThrd.c
+++ b/unix/tclUnixThrd.c
@@ -15,11 +15,13 @@
#ifdef TCL_THREADS
+#ifndef TCL_NO_DEPRECATED
typedef struct {
char nabuf[16];
} ThreadSpecificData;
static Tcl_ThreadDataKey dataKey;
+#endif
/*
* masterLock is used to serialize creation of mutexes, condition variables,
diff --git a/win/tclWinError.c b/win/tclWinError.c
index 30079b9..fea4b0f 100644
--- a/win/tclWinError.c
+++ b/win/tclWinError.c
@@ -30,7 +30,7 @@ static const unsigned char errorTable[] = {
ENOEXEC, /* ERROR_BAD_FORMAT 11 */
EACCES, /* ERROR_INVALID_ACCESS 12 */
EINVAL, /* ERROR_INVALID_DATA 13 */
- EFAULT, /* ERROR_OUT_OF_MEMORY 14 */
+ ENOMEM, /* ERROR_OUT_OF_MEMORY 14 */
ENOENT, /* ERROR_INVALID_DRIVE 15 */
EACCES, /* ERROR_CURRENT_DIRECTORY 16 */
EXDEV, /* ERROR_NOT_SAME_DEVICE 17 */
diff --git a/win/tclWinSerial.c b/win/tclWinSerial.c
index ed1a8e5..acfeecb 100644
--- a/win/tclWinSerial.c
+++ b/win/tclWinSerial.c
@@ -1738,7 +1738,7 @@ SerialSetOptionProc(
dcb.XonChar = argv[0][0];
dcb.XoffChar = argv[1][0];
if (argv[0][0] & 0x80 || argv[1][0] & 0x80) {
- Tcl_UniChar character;
+ Tcl_UniChar character = 0;
int charLen;
charLen = Tcl_UtfToUniChar(argv[0], &character);