summaryrefslogtreecommitdiffstats
diff options
context:
space:
mode:
authordgp <dgp@users.sourceforge.net>2017-11-29 14:54:21 (GMT)
committerdgp <dgp@users.sourceforge.net>2017-11-29 14:54:21 (GMT)
commit079887fe42be52a69c2b001ae3efb5dae39862e6 (patch)
treeffb74673818266080ad8b399a0a4869d2000da83
parent8a227678b234219b0301c75a977c09b1b0daafd0 (diff)
parent4190501ec7f6c70650e90c3d9f885a938d3e7795 (diff)
downloadtcl-079887fe42be52a69c2b001ae3efb5dae39862e6.zip
tcl-079887fe42be52a69c2b001ae3efb5dae39862e6.tar.gz
tcl-079887fe42be52a69c2b001ae3efb5dae39862e6.tar.bz2
merge 8.7
-rw-r--r--doc/Object.32
-rw-r--r--doc/SaveResult.34
-rw-r--r--doc/ToUpper.32
-rw-r--r--doc/UniCharIsAlpha.35
-rw-r--r--doc/Utf.32
-rw-r--r--generic/tcl.decls10
-rw-r--r--generic/tclBasic.c220
-rw-r--r--generic/tclDecls.h25
-rw-r--r--generic/tclEnsemble.c162
-rw-r--r--generic/tclExecute.c2
-rw-r--r--generic/tclIO.c2
-rw-r--r--generic/tclInt.decls28
-rw-r--r--generic/tclInt.h28
-rw-r--r--generic/tclIntDecls.h200
-rw-r--r--generic/tclInterp.c4
-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/tclStubInit.c62
-rw-r--r--generic/tclTest.c54
-rw-r--r--generic/tclUtf.c80
-rw-r--r--library/init.tcl37
-rw-r--r--tests/expr-old.test20
-rw-r--r--tests/interp.test2
-rw-r--r--tests/namespace.test38
-rw-r--r--tests/oo.test36
-rw-r--r--tests/safe.test2
-rw-r--r--tests/utf.test11
-rwxr-xr-xunix/configure10
-rw-r--r--unix/tcl.m42
-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
35 files changed, 1000 insertions, 795 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..5ba3fc9 100644
--- a/doc/UniCharIsAlpha.3
+++ b/doc/UniCharIsAlpha.3
@@ -53,14 +53,11 @@ The Tcl_UniChar to be examined.
.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 7c69faf..9f9ba23 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 1a0c256..10536ee 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.
@@ -7730,6 +7757,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. */
@@ -8218,6 +8310,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
@@ -9003,9 +9111,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) {
@@ -9013,34 +9121,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;
}
@@ -9052,16 +9147,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/tclDecls.h b/generic/tclDecls.h
index cd97ba6..801ba03 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);
@@ -2149,18 +2154,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/tclEnsemble.c b/generic/tclEnsemble.c
index 8ff5986..629d7a2 100644
--- a/generic/tclEnsemble.c
+++ b/generic/tclEnsemble.c
@@ -161,10 +161,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) {
@@ -210,13 +212,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
@@ -236,6 +233,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) {
@@ -352,6 +350,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
@@ -359,8 +361,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);
@@ -651,48 +654,38 @@ TclNamespaceEnsembleCmd(
/*
*----------------------------------------------------------------------
*
- * Tcl_CreateEnsemble --
- *
- * Create a simple ensemble attached to the given namespace.
- *
- * Results:
- * The token for the command created.
+ * TclCreateEnsembleInNs --
*
- * 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(
- Tcl_Interp *interp,
- const char *name,
- Tcl_Namespace *namespacePtr,
- int flags)
+TclCreateEnsembleInNs(
+ Tcl_Interp *interp,
+
+ 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 *) 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.
- */
+ 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;
@@ -705,9 +698,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;
@@ -724,11 +715,56 @@ Tcl_CreateEnsemble(
((Command *) ensemblePtr->token)->compileProc = TclCompileEnsemble;
}
+ 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)
+{
+ Tcl_Obj *nameObj = NULL;
+ Namespace *nsPtr = (Namespace *)namespacePtr, *foundNsPtr, *altNsPtr,
+ *actualNsPtr;
+ const char * simpleName;
+
+ if (nsPtr == NULL) {
+ nsPtr = (Namespace *) TclGetCurrentNamespace(interp);
+ }
+
+ TclGetNamespaceForQualName(interp, name, nsPtr, 0,
+ &foundNsPtr, &altNsPtr, &actualNsPtr, &simpleName);
if (nameObj != NULL) {
- TclDecrRefCount(nameObj);
+ TclDecrRefCount(nameObj);
}
- return ensemblePtr->token;
+ return TclCreateEnsembleInNs(interp, simpleName,
+ (Tcl_Namespace *) foundNsPtr, (Tcl_Namespace *) nsPtr, flags);
}
+
/*
*----------------------------------------------------------------------
@@ -1900,6 +1936,7 @@ NsEnsembleImplementationCmdNR(
TclSkipTailcall(interp);
Tcl_ListObjGetElements(NULL, copyPtr, &copyObjc, &copyObjv);
+ ((Interp *)interp)->lookupNsPtr = ensemblePtr->nsPtr;
return TclNREvalObjv(interp, copyObjc, copyObjv, TCL_EVAL_INVOKE, NULL);
}
@@ -2518,6 +2555,7 @@ BuildEnsembleConfig(
int i, j, isNew;
Tcl_HashTable *hash = &ensemblePtr->subcommandTable;
Tcl_HashEntry *hPtr;
+ Tcl_Obj *subcmdDictCopy = NULL ;
if (hash->numEntries != 0) {
/*
@@ -2566,7 +2604,15 @@ BuildEnsembleConfig(
*/
if (ensemblePtr->subcommandDict != NULL) {
- Tcl_DictObjGet(NULL, ensemblePtr->subcommandDict, subcmdv[i],
+ if (subcmdDictCopy == NULL) {
+ if (ensemblePtr->subcmdList == ensemblePtr->subcommandDict) {
+ subcmdDictCopy = Tcl_DuplicateObj(ensemblePtr->subcommandDict);
+ } else {
+ subcmdDictCopy = ensemblePtr->subcommandDict;
+ }
+ Tcl_IncrRefCount(subcmdDictCopy);
+ }
+ Tcl_DictObjGet(NULL, subcmdDictCopy, subcmdv[i],
&target);
if (target != NULL) {
Tcl_SetHashValue(hPtr, target);
@@ -2581,16 +2627,14 @@ BuildEnsembleConfig(
* 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);
- }
+ cmdObj = Tcl_NewStringObj(name, -1);
cmdPrefixObj = Tcl_NewListObj(1, &cmdObj);
Tcl_SetHashValue(hPtr, cmdPrefixObj);
Tcl_IncrRefCount(cmdPrefixObj);
}
+ if (subcmdDictCopy != NULL) {
+ Tcl_DecrRefCount(subcmdDictCopy);
+ }
} else if (ensemblePtr->subcommandDict != NULL) {
/*
* No subcmd list, but we do have a mapping dictionary so we should
@@ -2647,11 +2691,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 ada70d8..bb6a7dd 100644
--- a/generic/tclExecute.c
+++ b/generic/tclExecute.c
@@ -744,8 +744,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 b9c1082..83de08c 100644
--- a/generic/tclIO.c
+++ b/generic/tclIO.c
@@ -9044,6 +9044,7 @@ ZeroTransferTimerProc(
*----------------------------------------------------------------------
*/
+#if !defined(TCL_NO_DEPRECATED)
int
TclCopyChannelOld(
Tcl_Interp *interp, /* Current interpreter. */
@@ -9055,6 +9056,7 @@ TclCopyChannelOld(
return TclCopyChannel(interp, inChan, outChan, (Tcl_WideInt) toRead,
cmdPtr);
}
+#endif
int
TclCopyChannel(
diff --git a/generic/tclInt.decls b/generic/tclInt.decls
index b683a29..33bf0b3 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 17eb54b..180065b 100644
--- a/generic/tclInt.h
+++ b/generic/tclInt.h
@@ -2908,6 +2908,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,
@@ -2917,6 +2919,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,
@@ -2945,6 +2960,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);
@@ -2971,6 +2990,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);
diff --git a/generic/tclIntDecls.h b/generic/tclIntDecls.h
index 4244362..22b8072 100644
--- a/generic/tclIntDecls.h
+++ b/generic/tclIntDecls.h
@@ -28,22 +28,6 @@
# 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
-
/*
* WARNING: This file is automatically generated by the tools/genStubs.tcl
* script. Any modifications to the function declarations below should be made
@@ -287,22 +271,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 +301,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 +449,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 +751,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 +817,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 +1083,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 +1205,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 +1345,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 a0bac6b..8ed001d 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/tclNamesp.c b/generic/tclNamesp.c
index 6e112b3..49291af 100644
--- a/generic/tclNamesp.c
+++ b/generic/tclNamesp.c
@@ -2441,6 +2441,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.
@@ -2655,7 +2684,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..5404abc 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 ce1c4ea..f6fe4b9 100644
--- a/generic/tclProc.c
+++ b/generic/tclProc.c
@@ -159,11 +159,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");
@@ -176,29 +175,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;
}
@@ -207,31 +198,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/tclStubInit.c b/generic/tclStubInit.c
index 56b9355..ffd27e0 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 6366be2..d3078bc 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..a72394d 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:
@@ -1052,6 +1066,15 @@ Tcl_UtfNcmp(
cs += TclUtfToUniChar(cs, &ch1);
ct += TclUtfToUniChar(ct, &ch2);
+#if TCL_UTF_MAX == 4
+ /* map high surrogate characters to values > 0xffff */
+ if ((ch1 & 0xFC00) == 0xD800) {
+ ch1 += 0x4000;
+ }
+ if ((ch2 & 0xFC00) == 0xD800) {
+ ch2 += 0x4000;
+ }
+#endif
if (ch1 != ch2) {
return (ch1 - ch2);
}
@@ -1084,6 +1107,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.
@@ -1092,6 +1116,15 @@ Tcl_UtfNcasecmp(
*/
cs += TclUtfToUniChar(cs, &ch1);
ct += TclUtfToUniChar(ct, &ch2);
+#if TCL_UTF_MAX == 4
+ /* map high surrogate characters to values > 0xffff */
+ if ((ch1 & 0xFC00) == 0xD800) {
+ ch1 += 0x4000;
+ }
+ if ((ch2 & 0xFC00) == 0xD800) {
+ ch2 += 0x4000;
+ }
+#endif
if (ch1 != ch2) {
ch1 = Tcl_UniCharToLower(ch1);
ch2 = Tcl_UniCharToLower(ch2);
@@ -1106,7 +1139,7 @@ Tcl_UtfNcasecmp(
/*
*----------------------------------------------------------------------
*
- * 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,11 +1159,20 @@ 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 TCL_UTF_MAX == 4
+ /* map high surrogate characters to values > 0xffff */
+ if ((ch1 & 0xFC00) == 0xD800) {
+ ch1 += 0x4000;
+ }
+ if ((ch2 & 0xFC00) == 0xD800) {
+ ch2 += 0x4000;
+ }
+#endif
if (ch1 != ch2) {
ch1 = Tcl_UniCharToLower(ch1);
ch2 = Tcl_UniCharToLower(ch2);
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/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..5387ae8 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,19 @@ 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}
+ dict set list one ::two
+ namespace ensemble configure n -subcommands $list -map $list
+} -body {
+ n one
+} -cleanup {
+ namespace delete n
+} -returnCodes error -match glob -result {invalid command name*}
+
test namespace-43.1 {ensembles: dict-driven} {
namespace eval ns {
namespace export x*
@@ -1920,7 +1936,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 +2100,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 +3199,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 +3283,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..556d529 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..90116c8 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
diff --git a/unix/tcl.m4 b/unix/tcl.m4
index 9aa3eb2..51459c9 100644
--- a/unix/tcl.m4
+++ b/unix/tcl.m4
@@ -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 */