Index: .project
==================================================================
--- .project
+++ .project
@@ -1,11 +1,11 @@
- tcl8.7
+ tcl8
DELETED compat/float.h
Index: compat/float.h
==================================================================
--- compat/float.h
+++ compat/float.h
@@ -1,14 +0,0 @@
-/*
- * float.h --
- *
- * This is a dummy header file to #include in Tcl when there
- * is no float.h in /usr/include. Right now this file is empty:
- * Tcl contains #ifdefs to deal with the lack of definitions;
- * all it needs is for the #include statement to work.
- *
- * Copyright (c) 1993 The Regents of the University of California.
- * Copyright (c) 1994 Sun Microsystems, Inc.
- *
- * See the file "license.terms" for information on usage and redistribution
- * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
- */
Index: doc/Object.3
==================================================================
--- doc/Object.3
+++ doc/Object.3
@@ -255,11 +255,11 @@
.PP
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.
Both representations are now valid.
\fBincr\fR increments the value's integer internal representation
Index: doc/SaveResult.3
==================================================================
--- doc/SaveResult.3
+++ doc/SaveResult.3
@@ -52,13 +52,13 @@
state is to be restored. So long as one of the latter two routines
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).
.PP
Because the routines \fBTcl_SaveInterpState\fR,
ADDED execpwd.tip
Index: execpwd.tip
==================================================================
--- execpwd.tip
+++ execpwd.tip
@@ -0,0 +1,83 @@
+TIP: 9999
+Title: Exec in a specified directory
+Version: $Revision$
+Author: Peter Spjuth
+State: Draft
+Type: Project
+Vote: Pending
+Created: 12-Mar-2008
+Post-History:
+Keywords: Tcl
+Tcl-Version: 8.6
+
+~ Abstract
+
+This TIP adds a new switch to exec to set the current working
+directory of the started process in a safe manner.
+
+~ Rationale
+
+If an external executable is dependent on the current directory
+to do the right thing, a construct like this is often needed:
+
+|set old [pwd]
+|cd $dir
+|exec something somewhere
+|cd $old
+
+This is a bit clumsy, and since cd is a process global
+resource, it is not thread safe. This is one of the few
+places where cd is hard to avoid. If it could be handled
+under the hood by exec, it would make things simpler and safer.
+
+~ What this TIP is not
+
+What should really be needed is something like '''bgexec'''
+in the core to fill in all the shortcomings of '''exec'''. A
+proposal to do that could obsolote this TIP, should someone
+do it. This, however, is not that TIP.
+
+~ Specification
+
+An option '''-pwd''' is added to '''exec'''. The option is
+followed by a directory. The started child process will run
+with this directory as its working directory.
+
+~ Examples
+
+The above example
+
+|set old [pwd]
+|cd $dir
+|exec something somewhere
+|cd $old
+
+becomes
+
+|exec -pwd $dir something somewhere
+
+~ Possible addition
+
+The same need could be there for '''open |cmd''', and the
+implementation for '''exec''' provides all infrastructure
+to cheaply add it to '''open''' too. The extra argument
+added to '''open''' makes it a bit clumsy though.
+
+'''open fileName ?access? ?permissions? ?pwd?'''
+
+Since '''permissions''' is allowed and ignored when opening
+a pipe it needs to be kept for full backward compatibility.
+If '''permissions'' could be replaced by '''pwd''' for a pipe,
+things would be cleaner.
+
+These doubts led to the exclusion of this from the spec. The
+TIP still makes things simpler even though it does not solve
+everything.
+
+~ Reference Implementation
+
+Written but not supplied yet.
+
+~ Copyright
+
+This document has been placed in the public domain.
Index: generic/tcl.decls
==================================================================
--- generic/tcl.decls
+++ generic/tcl.decls
@@ -467,11 +467,10 @@
CONST84_RETURN char *Tcl_ErrnoMsg(int err)
}
declare 129 {
int Tcl_Eval(Tcl_Interp *interp, const char *script)
}
-# This is obsolete, use Tcl_FSEvalFile
declare 130 {
int Tcl_EvalFile(Tcl_Interp *interp, const char *fileName)
}
declare 131 {
int Tcl_EvalObj(Tcl_Interp *interp, Tcl_Obj *objPtr)
@@ -778,12 +777,11 @@
int Tcl_ScanElement(const char *src, int *flagPtr)
}
declare 219 {
int Tcl_ScanCountedElement(const char *src, int length, int *flagPtr)
}
-# Obsolete
-declare 220 {
+declare 220 {deprecated {}} {
int Tcl_SeekOld(Tcl_Channel chan, int offset, int mode)
}
declare 221 {
int Tcl_ServiceAll(void)
}
@@ -866,12 +864,11 @@
Tcl_PackageInitProc *initProc, Tcl_PackageInitProc *safeInitProc)
}
declare 245 {
int Tcl_StringMatch(const char *str, const char *pattern)
}
-# Obsolete
-declare 246 {
+declare 246 {deprecated {}} {
int Tcl_TellOld(Tcl_Channel chan)
}
declare 247 {
int Tcl_TraceVar(Tcl_Interp *interp, const char *varName, int flags,
Tcl_VarTraceProc *proc, ClientData clientData)
@@ -943,14 +940,14 @@
int Tcl_DumpActiveMemory(const char *fileName)
}
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 {
char *Tcl_HashStats(Tcl_HashTable *tablePtr)
}
@@ -974,20 +971,20 @@
# TIP #268: The internally used new Require function is in slot 573.
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 {
void Tcl_GetVersion(int *major, int *minor, int *patchLevel, int *type)
}
Index: generic/tcl.h
==================================================================
--- generic/tcl.h
+++ generic/tcl.h
@@ -1342,12 +1342,12 @@
*/
typedef struct {
void *next; /* Search position for underlying hash
* table. */
- int epoch; /* Epoch marker for dictionary being searched,
- * or -1 if search has terminated. */
+ unsigned int epoch; /* Epoch marker for dictionary being searched,
+ * or 0 if search has terminated. */
Tcl_Dict dictionaryPtr; /* Reference to dictionary being searched. */
} Tcl_DictSearch;
/*
*----------------------------------------------------------------------------
@@ -2407,18 +2407,31 @@
int exact, int magic);
const char * TclTomMathInitializeStubs(Tcl_Interp *interp,
const char *version, int epoch, int revision);
#ifdef USE_TCL_STUBS
-#define Tcl_InitStubs(interp, version, exact) \
- (Tcl_InitStubs)(interp, version, \
+#if TCL_RELEASE_LEVEL == TCL_FINAL_RELEASE
+# define Tcl_InitStubs(interp, version, exact) \
+ (Tcl_InitStubs)(interp, version, \
(exact)|(TCL_MAJOR_VERSION<<8)|(TCL_MINOR_VERSION<<16), \
TCL_STUB_MAGIC)
#else
-#define Tcl_InitStubs(interp, version, exact) \
- Tcl_PkgInitStubsCheck(interp, version, \
- (exact)|(TCL_MAJOR_VERSION<<8)|(TCL_MINOR_VERSION<<16))
+# define Tcl_InitStubs(interp, version, exact) \
+ (Tcl_InitStubs)(interp, TCL_PATCH_LEVEL, \
+ 1|(TCL_MAJOR_VERSION<<8)|(TCL_MINOR_VERSION<<16), \
+ TCL_STUB_MAGIC)
+#endif
+#else
+#if TCL_RELEASE_LEVEL == TCL_FINAL_RELEASE
+# define Tcl_InitStubs(interp, version, exact) \
+ Tcl_PkgInitStubsCheck(interp, version, \
+ (exact)|(TCL_MAJOR_VERSION<<8)|(TCL_MINOR_VERSION<<16))
+#else
+# define Tcl_InitStubs(interp, version, exact) \
+ Tcl_PkgInitStubsCheck(interp, TCL_PATCH_LEVEL, \
+ 1|(TCL_MAJOR_VERSION<<8)|(TCL_MINOR_VERSION<<16))
+#endif
#endif
/*
* Public functions that are not accessible via the stubs table.
* Tcl_GetMemoryInfo is needed for AOLserver. [Bug 1868171]
Index: generic/tclBasic.c
==================================================================
--- generic/tclBasic.c
+++ generic/tclBasic.c
@@ -116,10 +116,12 @@
static Tcl_ObjCmdProc ExprDoubleFunc;
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;
static Tcl_ObjCmdProc ExprSrandFunc;
static Tcl_ObjCmdProc ExprUnaryFunc;
@@ -319,10 +321,12 @@
{ "hypot", ExprBinaryFunc, (ClientData) hypot },
{ "int", ExprIntFunc, NULL },
{ "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 },
{ "sin", ExprUnaryFunc, (ClientData) sin },
{ "sinh", ExprUnaryFunc, (ClientData) sinh },
@@ -2096,17 +2100,17 @@
tail = cmdName;
}
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);
/*
@@ -2243,68 +2247,86 @@
* the global namespace. */
Tcl_ObjCmdProc *proc, /* Object-based function to associate with
* 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);
-
- if (isNew || deleted) {
+ hPtr = Tcl_CreateHashEntry(&nsPtr->cmdTable, cmdName, &isNew);
+
+ 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);
/*
@@ -2333,21 +2355,26 @@
cmdPtr->refCount++;
if (cmdPtr->importRefPtr) {
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;
cmdPtr->importRefPtr = NULL;
}
TclCleanupCommandMacro(cmdPtr);
deleted = 1;
}
-
if (!isNew) {
/*
* If the deletion callback recreated the command, just throw away
* the new command (if we try to delete it again, we could get
* stuck in an infinite loop).
@@ -2365,11 +2392,11 @@
* Without invalidating a possible CmdName literal here explicitly,
* such literals keep being reused while pointing to overhauled
* commands.
*/
- TclInvalidateCmdLiteral(interp, tail, nsPtr);
+ TclInvalidateCmdLiteral(interp, cmdName, nsPtr);
/*
* The list of command exported from the namespace might have changed.
* However, we do not need to recompute this just yet; next time we
* need the info will be soon enough.
@@ -7696,10 +7723,75 @@
Tcl_DecrRefCount(objPtr);
}
Tcl_SetObjResult(interp, Tcl_NewWideIntObj(wResult));
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. */
Tcl_Interp *interp, /* The interpreter in which to execute the
@@ -7720,11 +7812,11 @@
if (!(iPtr->flags & RAND_SEED_INITIALIZED)) {
iPtr->flags |= RAND_SEED_INITIALIZED;
/*
- * To ensure different seeds in different threads (bug #416643),
+ * To ensure different seeds in different threads (bug #416643),
* take into consideration the thread this interp is running in.
*/
iPtr->randSeed = TclpGetClicks() + (PTR2INT(Tcl_GetCurrentThread())<<12);
@@ -8182,10 +8274,26 @@
* this command is deleted. */
{
Command *cmdPtr = (Command *)
Tcl_CreateObjCommand(interp,cmdName,proc,clientData,deleteProc);
+ 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;
}
/****************************************************************************
@@ -8970,48 +9078,35 @@
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
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) {
Tcl_WrongNumArgs(interp, 1, objv, "name cmd ?arg ...?");
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;
}
/*
@@ -9019,20 +9114,13 @@
* struct and create the corresponding command.
*/
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++;
/*
Index: generic/tclCmdMZ.c
==================================================================
--- generic/tclCmdMZ.c
+++ generic/tclCmdMZ.c
@@ -307,11 +307,11 @@
if (offset == 0) {
eflags = 0;
} else if (offset > stringLength) {
eflags = TCL_REG_NOTBOL;
- } else if (Tcl_GetUniChar(objPtr, offset-1) == (Tcl_UniChar)'\n') {
+ } else if (Tcl_GetUniChar(objPtr, offset-1) == '\n') {
eflags = 0;
} else {
eflags = TCL_REG_NOTBOL;
}
@@ -1214,17 +1214,26 @@
*/
Tcl_InitHashTable(&charReuseTable, TCL_ONE_WORD_KEYS);
for ( ; stringPtr < end; stringPtr += len) {
+ int fullchar;
len = TclUtfToUniChar(stringPtr, &ch);
+ fullchar = ch;
+
+#if TCL_UTF_MAX == 4
+ if (!len) {
+ len += TclUtfToUniChar(stringPtr, &ch);
+ fullchar = (((fullchar & 0x3ff) << 10) | (ch & 0x3ff)) + 0x10000;
+ }
+#endif
/*
* Assume Tcl_UniChar is an integral type...
*/
- hPtr = Tcl_CreateHashEntry(&charReuseTable, INT2PTR((int) ch),
+ hPtr = Tcl_CreateHashEntry(&charReuseTable, INT2PTR(fullchar),
&isNew);
if (isNew) {
TclNewStringObj(objPtr, stringPtr, len);
/*
@@ -1812,12 +1821,20 @@
}
goto str_is_done;
}
end = string1 + length1;
for (; string1 < end; string1 += length2, failat++) {
+ int fullchar;
length2 = TclUtfToUniChar(string1, &ch);
- if (!chcomp(ch)) {
+ fullchar = ch;
+#if TCL_UTF_MAX == 4
+ if (!length2) {
+ length2 = TclUtfToUniChar(string1, &ch);
+ fullchar = (((fullchar & 0x3ff) << 10) | (ch & 0x3ff)) + 0x10000;
+ }
+#endif
+ if (!chcomp(fullchar)) {
result = 0;
break;
}
}
}
Index: generic/tclDecls.h
==================================================================
--- generic/tclDecls.h
+++ generic/tclDecls.h
@@ -667,11 +667,12 @@
EXTERN int Tcl_ScanElement(const char *src, int *flagPtr);
/* 219 */
EXTERN int Tcl_ScanCountedElement(const char *src, int length,
int *flagPtr);
/* 220 */
-EXTERN int Tcl_SeekOld(Tcl_Channel chan, int offset, int mode);
+TCL_DEPRECATED("")
+int Tcl_SeekOld(Tcl_Channel chan, int offset, int mode);
/* 221 */
EXTERN int Tcl_ServiceAll(void);
/* 222 */
EXTERN int Tcl_ServiceEvent(int flags);
/* 223 */
@@ -739,11 +740,12 @@
Tcl_PackageInitProc *initProc,
Tcl_PackageInitProc *safeInitProc);
/* 245 */
EXTERN int Tcl_StringMatch(const char *str, const char *pattern);
/* 246 */
-EXTERN int Tcl_TellOld(Tcl_Channel chan);
+TCL_DEPRECATED("")
+int Tcl_TellOld(Tcl_Channel chan);
/* 247 */
EXTERN int Tcl_TraceVar(Tcl_Interp *interp, const char *varName,
int flags, Tcl_VarTraceProc *proc,
ClientData clientData);
/* 248 */
@@ -810,14 +812,16 @@
/* 265 */
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);
/* 270 */
EXTERN CONST84_RETURN char * Tcl_ParseVar(Tcl_Interp *interp,
@@ -836,18 +840,21 @@
/* 274 */
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);
/* 280 */
EXTERN void Tcl_InitMemory(Tcl_Interp *interp);
@@ -2084,11 +2091,11 @@
void (*tcl_RegExpRange) (Tcl_RegExp regexp, int index, CONST84 char **startPtr, CONST84 char **endPtr); /* 215 */
void (*tcl_Release) (ClientData clientData); /* 216 */
void (*tcl_ResetResult) (Tcl_Interp *interp); /* 217 */
int (*tcl_ScanElement) (const char *src, int *flagPtr); /* 218 */
int (*tcl_ScanCountedElement) (const char *src, int length, int *flagPtr); /* 219 */
- int (*tcl_SeekOld) (Tcl_Channel chan, int offset, int mode); /* 220 */
+ TCL_DEPRECATED_API("") int (*tcl_SeekOld) (Tcl_Channel chan, int offset, int mode); /* 220 */
int (*tcl_ServiceAll) (void); /* 221 */
int (*tcl_ServiceEvent) (int flags); /* 222 */
void (*tcl_SetAssocData) (Tcl_Interp *interp, const char *name, Tcl_InterpDeleteProc *proc, ClientData clientData); /* 223 */
void (*tcl_SetChannelBufferSize) (Tcl_Channel chan, int sz); /* 224 */
int (*tcl_SetChannelOption) (Tcl_Interp *interp, Tcl_Channel chan, const char *optionName, const char *newValue); /* 225 */
@@ -2110,11 +2117,11 @@
void (*tcl_SourceRCFile) (Tcl_Interp *interp); /* 241 */
int (*tcl_SplitList) (Tcl_Interp *interp, const char *listStr, int *argcPtr, CONST84 char ***argvPtr); /* 242 */
void (*tcl_SplitPath) (const char *path, int *argcPtr, CONST84 char ***argvPtr); /* 243 */
void (*tcl_StaticPackage) (Tcl_Interp *interp, const char *pkgName, Tcl_PackageInitProc *initProc, Tcl_PackageInitProc *safeInitProc); /* 244 */
int (*tcl_StringMatch) (const char *str, const char *pattern); /* 245 */
- int (*tcl_TellOld) (Tcl_Channel chan); /* 246 */
+ TCL_DEPRECATED_API("") int (*tcl_TellOld) (Tcl_Channel chan); /* 246 */
int (*tcl_TraceVar) (Tcl_Interp *interp, const char *varName, int flags, Tcl_VarTraceProc *proc, ClientData clientData); /* 247 */
int (*tcl_TraceVar2) (Tcl_Interp *interp, const char *part1, const char *part2, int flags, Tcl_VarTraceProc *proc, ClientData clientData); /* 248 */
char * (*tcl_TranslateFileName) (Tcl_Interp *interp, const char *name, Tcl_DString *bufferPtr); /* 249 */
int (*tcl_Ungets) (Tcl_Channel chan, const char *str, int len, int atHead); /* 250 */
void (*tcl_UnlinkVar) (Tcl_Interp *interp, const char *varName); /* 251 */
@@ -2131,22 +2138,22 @@
ClientData (*tcl_VarTraceInfo2) (Tcl_Interp *interp, const char *part1, const char *part2, int flags, Tcl_VarTraceProc *procPtr, ClientData prevClientData); /* 262 */
int (*tcl_Write) (Tcl_Channel chan, const char *s, int slen); /* 263 */
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 */
int (*tcl_UnstackChannel) (Tcl_Interp *interp, Tcl_Channel chan); /* 282 */
Tcl_Channel (*tcl_GetStackedChannel) (Tcl_Channel chan); /* 283 */
Index: generic/tclDictObj.c
==================================================================
--- generic/tclDictObj.c
+++ generic/tclDictObj.c
@@ -139,11 +139,11 @@
* created. */
ChainEntry *entryChainTail; /* Other end of linked list of all entries in
* the dictionary. Used for doing traversal of
* the entries in the order that they are
* created. */
- int epoch; /* Epoch counter */
+ unsigned int epoch; /* Epoch counter */
size_t refCount; /* Reference counter (see above) */
Tcl_Obj *chain; /* Linked list used for invalidating the
* string representations of updated nested
* dictionaries. */
} Dict;
@@ -388,11 +388,11 @@
/*
* Initialise other fields.
*/
- newDict->epoch = 0;
+ newDict->epoch = 1;
newDict->chain = NULL;
newDict->refCount = 1;
/*
* Store in the object.
@@ -485,19 +485,18 @@
static void
UpdateStringOfDict(
Tcl_Obj *dictPtr)
{
-#define LOCAL_SIZE 20
- int localFlags[LOCAL_SIZE], *flagPtr = NULL;
+#define LOCAL_SIZE 64
+ char localFlags[LOCAL_SIZE], *flagPtr = NULL;
Dict *dict = DICT(dictPtr);
ChainEntry *cPtr;
Tcl_Obj *keyPtr, *valuePtr;
int i, length, bytesNeeded = 0;
const char *elem;
char *dst;
- const int maxFlags = UINT_MAX / sizeof(int);
/*
* This field is the most useful one in the whole hash structure, and it
* is not exposed by any API function...
*/
@@ -515,14 +514,12 @@
* Pass 1: estimate space, gather flags.
*/
if (numElems <= LOCAL_SIZE) {
flagPtr = localFlags;
- } else if (numElems > maxFlags) {
- Tcl_Panic("max size for a Tcl value (%d bytes) exceeded", INT_MAX);
} else {
- flagPtr = ckalloc(numElems * sizeof(int));
+ flagPtr = ckalloc(numElems);
}
for (i=0,cPtr=dict->entryChainHead; inextPtr) {
/*
* Assume that cPtr is never NULL since we know the number of array
* elements already.
@@ -708,11 +705,11 @@
* as possible to allow the conversion code, in particular
* Tcl_GetStringFromObj, to use that old internalRep.
*/
TclFreeIntRep(objPtr);
- dict->epoch = 0;
+ dict->epoch = 1;
dict->chain = NULL;
dict->refCount = 1;
DICT(objPtr) = dict;
objPtr->internalRep.twoPtrValue.ptr2 = NULL;
objPtr->typePtr = &tclDictType;
@@ -1107,11 +1104,11 @@
}
dict = DICT(dictPtr);
cPtr = dict->entryChainHead;
if (cPtr == NULL) {
- searchPtr->epoch = -1;
+ searchPtr->epoch = 0;
*donePtr = 1;
} else {
*donePtr = 0;
searchPtr->dictionaryPtr = (Tcl_Dict) dict;
searchPtr->epoch = dict->epoch;
@@ -1168,11 +1165,11 @@
/*
* If the searh is done; we do no work.
*/
- if (searchPtr->epoch == -1) {
+ if (!searchPtr->epoch) {
*donePtr = 1;
return;
}
/*
@@ -1225,12 +1222,12 @@
Tcl_DictObjDone(
Tcl_DictSearch *searchPtr) /* Pointer to a hash search context. */
{
Dict *dict;
- if (searchPtr->epoch != -1) {
- searchPtr->epoch = -1;
+ if (searchPtr->epoch) {
+ searchPtr->epoch = 0;
dict = (Dict *) searchPtr->dictionaryPtr;
if (dict->refCount-- <= 1) {
DeleteDict(dict);
}
}
@@ -1378,11 +1375,11 @@
TclNewObj(dictPtr);
TclInvalidateStringRep(dictPtr);
dict = ckalloc(sizeof(Dict));
InitChainTable(dict);
- dict->epoch = 0;
+ dict->epoch = 1;
dict->chain = NULL;
dict->refCount = 1;
DICT(dictPtr) = dict;
dictPtr->internalRep.twoPtrValue.ptr2 = NULL;
dictPtr->typePtr = &tclDictType;
@@ -1428,11 +1425,11 @@
TclDbNewObj(dictPtr, file, line);
TclInvalidateStringRep(dictPtr);
dict = ckalloc(sizeof(Dict));
InitChainTable(dict);
- dict->epoch = 0;
+ dict->epoch = 1;
dict->chain = NULL;
dict->refCount = 1;
DICT(dictPtr) = dict;
dictPtr->internalRep.twoPtrValue.ptr2 = NULL;
dictPtr->typePtr = &tclDictType;
Index: generic/tclEnsemble.c
==================================================================
--- generic/tclEnsemble.c
+++ generic/tclEnsemble.c
@@ -144,14 +144,16 @@
Tcl_Interp *interp,
int objc,
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) {
if (!Tcl_InterpDeleted(interp)) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
@@ -193,17 +195,12 @@
return TCL_ERROR;
}
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
* are not incrementing any reference counts in the objects at this
* stage, so the presence of an option multiple times won't cause any
@@ -219,10 +216,11 @@
return TCL_ERROR;
}
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) {
if (allocatedMapFlag) {
Tcl_DecrRefCount(mapObj);
@@ -335,19 +333,24 @@
unknownObj = (len > 0 ? objv[1] : NULL);
continue;
}
}
+ 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
* should be OK because we only link the namespace into the list once
* 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);
Tcl_SetEnsembleParameterList(interp, token, paramObj);
@@ -634,52 +637,42 @@
}
/*
*----------------------------------------------------------------------
*
- * Tcl_CreateEnsemble --
- *
- * Create a simple ensemble attached to the given namespace.
- *
- * Results:
- * The token for the command created.
- *
- * Side effects:
- * The ensemble is created and marked for compilation.
+ * TclCreateEnsembleInNs --
+ *
+ * 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)
-{
- 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.
- */
-
- 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);
+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 *) ensembleNsPtr;
+ EnsembleConfig *ensemblePtr;
+ Tcl_Command token;
+
+ 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;
ensemblePtr->epoch = 0;
Tcl_InitHashTable(&ensemblePtr->subcommandTable, TCL_STRING_KEYS);
@@ -688,13 +681,11 @@
ensemblePtr->subcommandDict = NULL;
ensemblePtr->flags = flags;
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;
/*
* Trigger an eventual recomputation of the ensemble command set. Note
@@ -707,15 +698,60 @@
if (flags & ENSEMBLE_COMPILE) {
((Command *) ensemblePtr->token)->compileProc = TclCompileEnsemble;
}
- if (nameObj != NULL) {
- TclDecrRefCount(nameObj);
- }
return ensemblePtr->token;
+
+}
+
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * Tcl_CreateEnsemble
+ *
+ * Create a simple ensemble attached to the given namespace.
+ *
+ * Deprecated by TclCreateEnsembleInNs.
+ *
+ * Value
+ *
+ * The token for the command created.
+ *
+ * Effect
+ * The ensemble is created and marked for compilation.
+ *
+ *
+ *----------------------------------------------------------------------
+ */
+
+Tcl_Command
+Tcl_CreateEnsemble(
+ Tcl_Interp *interp,
+ const char *name,
+ Tcl_Namespace *namespacePtr,
+ int flags)
+{
+ 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);
+ }
+ return TclCreateEnsembleInNs(interp, simpleName,
+ (Tcl_Namespace *) foundNsPtr, (Tcl_Namespace *) nsPtr, flags);
}
+
/*
*----------------------------------------------------------------------
*
* Tcl_SetEnsembleSubcommandList --
@@ -1883,10 +1919,11 @@
* Hand off to the target command.
*/
TclSkipTailcall(interp);
Tcl_ListObjGetElements(NULL, copyPtr, ©Objc, ©Objv);
+ ((Interp *)interp)->lookupNsPtr = ensemblePtr->nsPtr;
return TclNREvalObjv(interp, copyObjc, copyObjv, TCL_EVAL_INVOKE, NULL);
}
unknownOrAmbiguousSubcommand:
/*
@@ -2503,10 +2540,11 @@
* the namespace that backs up this
* ensemble. */
int i, j, isNew;
Tcl_HashTable *hash = &ensemblePtr->subcommandTable;
Tcl_HashEntry *hPtr;
+ Tcl_Obj *subcmdDictCopy = NULL ;
if (hash->numEntries != 0) {
/*
* Remove pre-existing table.
*/
@@ -2551,11 +2589,19 @@
/*
* Look in our dictionary (if present) for the command.
*/
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);
Tcl_IncrRefCount(target);
continue;
@@ -2566,20 +2612,18 @@
* Not there, so map onto the namespace. Note in this case that we
* do not guarantee that the command is actually there; that is
* the programmer's responsibility (or [::unknown] of course).
*/
- cmdObj = NewNsObj((Tcl_Namespace *) ensemblePtr->nsPtr);
- if (ensemblePtr->nsPtr->parentPtr != NULL) {
- Tcl_AppendStringsToObj(cmdObj, "::", name, NULL);
- } else {
- Tcl_AppendStringsToObj(cmdObj, name, NULL);
- }
+ 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
* use the keys of that. Convert the dictionary's contents into the
* form required for the ensemble's internal hashtable.
@@ -2632,15 +2676,11 @@
*/
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);
}
break;
Index: generic/tclExecute.c
==================================================================
--- generic/tclExecute.c
+++ generic/tclExecute.c
@@ -742,12 +742,10 @@
#endif /* TCL_COMPILE_DEBUG */
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);
static Tcl_Obj * ExecuteExtendedUnaryMathOp(int opcode,
Tcl_Obj *valuePtr);
@@ -1331,16 +1329,16 @@
TclStackAlloc(
Tcl_Interp *interp,
int numBytes)
{
Interp *iPtr = (Interp *) interp;
- int numWords = (numBytes + (sizeof(Tcl_Obj *) - 1))/sizeof(Tcl_Obj *);
+ int numWords;
if (iPtr == NULL || iPtr->execEnvPtr == NULL) {
return (void *) ckalloc(numBytes);
}
-
+ numWords = (numBytes + (sizeof(Tcl_Obj *) - 1))/sizeof(Tcl_Obj *);
return (void *) StackAllocWords(interp, numWords);
}
void *
TclStackRealloc(
Index: generic/tclHash.c
==================================================================
--- generic/tclHash.c
+++ generic/tclHash.c
@@ -983,15 +983,21 @@
static void
RebuildTable(
register Tcl_HashTable *tablePtr) /* Table to enlarge. */
{
- int oldSize, count, index;
- Tcl_HashEntry **oldBuckets;
+ int count, index, oldSize = tablePtr->numBuckets;
+ Tcl_HashEntry **oldBuckets = tablePtr->buckets;
register Tcl_HashEntry **oldChainPtr, **newChainPtr;
register Tcl_HashEntry *hPtr;
const Tcl_HashKeyType *typePtr;
+
+ /* Avoid outgrowing capability of the memory allocators */
+ if (oldSize > (int)(UINT_MAX / (4 * sizeof(Tcl_HashEntry *)))) {
+ tablePtr->rebuildSize = INT_MAX;
+ return;
+ }
if (tablePtr->keyType == TCL_STRING_KEYS) {
typePtr = &tclStringHashKeyType;
} else if (tablePtr->keyType == TCL_ONE_WORD_KEYS) {
typePtr = &tclOneWordHashKeyType;
@@ -1000,13 +1006,10 @@
typePtr = tablePtr->typePtr;
} else {
typePtr = &tclArrayHashKeyType;
}
- oldSize = tablePtr->numBuckets;
- oldBuckets = tablePtr->buckets;
-
/*
* Allocate and initialize the new bucket array, and set up hashing
* constants for new array size.
*/
Index: generic/tclIO.c
==================================================================
--- generic/tclIO.c
+++ generic/tclIO.c
@@ -9030,10 +9030,11 @@
* be marked busy.
*
*----------------------------------------------------------------------
*/
+#if !defined(TCL_NO_DEPRECATED)
int
TclCopyChannelOld(
Tcl_Interp *interp, /* Current interpreter. */
Tcl_Channel inChan, /* Channel to read from. */
Tcl_Channel outChan, /* Channel to write to. */
@@ -9041,10 +9042,11 @@
Tcl_Obj *cmdPtr) /* Pointer to script to execute or NULL. */
{
return TclCopyChannel(interp, inChan, outChan, (Tcl_WideInt) toRead,
cmdPtr);
}
+#endif
int
TclCopyChannel(
Tcl_Interp *interp, /* Current interpreter. */
Tcl_Channel inChan, /* Channel to read from. */
Index: generic/tclIOCmd.c
==================================================================
--- generic/tclIOCmd.c
+++ generic/tclIOCmd.c
@@ -890,22 +890,22 @@
ClientData dummy, /* Not used. */
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
- Tcl_Obj *resultPtr;
+ Tcl_Obj *resultPtr, *pwdPtr = NULL;
const char **argv; /* An array for the string arguments. Stored
* on the _Tcl_ stack. */
const char *string;
Tcl_Channel chan;
int argc, background, i, index, keepNewline, result, skip, length;
int ignoreStderr;
static const char *const options[] = {
- "-ignorestderr", "-keepnewline", "--", NULL
+ "-ignorestderr", "-keepnewline", "-pwd", "--", NULL
};
enum options {
- EXEC_IGNORESTDERR, EXEC_KEEPNEWLINE, EXEC_LAST
+ EXEC_IGNORESTDERR, EXEC_KEEPNEWLINE, EXEC_PWD, EXEC_LAST
};
/*
* Check for any leading option arguments.
*/
@@ -923,19 +923,36 @@
}
if (index == EXEC_KEEPNEWLINE) {
keepNewline = 1;
} else if (index == EXEC_IGNORESTDERR) {
ignoreStderr = 1;
+ } else if (index == EXEC_PWD) {
+ skip++;
+ if (skip >= objc) {
+ /* FIXA Message */
+ return TCL_ERROR;
+ }
+ pwdPtr = objv[skip];
} else {
skip++;
break;
}
}
if (objc <= skip) {
Tcl_WrongNumArgs(interp, 1, objv, "?-option ...? arg ?arg ...?");
return TCL_ERROR;
}
+
+ if (pwdPtr != NULL) {
+ Tcl_Obj *normalizedPtr;
+ normalizedPtr = Tcl_FSGetNormalizedPath(interp, pwdPtr);
+ if (normalizedPtr == NULL) {
+ return TCL_ERROR;
+ }
+ pwdPtr = normalizedPtr;
+ Tcl_IncrRefCount(pwdPtr);
+ }
/*
* See if the command is to be run in background.
*/
@@ -961,12 +978,17 @@
for (i = 0; i < argc; i++) {
argv[i] = TclGetString(objv[i + skip]);
}
argv[argc] = NULL;
- chan = Tcl_OpenCommandChannel(interp, argc, argv, (background ? 0 :
- ignoreStderr ? TCL_STDOUT : TCL_STDOUT|TCL_STDERR));
+ chan = TclOpenCommandChannel(interp, argc, argv, (background ? 0 :
+ (ignoreStderr ? TCL_STDOUT : TCL_STDOUT|TCL_STDERR)), pwdPtr);
+
+ if (pwdPtr != NULL) {
+ Tcl_DecrRefCount(pwdPtr);
+ pwdPtr = NULL;
+ }
/*
* Free the argv array.
*/
@@ -1108,21 +1130,23 @@
Tcl_Obj *const objv[]) /* Argument objects. */
{
int pipeline, prot;
const char *modeString, *what;
Tcl_Channel chan;
+ Tcl_Obj *pwdPtr = NULL;
- if ((objc < 2) || (objc > 4)) {
- Tcl_WrongNumArgs(interp, 1, objv, "fileName ?access? ?permissions?");
+ if ((objc < 2) || (objc > 5)) {
+ Tcl_WrongNumArgs(interp, 1, objv,
+ "fileName ?access? ?permissions? ?pwd?");
return TCL_ERROR;
}
prot = 0666;
if (objc == 2) {
modeString = "r";
} else {
modeString = TclGetString(objv[2]);
- if (objc == 4) {
+ if (objc >= 4) {
const char *permString = TclGetString(objv[3]);
int code = TCL_ERROR;
int scanned = TclParseAllWhiteSpace(permString, -1);
/*
@@ -1143,29 +1167,56 @@
if ((code == TCL_ERROR)
&& TclGetIntFromObj(interp, objv[3], &prot) != TCL_OK) {
return TCL_ERROR;
}
}
+ if (objc >= 5) {
+ pwdPtr = objv[4];
+ }
}
pipeline = 0;
what = TclGetString(objv[1]);
if (what[0] == '|') {
pipeline = 1;
}
+
+ if (pwdPtr != NULL) {
+ Tcl_Obj *normalizedPtr;
+ normalizedPtr = Tcl_FSGetNormalizedPath(interp, pwdPtr);
+ if (normalizedPtr == NULL) {
+ return TCL_ERROR;
+ }
+ pwdPtr = normalizedPtr;
+ Tcl_IncrRefCount(pwdPtr);
+ }
/*
* Open the file or create a process pipeline.
*/
if (!pipeline) {
- chan = Tcl_FSOpenFileChannel(interp, objv[1], modeString, prot);
+ if (pwdPtr != NULL) {
+ Tcl_Obj *toJoin[2];
+ Tcl_Obj *joinedPtr;
+ toJoin[0] = pwdPtr;
+ toJoin[1] = objv[1];
+ joinedPtr = Tcl_FSJoinToPath(NULL, 2, toJoin);
+ Tcl_IncrRefCount(joinedPtr);
+ chan = Tcl_FSOpenFileChannel(interp, joinedPtr, modeString, prot);
+ Tcl_DecrRefCount(joinedPtr);
+ } else {
+ chan = Tcl_FSOpenFileChannel(interp, objv[1], modeString, prot);
+ }
} else {
int mode, seekFlag, cmdObjc, binary;
const char **cmdArgv;
if (Tcl_SplitList(interp, what+1, &cmdObjc, &cmdArgv) != TCL_OK) {
+ if (pwdPtr != NULL) {
+ Tcl_DecrRefCount(pwdPtr);
+ }
return TCL_ERROR;
}
mode = TclGetOpenModeEx(interp, modeString, &seekFlag, &binary);
if (mode == -1) {
@@ -1185,17 +1236,21 @@
break;
default:
Tcl_Panic("Tcl_OpenCmd: invalid mode value");
break;
}
- chan = Tcl_OpenCommandChannel(interp, cmdObjc, cmdArgv, flags);
+ chan = TclOpenCommandChannel(interp, cmdObjc, cmdArgv, flags,
+ pwdPtr);
if (binary && chan) {
Tcl_SetChannelOption(interp, chan, "-translation", "binary");
}
}
ckfree(cmdArgv);
}
+ if (pwdPtr != NULL) {
+ Tcl_DecrRefCount(pwdPtr);
+ }
if (chan == NULL) {
return TCL_ERROR;
}
Tcl_RegisterChannel(interp, chan);
Tcl_SetObjResult(interp, Tcl_NewStringObj(Tcl_GetChannelName(chan), -1));
Index: generic/tclIOUtil.c
==================================================================
--- generic/tclIOUtil.c
+++ generic/tclIOUtil.c
@@ -410,11 +410,10 @@
TclDStringAppendObj(cwdPtr, cwd);
Tcl_DecrRefCount(cwd);
return Tcl_DStringValue(cwdPtr);
}
-/* Obsolete */
int
Tcl_EvalFile(
Tcl_Interp *interp, /* Interpreter in which to process file. */
const char *fileName) /* Name of file to process. Tilde-substitution
* will be performed on this name. */
Index: generic/tclIndexObj.c
==================================================================
--- generic/tclIndexObj.c
+++ generic/tclIndexObj.c
@@ -874,11 +874,12 @@
const char *message) /* Error message to print after the leading
* objects in objv. The message may be
* NULL. */
{
Tcl_Obj *objPtr;
- int i, len, elemLen, flags;
+ int i, len, elemLen;
+ char flags;
Interp *iPtr = (Interp *) interp;
const char *elementStr;
/*
* [incr Tcl] does something fairly horrific when generating error
Index: generic/tclInt.decls
==================================================================
--- generic/tclInt.decls
+++ generic/tclInt.decls
@@ -48,11 +48,11 @@
void TclCleanupCommand(Command *cmdPtr)
}
declare 7 {
int TclCopyAndCollapse(int count, const char *src, char *dst)
}
-declare 8 {
+declare 8 {deprecated {}} {
int TclCopyChannelOld(Tcl_Interp *interp, Tcl_Channel inChan,
Tcl_Channel outChan, int toRead, Tcl_Obj *cmdPtr)
}
# TclCreatePipeline unofficially exported for use by BLT.
@@ -71,11 +71,11 @@
void TclDeleteCompiledLocalVars(Interp *iPtr, CallFrame *framePtr)
}
declare 12 {
void TclDeleteVars(Interp *iPtr, TclVarHashTable *tablePtr)
}
-# Removed in 8.5
+# Removed in 8.5:
#declare 13 {
# int TclDoGlob(Tcl_Interp *interp, char *separators,
# Tcl_DString *headPtr, char *tail, Tcl_GlobTypeData *types)
#}
declare 14 {
@@ -86,11 +86,11 @@
# void TclExpandParseValue(ParseValue *pvPtr, int needed)
# }
declare 16 {
void TclExprFloatError(Tcl_Interp *interp, double value)
}
-# Removed in 8.4
+# Removed in 8.4:
#declare 17 {
# int TclFileAttrsCmd(Tcl_Interp *interp, int objc, Tcl_Obj *const objv[])
#}
#declare 18 {
# int TclFileCopyCmd(Tcl_Interp *interp, int argc, char **argv)
@@ -121,11 +121,11 @@
}
# Removed in 8.1:
# declare 26 {
# char *TclGetCwd(Tcl_Interp *interp)
# }
-# Removed in 8.5
+# Removed in 8.5:
#declare 27 {
# int TclGetDate(char *p, unsigned long now, long zone,
# unsigned long *timePtr)
#}
declare 28 {
@@ -145,11 +145,11 @@
}
declare 32 {
int TclGetFrame(Tcl_Interp *interp, const char *str,
CallFrame **framePtrPtr)
}
-# Removed in Tcl 8.5
+# Removed in 8.5:
#declare 33 {
# TclCmdProcType TclGetInterpProc(void)
#}
declare 34 {
int TclGetIntForIndex(Tcl_Interp *interp, Tcl_Obj *objPtr,
@@ -158,11 +158,11 @@
# Removed in 8.4b2:
#declare 35 {
# Tcl_Obj *TclGetIndexedScalar(Tcl_Interp *interp, int localIndex,
# int flags)
#}
-# Removed in 8.6a2
+# Removed in 8.6a2:
#declare 36 {
# int TclGetLong(Tcl_Interp *interp, const char *str, long *longPtr)
#}
declare 37 {
int TclGetLoadedPackages(Tcl_Interp *interp, const char *targetName)
@@ -183,11 +183,11 @@
Tcl_Command TclGetOriginalCommand(Tcl_Command command)
}
declare 42 {
CONST86 char *TclpGetUserHome(const char *name, Tcl_DString *bufferPtr)
}
-# Removed in Tcl 8.5a2
+# Removed in 8.5a2:
#declare 43 {
# int TclGlobalInvoke(Tcl_Interp *interp, int argc, CONST84 char **argv,
# int flags)
#}
declare 44 {
@@ -218,11 +218,11 @@
Namespace *nsPtr)
}
declare 51 {
int TclInterpInit(Tcl_Interp *interp)
}
-# Removed in Tcl 8.5a2
+# Removed in 8.5a2:
#declare 52 {
# int TclInvoke(Tcl_Interp *interp, int argc, CONST84 char **argv,
# int flags)
#}
declare 53 {
@@ -271,11 +271,11 @@
}
declare 64 {
int TclObjInvoke(Tcl_Interp *interp, int objc, Tcl_Obj *const objv[],
int flags)
}
-# Removed in Tcl 8.5a2
+# Removed in 8.5a2:
#declare 65 {
# int TclObjInvokeGlobal(Tcl_Interp *interp, int objc,
# Tcl_Obj *const objv[], int flags)
#}
#declare 66 {
@@ -311,13 +311,11 @@
unsigned long TclpGetClicks(void)
}
declare 76 {
unsigned long TclpGetSeconds(void)
}
-
-# deprecated
-declare 77 {
+declare 77 {deprecated {}} {
void TclpGetTime(Tcl_Time *time)
}
# Removed in 8.6:
#declare 78 {
# int TclpGetTimeZone(unsigned long time)
@@ -378,11 +376,11 @@
const char *procName)
}
declare 93 {
void TclProcDeleteProc(ClientData clientData)
}
-# Removed in Tcl 8.5:
+# Removed in 8.5:
#declare 94 {
# int TclProcInterpProc(ClientData clientData, Tcl_Interp *interp,
# int argc, const char **argv)
#}
# Replaced by Tcl_FSStat in 8.4:
@@ -417,11 +415,11 @@
}
declare 103 {
int TclSockGetPort(Tcl_Interp *interp, const char *str, const char *proto,
int *portPtr)
}
-declare 104 {
+declare 104 {deprecated {}} {
int TclSockMinimumBuffersOld(int sock, int size)
}
# Replaced by Tcl_FSStat in 8.4:
#declare 105 {
# int TclStat(const char *path, Tcl_StatBuf *buf)
@@ -453,30 +451,30 @@
void Tcl_AddInterpResolvers(Tcl_Interp *interp, const char *name,
Tcl_ResolveCmdProc *cmdProc, Tcl_ResolveVarProc *varProc,
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 {
int Tcl_GetInterpResolvers(Tcl_Interp *interp, const char *name,
Tcl_ResolverInfo *resInfo)
@@ -488,32 +486,32 @@
declare 120 {
Tcl_Var Tcl_FindNamespaceVar(Tcl_Interp *interp, const char *name,
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 {
void Tcl_PopCallFrame(Tcl_Interp *interp)
}
@@ -530,11 +528,11 @@
Tcl_ResolveCompiledVarProc *compiledVarProc)
}
declare 132 {
int TclpHasSockets(Tcl_Interp *interp)
}
-declare 133 {
+declare 133 {deprecated {}} {
struct tm *TclpGetDate(const time_t *time, int useGMT)
}
# Removed in 8.5
#declare 134 {
# size_t TclpStrftime(char *s, size_t maxsize, const char *format,
@@ -623,16 +621,14 @@
int status)
}
declare 157 {
Var *TclVarTraceExists(Tcl_Interp *interp, const char *varName)
}
-# REMOVED (except from stub table) - use public Tcl_SetStartupScript()
-declare 158 {
+declare 158 {deprecated {use public Tcl_SetStartupScript()}} {
void TclSetStartupScriptFileName(const char *filename)
}
-# REMOVED (except from stub table) - use public Tcl_GetStartupScript()
-declare 159 {
+declare 159 {deprecated {use public Tcl_GetStartupScript()}} {
const char *TclGetStartupScriptFileName(void)
}
#declare 160 {
# int TclpMatchFilesTypes(Tcl_Interp *interp, char *separators,
# Tcl_DString *dirPtr, char *pattern, char *tail,
@@ -674,17 +670,14 @@
declare 166 {
int TclListObjSetElement(Tcl_Interp *interp, Tcl_Obj *listPtr,
int index, Tcl_Obj *valuePtr)
}
-# VFS-aware versions of Tcl*StartupScriptFileName (158 and 159 above)
-# REMOVED (except from stub table) - use public Tcl_SetStartupScript()
-declare 167 {
+declare 167 {deprecated {use public Tcl_SetStartupScript()}} {
void TclSetStartupScriptPath(Tcl_Obj *pathPtr)
}
-# REMOVED (except from stub table) - use public Tcl_GetStartupScript()
-declare 168 {
+declare 168 {deprecated {use public Tcl_GetStartupScript()}} {
Tcl_Obj *TclGetStartupScriptPath(void)
}
# variant of Tcl_UtfNCmp that takes n as bytes, not chars
declare 169 {
int TclpUtfNcmp2(const char *s1, const char *s2, unsigned long n)
@@ -728,16 +721,15 @@
}
declare 177 {
void TclVarErrMsg(Tcl_Interp *interp, const char *part1, const char *part2,
const char *operation, const char *reason)
}
-# TIP 338 made these public - now declared in tcl.h too
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
# Allocate lists without copying arrays
# declare 180 {
@@ -746,16 +738,14 @@
#declare 181 {
# Tcl_Obj *TclDbNewListObjDirect(int objc, Tcl_Obj **objv,
# const char *file, int line)
#}
-# TclpGmtime and TclpLocaltime promoted to the generic interface from unix
-
-declare 182 {
+declare 182 {deprecated {}} {
struct tm *TclpLocaltime(const time_t *clock)
}
-declare 183 {
+declare 183 {deprecated {}} {
struct tm *TclpGmtime(const time_t *clock)
}
# For the new "Thread Storage" subsystem.
@@ -935,14 +925,11 @@
int *newPtr)
}
declare 235 {
void TclInitVarHashTable(TclVarHashTable *tablePtr, Namespace *nsPtr)
}
-
-
-# TIP 337 made this one public
-declare 236 {
+declare 236 {deprecated {use Tcl_BackgroundException}} {
void TclBackgroundException(Tcl_Interp *interp, int code)
}
# TIP #285: Script cancellation support.
declare 237 {
@@ -1088,11 +1075,11 @@
}
# new for 8.4.20+/8.5.12+ Cygwin only
declare 10 win {
Tcl_DirEntry *TclpReaddir(DIR *dir)
}
-# Removed in 8.3.1 (for Win32s only)
+# Removed in 8.3.1 (for Win32s only):
#declare 10 win {
# int TclWinSynchSpawn(void *args, int type, void **trans, Tcl_Pid *pidPtr)
#}
# Pipe channel functions
@@ -1138,11 +1125,10 @@
TclFile TclpOpenFile(const char *fname, int mode)
}
declare 20 win {
void TclWinAddProcess(HANDLE hProcess, DWORD id)
}
-# new for 8.4.20+/8.5.12+
declare 21 win {
char *TclpInetNtoa(struct in_addr addr)
}
# removed permanently for 8.4
#declare 21 win {
Index: generic/tclInt.h
==================================================================
--- generic/tclInt.h
+++ generic/tclInt.h
@@ -2906,25 +2906,40 @@
const char *value);
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,
int start, int *clNext);
MODULE_SCOPE ContLineLoc *TclContinuationsGet(Tcl_Obj *objPtr);
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,
const char **elementPtr, const char **nextPtr,
int *sizePtr, int *literalPtr);
-/* TIP #280 - Modified token based evulation, with line information. */
+/* TIP #280 - Modified token based evaluation, with line information. */
MODULE_SCOPE int TclEvalEx(Tcl_Interp *interp, const char *script,
int numBytes, int flags, int line,
int *clNextOuter, const char *outerScript);
MODULE_SCOPE Tcl_ObjCmdProc TclFileAttrsCmd;
MODULE_SCOPE Tcl_ObjCmdProc TclFileCopyCmd;
@@ -2943,10 +2958,14 @@
MODULE_SCOPE char * TclDStringAppendDString(Tcl_DString *dsPtr,
Tcl_DString *toAppendPtr);
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);
MODULE_SCOPE void TclFinalizeEncodingSubsystem(void);
MODULE_SCOPE void TclFinalizeEnvironment(void);
@@ -2969,10 +2988,19 @@
MODULE_SCOPE void TclFinalizeThreadObjects(void);
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);
MODULE_SCOPE int * TclGetAsyncReadyPtr(void);
MODULE_SCOPE Tcl_Obj * TclGetBgErrorHandler(Tcl_Interp *interp);
@@ -3081,10 +3109,20 @@
MODULE_SCOPE int TclpObjLstat(Tcl_Obj *pathPtr, Tcl_StatBuf *buf);
MODULE_SCOPE Tcl_Obj * TclpTempFileName(void);
MODULE_SCOPE Tcl_Obj * TclpTempFileNameForLibrary(Tcl_Interp *interp, Tcl_Obj* pathPtr);
MODULE_SCOPE Tcl_Obj * TclNewFSPathObj(Tcl_Obj *dirPtr, const char *addStrRep,
int len);
+MODULE_SCOPE int TclCreatePipelinePwd (Tcl_Interp * interp, int argc,
+ const char ** argv, Tcl_Pid ** pidArrayPtr,
+ TclFile * inPipePtr, TclFile * outPipePtr,
+ TclFile * errFilePtr, Tcl_Obj *pwdPtr);
+MODULE_SCOPE Tcl_Channel TclOpenCommandChannel (Tcl_Interp *interp, int argc,
+ const char **argv, int flags, Tcl_Obj *pwdPtr);
+MODULE_SCOPE int TclpCreateProcessPwd (Tcl_Interp * interp, int argc,
+ const char ** argv, TclFile inputFile,
+ TclFile outputFile, TclFile errorFile,
+ Tcl_Obj *pwdPtr, Tcl_Pid * pidPtr);
MODULE_SCOPE int TclpDeleteFile(const void *path);
MODULE_SCOPE void TclpFinalizeCondition(Tcl_Condition *condPtr);
MODULE_SCOPE void TclpFinalizeMutex(Tcl_Mutex *mutexPtr);
MODULE_SCOPE void TclpFinalizePipes(void);
MODULE_SCOPE void TclpFinalizeSockets(void);
@@ -3143,11 +3181,11 @@
MODULE_SCOPE void TclRemoveScriptLimitCallbacks(Tcl_Interp *interp);
MODULE_SCOPE int TclReToGlob(Tcl_Interp *interp, const char *reStr,
int reStrLen, Tcl_DString *dsPtr, int *flagsPtr,
int *quantifiersFoundPtr);
MODULE_SCOPE int TclScanElement(const char *string, int length,
- int *flagPtr);
+ char *flagPtr);
MODULE_SCOPE void TclSetBgErrorHandler(Tcl_Interp *interp,
Tcl_Obj *cmdPrefix);
MODULE_SCOPE void TclSetBignumIntRep(Tcl_Obj *objPtr,
mp_int *bignumValue);
MODULE_SCOPE int TclSetBooleanFromAny(Tcl_Interp *interp, Tcl_Obj *objPtr);
@@ -4481,11 +4519,11 @@
# define TclUniCharNcmp Tcl_UniCharNcmp
#endif /* WORDS_BIGENDIAN */
/*
*----------------------------------------------------------------
- * Macro used by the Tcl core to increment a namespace's export export epoch
+ * Macro used by the Tcl core to increment a namespace's export epoch
* counter. The ANSI C "prototype" for this macro is:
*
* MODULE_SCOPE void TclInvalidateNsCmdLookup(Namespace *nsPtr);
*----------------------------------------------------------------
*/
Index: generic/tclIntDecls.h
==================================================================
--- generic/tclIntDecls.h
+++ generic/tclIntDecls.h
@@ -26,26 +26,10 @@
# else
# define TCL_STORAGE_CLASS DLLIMPORT
# 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
* in the generic/tclInt.decls script.
*/
@@ -73,11 +57,12 @@
EXTERN void TclCleanupCommand(Command *cmdPtr);
/* 7 */
EXTERN int TclCopyAndCollapse(int count, const char *src,
char *dst);
/* 8 */
-EXTERN int TclCopyChannelOld(Tcl_Interp *interp,
+TCL_DEPRECATED("")
+int TclCopyChannelOld(Tcl_Interp *interp,
Tcl_Channel inChan, Tcl_Channel outChan,
int toRead, Tcl_Obj *cmdPtr);
/* 9 */
EXTERN int TclCreatePipeline(Tcl_Interp *interp, int argc,
const char **argv, Tcl_Pid **pidArrayPtr,
@@ -216,11 +201,12 @@
/* 75 */
EXTERN unsigned long TclpGetClicks(void);
/* 76 */
EXTERN unsigned long TclpGetSeconds(void);
/* 77 */
-EXTERN void TclpGetTime(Tcl_Time *time);
+TCL_DEPRECATED("")
+void TclpGetTime(Tcl_Time *time);
/* Slot 78 is reserved */
/* Slot 79 is reserved */
/* Slot 80 is reserved */
/* 81 */
EXTERN char * TclpRealloc(char *ptr, unsigned int size);
@@ -265,11 +251,12 @@
EXTERN void TclSetupEnv(Tcl_Interp *interp);
/* 103 */
EXTERN int TclSockGetPort(Tcl_Interp *interp, const char *str,
const char *proto, int *portPtr);
/* 104 */
-EXTERN int TclSockMinimumBuffersOld(int sock, int size);
+TCL_DEPRECATED("")
+int TclSockMinimumBuffersOld(int sock, int size);
/* Slot 105 is reserved */
/* Slot 106 is reserved */
/* Slot 107 is reserved */
/* 108 */
EXTERN void TclTeardownNamespace(Namespace *nsPtr);
@@ -282,26 +269,26 @@
const char *name,
Tcl_ResolveCmdProc *cmdProc,
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 */
EXTERN int Tcl_GetInterpResolvers(Tcl_Interp *interp,
const char *name, Tcl_ResolverInfo *resInfo);
@@ -312,27 +299,27 @@
/* 120 */
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);
/* 129 */
EXTERN int Tcl_PushCallFrame(Tcl_Interp *interp,
@@ -348,11 +335,12 @@
Tcl_ResolveVarProc *varProc,
Tcl_ResolveCompiledVarProc *compiledVarProc);
/* 132 */
EXTERN int TclpHasSockets(Tcl_Interp *interp);
/* 133 */
-EXTERN struct tm * TclpGetDate(const time_t *time, int useGMT);
+TCL_DEPRECATED("")
+struct tm * TclpGetDate(const time_t *time, int useGMT);
/* Slot 134 is reserved */
/* Slot 135 is reserved */
/* Slot 136 is reserved */
/* Slot 137 is reserved */
/* 138 */
@@ -399,13 +387,15 @@
int status);
/* 157 */
EXTERN Var * TclVarTraceExists(Tcl_Interp *interp,
const char *varName);
/* 158 */
-EXTERN void TclSetStartupScriptFileName(const char *filename);
+TCL_DEPRECATED("use public Tcl_SetStartupScript()")
+void TclSetStartupScriptFileName(const char *filename);
/* 159 */
-EXTERN const char * TclGetStartupScriptFileName(void);
+TCL_DEPRECATED("use public Tcl_GetStartupScript()")
+const char * TclGetStartupScriptFileName(void);
/* Slot 160 is reserved */
/* 161 */
EXTERN int TclChannelTransform(Tcl_Interp *interp,
Tcl_Channel chan, Tcl_Obj *cmdObjPtr);
/* 162 */
@@ -420,13 +410,15 @@
/* 166 */
EXTERN int TclListObjSetElement(Tcl_Interp *interp,
Tcl_Obj *listPtr, int index,
Tcl_Obj *valuePtr);
/* 167 */
-EXTERN void TclSetStartupScriptPath(Tcl_Obj *pathPtr);
+TCL_DEPRECATED("use public Tcl_SetStartupScript()")
+void TclSetStartupScriptPath(Tcl_Obj *pathPtr);
/* 168 */
-EXTERN Tcl_Obj * TclGetStartupScriptPath(void);
+TCL_DEPRECATED("use public Tcl_GetStartupScript()")
+Tcl_Obj * TclGetStartupScriptPath(void);
/* 169 */
EXTERN int TclpUtfNcmp2(const char *s1, const char *s2,
unsigned long n);
/* 170 */
EXTERN int TclCheckInterpTraces(Tcl_Interp *interp,
@@ -455,20 +447,22 @@
/* 177 */
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 */
-EXTERN struct tm * TclpLocaltime(const time_t *clock);
+TCL_DEPRECATED("")
+struct tm * TclpLocaltime(const time_t *clock);
/* 183 */
-EXTERN struct tm * TclpGmtime(const time_t *clock);
+TCL_DEPRECATED("")
+struct tm * TclpGmtime(const time_t *clock);
/* Slot 184 is reserved */
/* Slot 185 is reserved */
/* Slot 186 is reserved */
/* Slot 187 is reserved */
/* Slot 188 is reserved */
@@ -568,11 +562,12 @@
const char *key, int *newPtr);
/* 235 */
EXTERN void TclInitVarHashTable(TclVarHashTable *tablePtr,
Namespace *nsPtr);
/* 236 */
-EXTERN void TclBackgroundException(Tcl_Interp *interp, int code);
+TCL_DEPRECATED("use Tcl_BackgroundException")
+void TclBackgroundException(Tcl_Interp *interp, int code);
/* 237 */
EXTERN int TclResetCancellation(Tcl_Interp *interp, int force);
/* 238 */
EXTERN int TclNRInterpProc(ClientData clientData,
Tcl_Interp *interp, int objc,
@@ -650,11 +645,11 @@
void (*tclAllocateFreeObjects) (void); /* 3 */
void (*reserved4)(void);
int (*tclCleanupChildren) (Tcl_Interp *interp, int numPids, Tcl_Pid *pidPtr, Tcl_Channel errorChan); /* 5 */
void (*tclCleanupCommand) (Command *cmdPtr); /* 6 */
int (*tclCopyAndCollapse) (int count, const char *src, char *dst); /* 7 */
- int (*tclCopyChannelOld) (Tcl_Interp *interp, Tcl_Channel inChan, Tcl_Channel outChan, int toRead, Tcl_Obj *cmdPtr); /* 8 */
+ TCL_DEPRECATED_API("") int (*tclCopyChannelOld) (Tcl_Interp *interp, Tcl_Channel inChan, Tcl_Channel outChan, int toRead, Tcl_Obj *cmdPtr); /* 8 */
int (*tclCreatePipeline) (Tcl_Interp *interp, int argc, const char **argv, Tcl_Pid **pidArrayPtr, TclFile *inPipePtr, TclFile *outPipePtr, TclFile *errFilePtr); /* 9 */
int (*tclCreateProc) (Tcl_Interp *interp, Namespace *nsPtr, const char *procName, Tcl_Obj *argsPtr, Tcl_Obj *bodyPtr, Proc **procPtrPtr); /* 10 */
void (*tclDeleteCompiledLocalVars) (Interp *iPtr, CallFrame *framePtr); /* 11 */
void (*tclDeleteVars) (Interp *iPtr, TclVarHashTable *tablePtr); /* 12 */
void (*reserved13)(void);
@@ -719,11 +714,11 @@
void (*reserved72)(void);
void (*reserved73)(void);
void (*tclpFree) (char *ptr); /* 74 */
unsigned long (*tclpGetClicks) (void); /* 75 */
unsigned long (*tclpGetSeconds) (void); /* 76 */
- void (*tclpGetTime) (Tcl_Time *time); /* 77 */
+ TCL_DEPRECATED_API("") void (*tclpGetTime) (Tcl_Time *time); /* 77 */
void (*reserved78)(void);
void (*reserved79)(void);
void (*reserved80)(void);
char * (*tclpRealloc) (char *ptr, unsigned int size); /* 81 */
void (*reserved82)(void);
@@ -746,40 +741,40 @@
void (*reserved99)(void);
void (*reserved100)(void);
CONST86 char * (*tclSetPreInitScript) (const char *string); /* 101 */
void (*tclSetupEnv) (Tcl_Interp *interp); /* 102 */
int (*tclSockGetPort) (Tcl_Interp *interp, const char *str, const char *proto, int *portPtr); /* 103 */
- int (*tclSockMinimumBuffersOld) (int sock, int size); /* 104 */
+ TCL_DEPRECATED_API("") int (*tclSockMinimumBuffersOld) (int sock, int size); /* 104 */
void (*reserved105)(void);
void (*reserved106)(void);
void (*reserved107)(void);
void (*tclTeardownNamespace) (Namespace *nsPtr); /* 108 */
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 */
void (*tcl_SetNamespaceResolvers) (Tcl_Namespace *namespacePtr, Tcl_ResolveCmdProc *cmdProc, Tcl_ResolveVarProc *varProc, Tcl_ResolveCompiledVarProc *compiledVarProc); /* 131 */
int (*tclpHasSockets) (Tcl_Interp *interp); /* 132 */
- struct tm * (*tclpGetDate) (const time_t *time, int useGMT); /* 133 */
+ TCL_DEPRECATED_API("") struct tm * (*tclpGetDate) (const time_t *time, int useGMT); /* 133 */
void (*reserved134)(void);
void (*reserved135)(void);
void (*reserved136)(void);
void (*reserved137)(void);
CONST84_RETURN char * (*tclGetEnv) (const char *name, Tcl_DString *valuePtr); /* 138 */
@@ -800,36 +795,36 @@
Tcl_Obj * (*tclGetLibraryPath) (void); /* 153 */
void (*reserved154)(void);
void (*reserved155)(void);
void (*tclRegError) (Tcl_Interp *interp, const char *msg, int status); /* 156 */
Var * (*tclVarTraceExists) (Tcl_Interp *interp, const char *varName); /* 157 */
- void (*tclSetStartupScriptFileName) (const char *filename); /* 158 */
- const char * (*tclGetStartupScriptFileName) (void); /* 159 */
+ TCL_DEPRECATED_API("use public Tcl_SetStartupScript()") void (*tclSetStartupScriptFileName) (const char *filename); /* 158 */
+ TCL_DEPRECATED_API("use public Tcl_GetStartupScript()") const char * (*tclGetStartupScriptFileName) (void); /* 159 */
void (*reserved160)(void);
int (*tclChannelTransform) (Tcl_Interp *interp, Tcl_Channel chan, Tcl_Obj *cmdObjPtr); /* 161 */
void (*tclChannelEventScriptInvoker) (ClientData clientData, int flags); /* 162 */
const void * (*tclGetInstructionTable) (void); /* 163 */
void (*tclExpandCodeArray) (void *envPtr); /* 164 */
void (*tclpSetInitialEncodings) (void); /* 165 */
int (*tclListObjSetElement) (Tcl_Interp *interp, Tcl_Obj *listPtr, int index, Tcl_Obj *valuePtr); /* 166 */
- void (*tclSetStartupScriptPath) (Tcl_Obj *pathPtr); /* 167 */
- Tcl_Obj * (*tclGetStartupScriptPath) (void); /* 168 */
+ TCL_DEPRECATED_API("use public Tcl_SetStartupScript()") void (*tclSetStartupScriptPath) (Tcl_Obj *pathPtr); /* 167 */
+ TCL_DEPRECATED_API("use public Tcl_GetStartupScript()") Tcl_Obj * (*tclGetStartupScriptPath) (void); /* 168 */
int (*tclpUtfNcmp2) (const char *s1, const char *s2, unsigned long n); /* 169 */
int (*tclCheckInterpTraces) (Tcl_Interp *interp, const char *command, int numChars, Command *cmdPtr, int result, int traceFlags, int objc, Tcl_Obj *const objv[]); /* 170 */
int (*tclCheckExecutionTraces) (Tcl_Interp *interp, const char *command, int numChars, Command *cmdPtr, int result, int traceFlags, int objc, Tcl_Obj *const objv[]); /* 171 */
int (*tclInThreadExit) (void); /* 172 */
int (*tclUniCharMatch) (const Tcl_UniChar *string, int strLen, const Tcl_UniChar *pattern, int ptnLen, int flags); /* 173 */
void (*reserved174)(void);
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);
- struct tm * (*tclpLocaltime) (const time_t *clock); /* 182 */
- struct tm * (*tclpGmtime) (const time_t *clock); /* 183 */
+ TCL_DEPRECATED_API("") struct tm * (*tclpLocaltime) (const time_t *clock); /* 182 */
+ TCL_DEPRECATED_API("") struct tm * (*tclpGmtime) (const time_t *clock); /* 183 */
void (*reserved184)(void);
void (*reserved185)(void);
void (*reserved186)(void);
void (*reserved187)(void);
void (*reserved188)(void);
@@ -878,11 +873,11 @@
int (*tclGetNamespaceFromObj) (Tcl_Interp *interp, Tcl_Obj *objPtr, Tcl_Namespace **nsPtrPtr); /* 231 */
int (*tclEvalObjEx) (Tcl_Interp *interp, Tcl_Obj *objPtr, int flags, const CmdFrame *invoker, int word); /* 232 */
void (*tclGetSrcInfoForPc) (CmdFrame *contextPtr); /* 233 */
Var * (*tclVarHashCreateVar) (TclVarHashTable *tablePtr, const char *key, int *newPtr); /* 234 */
void (*tclInitVarHashTable) (TclVarHashTable *tablePtr, Namespace *nsPtr); /* 235 */
- void (*tclBackgroundException) (Tcl_Interp *interp, int code); /* 236 */
+ TCL_DEPRECATED_API("use Tcl_BackgroundException") void (*tclBackgroundException) (Tcl_Interp *interp, int code); /* 236 */
int (*tclResetCancellation) (Tcl_Interp *interp, int force); /* 237 */
int (*tclNRInterpProc) (ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); /* 238 */
int (*tclNRInterpProcCore) (Tcl_Interp *interp, Tcl_Obj *procNameObj, int skip, ProcErrorProc *errorProc); /* 239 */
int (*tclNRRunCallbacks) (Tcl_Interp *interp, int result, struct NRE_callback *rootPtr); /* 240 */
int (*tclNREvalObjEx) (Tcl_Interp *interp, Tcl_Obj *objPtr, int flags, const CmdFrame *invoker, int word); /* 241 */
@@ -1086,42 +1081,42 @@
(tclIntStubsPtr->tclUpdateReturnInfo) /* 109 */
#define TclSockMinimumBuffers \
(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 \
(tclIntStubsPtr->tcl_PushCallFrame) /* 129 */
#define Tcl_RemoveInterpResolvers \
@@ -1208,14 +1203,14 @@
(tclIntStubsPtr->tclCallVarTraces) /* 175 */
#define TclCleanupVar \
(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 \
(tclIntStubsPtr->tclpLocaltime) /* 182 */
#define TclpGmtime \
@@ -1348,60 +1343,30 @@
/* !END!: Do not edit above this line. */
#undef TCL_STORAGE_CLASS
#define TCL_STORAGE_CLASS DLLIMPORT
-#undef TclGetStartupScriptFileName
-#undef TclSetStartupScriptFileName
-#undef TclGetStartupScriptPath
-#undef TclSetStartupScriptPath
-#undef TclBackgroundException
-
-#if defined(USE_TCL_STUBS) && defined(TCL_NO_DEPRECATED)
-# 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 */
+#if defined(USE_TCL_STUBS)
+# 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 */
Index: generic/tclInterp.c
==================================================================
--- generic/tclInterp.c
+++ generic/tclInterp.c
@@ -3206,14 +3206,10 @@
* Assume these functions all work. [Bug 2895741]
*/
(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;
/*
Index: generic/tclListObj.c
==================================================================
--- generic/tclListObj.c
+++ generic/tclListObj.c
@@ -1955,12 +1955,12 @@
static void
UpdateStringOfList(
Tcl_Obj *listPtr) /* List object with string rep to update. */
{
-# define LOCAL_SIZE 20
- int localFlags[LOCAL_SIZE], *flagPtr = NULL;
+# define LOCAL_SIZE 64
+ char localFlags[LOCAL_SIZE], *flagPtr = NULL;
List *listRepPtr = ListRepPtr(listPtr);
int numElems = listRepPtr->elemCount;
int i, length, bytesNeeded = 0;
const char *elem;
char *dst;
@@ -1993,11 +1993,11 @@
} else {
/*
* We know numElems <= LIST_MAX, so this is safe.
*/
- flagPtr = ckalloc(numElems * sizeof(int));
+ flagPtr = ckalloc(numElems);
}
elemPtrs = &listRepPtr->elements;
for (i = 0; i < numElems; i++) {
flagPtr[i] = (i ? TCL_DONT_QUOTE_HASH : 0);
elem = TclGetStringFromObj(elemPtrs[i], &length);
Index: generic/tclMain.c
==================================================================
--- generic/tclMain.c
+++ generic/tclMain.c
@@ -264,22 +264,18 @@
* Test for the existence of the rc file before trying to read it.
*/
c = Tcl_OpenFileChannel(NULL, fullName, "r", 0);
if (c != NULL) {
- Tcl_Obj *fullNameObj = Tcl_NewStringObj(fullName, -1);
-
Tcl_Close(NULL, c);
- Tcl_IncrRefCount(fullNameObj);
- if (Tcl_FSEvalFileEx(interp, fullNameObj, NULL) != TCL_OK) {
+ if (Tcl_EvalFile(interp, fullName) != TCL_OK) {
chan = Tcl_GetStdChannel(TCL_STDERR);
if (chan) {
Tcl_WriteObj(chan, Tcl_GetObjResult(interp));
Tcl_WriteChars(chan, "\n", 1);
}
}
- Tcl_DecrRefCount(fullNameObj);
}
}
Tcl_DStringFree(&temp);
}
}
Index: generic/tclNamesp.c
==================================================================
--- generic/tclNamesp.c
+++ generic/tclNamesp.c
@@ -2422,10 +2422,39 @@
}
/*
*----------------------------------------------------------------------
*
+ * 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.
*
* Results:
@@ -2636,11 +2665,11 @@
}
} else {
Namespace *nsPtr[2];
register int search;
- TclGetNamespaceForQualName(interp, name, (Namespace *) contextNsPtr,
+ TclGetNamespaceForQualName(interp, name, cxtNsPtr,
flags, &nsPtr[0], &nsPtr[1], &cxtNsPtr, &simpleName);
/*
* Look for the command in the command table of its namespace. Be sure
* to check both possible search paths: from the specified namespace
Index: generic/tclOO.c
==================================================================
--- generic/tclOO.c
+++ generic/tclOO.c
@@ -2,10 +2,11 @@
* tclOO.c --
*
* 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.
*/
@@ -80,11 +81,10 @@
static void ObjectRenamedTrace(ClientData clientData,
Tcl_Interp *interp, const char *oldName,
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,
Tcl_Obj *const *objv);
static int PublicNRObjectCmd(ClientData clientData,
@@ -536,11 +536,12 @@
* ----------------------------------------------------------------------
*
* AllocObject --
*
* Allocate an object of basic type. Does not splice the object into its
- * class's instance list.
+ * class's instance list. The caller must set the classPtr on the object,
+ * either to a class or to NULL.
*
* ----------------------------------------------------------------------
*/
static Object *
@@ -559,11 +560,14 @@
{
Foundation *fPtr = GetFoundation(interp);
Object *oPtr;
Command *cmdPtr;
CommandTrace *tracePtr;
+ Namespace *nsPtr, *altNsPtr, *cxtNsPtr;
+ Tcl_Namespace *inNsPtr;
int creationEpoch, ignored;
+ const char *simpleName;
oPtr = ckalloc(sizeof(Object));
memset(oPtr, 0, sizeof(Object));
/*
@@ -577,12 +581,11 @@
* names using the epoch until such time as a new namespace is actually
* created.
*/
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;
}
Tcl_ResetResult(interp);
@@ -590,12 +593,11 @@
while (1) {
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;
}
@@ -631,11 +633,11 @@
* Set up a callback to get notification of the deletion of a namespace
* when enough of the namespace still remains to execute commands and
* 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.
*/
@@ -649,28 +651,22 @@
* Finally, create the object commands and initialize the trace on the
* public command (so that the object structures are deleted when the
* command is deleted).
*/
- 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);
+ if (nameStr) {
+ inNsPtr = TclGetCurrentNamespace(interp);
} 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;
+ inNsPtr = oPtr->namespacePtr;
+ }
+
+ TclGetNamespaceForQualName(interp, nameStr, (Namespace *) inNsPtr, 0,
+ &nsPtr, &altNsPtr, &cxtNsPtr, &simpleName);
+
+ oPtr->command = TclCreateObjCommandInNs(interp, simpleName,
+ (Tcl_Namespace *)nsPtr, PublicObjectCmd, oPtr, NULL);
/*
* Add the NRE command and trace directly. While this breaks a number of
* abstractions, it is faster and we're inside Tcl here so we're allowed.
*/
@@ -752,34 +748,10 @@
}
/*
* ----------------------------------------------------------------------
*
- * 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
* mechanism. It runs the destructors and arranges for the actual cleanup
* of the object's namespace, which in turn triggers cleansing of the
@@ -795,12 +767,10 @@
const char *oldName, /* What the object was (last) called. */
const char *newName, /* What it's getting renamed to. (unused) */
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.
*/
@@ -807,92 +777,40 @@
if (flags & TCL_TRACE_RENAME) {
SquelchCachedName(oPtr);
return;
}
- /*
- * 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);
- }
- DelRef(fPtr->classCls->thisPtr);
- DelRef(fPtr->objectCls->thisPtr);
- DelRef(fPtr->classCls);
- DelRef(fPtr->objectCls);
- DelRef(oPtr);
+ 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);
+ }
+ }
+ return;
}
/*
* ----------------------------------------------------------------------
*
@@ -960,11 +878,13 @@
{
FOREACH_HASH_DECLS;
int i;
Class *clsPtr = oPtr->classPtr, *mixinSubclassPtr, *subclassPtr;
Object *instancePtr;
+ Method *mPtr;
Foundation *fPtr = oPtr->fPtr;
+ Tcl_Obj *variableObj;
/*
* Sanity check!
*/
@@ -1151,10 +1071,30 @@
}
Tcl_DeleteHashTable(clsPtr->metadataPtr);
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);
+ }
+
+ DelRef(clsPtr);
+
}
/*
* ----------------------------------------------------------------------
*
@@ -1172,38 +1112,94 @@
ObjectNamespaceDeleted(
ClientData clientData) /* Pointer to the class whose namespace is
* 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);
+
+ /*
+ * 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->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 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.
- */
-
- 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;
- }
-
+ * 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);
}
+
+ /*
+ * 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) {
+ ReleaseClassContents(interp, oPtr);
+ }
/*
* Splice the object out of its context. After this, we must *not* call
* methods on the object.
*/
@@ -1259,82 +1255,32 @@
Tcl_DeleteHashTable(oPtr->metadataPtr);
ckfree(oPtr->metadataPtr);
oPtr->metadataPtr = NULL;
}
- /*
- * If this was a class, there's additional deletion work to do.
- */
-
- 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);
- }
-
- DelRef(clsPtr);
- }
-
/*
* 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;
}
/*
* ----------------------------------------------------------------------
@@ -1424,11 +1370,11 @@
*/
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;
Class *subclsPtr;
@@ -1495,11 +1441,11 @@
*/
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;
Class *subclsPtr;
@@ -1569,11 +1515,11 @@
AllocClass(
Tcl_Interp *interp, /* Interpreter within which to allocate the
* 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));
/*
@@ -1641,11 +1587,10 @@
*
* Allocate a new instance of an object.
*
* ----------------------------------------------------------------------
*/
-
Tcl_Object
Tcl_NewObjectInstance(
Tcl_Interp *interp, /* Interpreter context. */
Tcl_Class cls, /* Class to create an instance of. */
const char *nameStr, /* Name of object to create, or NULL to ask
@@ -1658,56 +1603,18 @@
Tcl_Obj *const *objv, /* Argument list. */
int skip) /* Number of arguments to _not_ pass to the
* constructor. */
{
register Class *classPtr = (Class *) cls;
- Foundation *fPtr = GetFoundation(interp);
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 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);
- }
-
- /*
- * Run constructors, except when objc < 0 (a special flag case used for
- * object cloning only).
+ oPtr = TclNewObjectInstanceCommon(interp, classPtr, nameStr, nsNameStr);
+ if (oPtr == NULL) {return NULL;}
+
+ /*
+ * Run constructors, except when objc < 0, which is a special flag case
+ * used for object cloning only.
*/
if (objc >= 0) {
CallContext *contextPtr =
TclOOGetCallContext(oPtr, NULL, CONSTRUCTOR, NULL);
@@ -1731,13 +1638,12 @@
if (isRoot) {
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]
+ * 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)) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"object deleted in constructor", -1));
@@ -1784,27 +1690,85 @@
* constructor. */
Tcl_Object *objectPtr) /* Place to write the object reference upon
* 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.
+ * Protect classPtr from getting cleaned up when the command is created.
+ */
+ AddRef(classPtr);
+
+ oPtr = TclNewObjectInstanceCommon(interp, classPtr, nameStr, nsNameStr);
+ if (oPtr == NULL) {return TCL_ERROR;}
+
+ /*
+ * Run constructors, except when objc < 0 (a special flag case used for
+ * object cloning only). If there aren't any constructors, we do nothing.
+ */
+
+ if (objc < 0) {
+ *objectPtr = (Tcl_Object) oPtr;
+ DelRef(classPtr);
+ return TCL_OK;
+ }
+ contextPtr = TclOOGetCallContext(oPtr, NULL, CONSTRUCTOR, NULL);
+ if (contextPtr == NULL) {
+ *objectPtr = (Tcl_Object) oPtr;
+ DelRef(classPtr);
+ return TCL_OK;
+ }
+
+ state = Tcl_SaveInterpState(interp, TCL_OK);
+ contextPtr->callPtr->flags |= CONSTRUCTOR;
+ contextPtr->skip = skip;
+
+ /*
+ * Adjust the ensmble tracking record if necessary. [Bug 3514761]
+ */
+
+ if (TclInitRewriteEnsemble(interp, skip, skip, objv)) {
+ TclNRAddCallback(interp, TclClearRootEnsemble, NULL, NULL, NULL, NULL);
+ }
+
+ /*
+ * Fire off the constructors non-recursively.
+ */
+
+ AddRef(oPtr);
+ TclNRAddCallback(interp, FinalizeAlloc, contextPtr, oPtr, state,
+ objectPtr);
+ TclPushTailcallPoint(interp);
+ DelRef(classPtr);
+ return TclOOInvokeContext(contextPtr, interp, objc, objv);
+}
+
+
+Object *
+TclNewObjectInstanceCommon(
+ Tcl_Interp *interp,
+ Class *classPtr,
+ const char *nameStr,
+ const char *nsNameStr)
+{
+ Foundation *fPtr = GetFoundation(interp);
+ Object *oPtr;
+
+ /*
+ * Disallow creation of an object over an existing command.
*/
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;
+ return NULL;
}
/*
* Create the object.
*/
@@ -1827,49 +1791,17 @@
*/
AllocClass(interp, oPtr);
oPtr->selfCls = classPtr;
TclOOAddToSubclasses(oPtr->classPtr, fPtr->objectCls);
- }
-
- /*
- * Run constructors, except when objc < 0 (a special flag case used for
- * object cloning only). If there aren't any constructors, we do nothing.
- */
-
- if (objc < 0) {
- *objectPtr = (Tcl_Object) oPtr;
- return TCL_OK;
- }
- contextPtr = TclOOGetCallContext(oPtr, NULL, CONSTRUCTOR, NULL);
- if (contextPtr == NULL) {
- *objectPtr = (Tcl_Object) oPtr;
- return TCL_OK;
- }
-
- state = Tcl_SaveInterpState(interp, TCL_OK);
- contextPtr->callPtr->flags |= CONSTRUCTOR;
- contextPtr->skip = skip;
-
- /*
- * Adjust the ensmble tracking record if necessary. [Bug 3514761]
- */
-
- if (TclInitRewriteEnsemble(interp, skip, skip, objv)) {
- TclNRAddCallback(interp, TclClearRootEnsemble, NULL, NULL, NULL, NULL);
- }
-
- /*
- * Fire off the constructors non-recursively.
- */
-
- AddRef(oPtr);
- TclNRAddCallback(interp, FinalizeAlloc, contextPtr, oPtr, state,
- objectPtr);
- TclPushTailcallPoint(interp);
- return TclOOInvokeContext(contextPtr, interp, objc, objv);
-}
+ } else {
+ oPtr->classPtr = NULL;
+ }
+ return oPtr;
+}
+
+
static int
FinalizeAlloc(
ClientData data[],
Tcl_Interp *interp,
Index: generic/tclOOInt.h
==================================================================
--- generic/tclOOInt.h
+++ generic/tclOOInt.h
@@ -493,10 +493,14 @@
MODULE_SCOPE int TclNRNewObjectInstance(Tcl_Interp *interp,
Tcl_Class cls, const char *nameStr,
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);
MODULE_SCOPE void TclOODeleteContext(CallContext *contextPtr);
MODULE_SCOPE void TclOODelMethodRef(Method *method);
Index: generic/tclPipe.c
==================================================================
--- generic/tclPipe.c
+++ generic/tclPipe.c
@@ -463,10 +463,49 @@
* descriptor will be the end of the file. If
* this is NULL, then all stderr output goes
* to our stderr. If the pipeline specifies
* redirection then the file will still be
* created but it will never get any data. */
+{
+ return TclCreatePipelinePwd(interp, argc, argv, pidArrayPtr, inPipePtr,
+ outPipePtr, errFilePtr, NULL);
+}
+
+int
+TclCreatePipelinePwd(
+ Tcl_Interp *interp, /* Interpreter to use for error reporting. */
+ int argc, /* Number of entries in argv. */
+ CONST char **argv, /* Array of strings describing commands in
+ * pipeline plus I/O redirection with <, <<,
+ * >, etc. Argv[argc] must be NULL. */
+ Tcl_Pid **pidArrayPtr, /* Word at *pidArrayPtr gets filled in with
+ * address of array of pids for processes in
+ * pipeline (first pid is first process in
+ * pipeline). */
+ TclFile *inPipePtr, /* If non-NULL, input to the pipeline comes
+ * from a pipe (unless overridden by
+ * redirection in the command). The file id
+ * with which to write to this pipe is stored
+ * at *inPipePtr. NULL means command specified
+ * its own input source. */
+ TclFile *outPipePtr, /* If non-NULL, output to the pipeline goes to
+ * a pipe, unless overriden by redirection in
+ * the command. The file id with which to read
+ * frome this pipe is stored at *outPipePtr.
+ * NULL means command specified its own output
+ * sink. */
+ TclFile *errFilePtr, /* If non-NULL, all stderr output from the
+ * pipeline will go to a temporary file
+ * created here, and a descriptor to read the
+ * file will be left at *errFilePtr. The file
+ * will be removed already, so closing this
+ * descriptor will be the end of the file. If
+ * this is NULL, then all stderr output goes
+ * to our stderr. If the pipeline specifies
+ * redirection then the file will still be
+ * created but it will never get any data. */
+ Tcl_Obj *pwdPtr)
{
Tcl_Pid *pidPtr = NULL; /* Points to malloc-ed array holding all the
* pids of child processes. */
int numPids; /* Actual number of processes that exist at
* *pidPtr right now. */
@@ -924,12 +963,12 @@
* argv to be modified.
*/
oldName = argv[i];
argv[i] = Tcl_DStringValue(&execBuffer);
- result = TclpCreateProcess(interp, lastArg - i, argv + i,
- curInFile, curOutFile, curErrFile, &pid);
+ result = TclpCreateProcessPwd(interp, lastArg - i, argv + i,
+ curInFile, curOutFile, curErrFile, pwdPtr, &pid);
argv[i] = oldName;
if (result != TCL_OK) {
goto error;
}
Tcl_DStringFree(&execBuffer);
@@ -1058,10 +1097,23 @@
* NULL. */
int argc, /* How many arguments. */
const char **argv, /* Array of arguments for command pipe. */
int flags) /* Or'ed combination of TCL_STDIN, TCL_STDOUT,
* TCL_STDERR, and TCL_ENFORCE_MODE. */
+{
+ return TclOpenCommandChannel(interp, argc, argv, flags, NULL);
+}
+
+Tcl_Channel
+TclOpenCommandChannel(
+ Tcl_Interp *interp, /* Interpreter for error reporting. Can NOT be
+ * NULL. */
+ int argc, /* How many arguments. */
+ CONST char **argv, /* Array of arguments for command pipe. */
+ int flags, /* Or'ed combination of TCL_STDIN, TCL_STDOUT,
+ * TCL_STDERR, and TCL_ENFORCE_MODE. */
+ Tcl_Obj *pwdPtr)
{
TclFile *inPipePtr, *outPipePtr, *errFilePtr;
TclFile inPipe, outPipe, errFile;
int numPids;
Tcl_Pid *pidPtr;
@@ -1071,12 +1123,12 @@
inPipePtr = (flags & TCL_STDIN) ? &inPipe : NULL;
outPipePtr = (flags & TCL_STDOUT) ? &outPipe : NULL;
errFilePtr = (flags & TCL_STDERR) ? &errFile : NULL;
- numPids = TclCreatePipeline(interp, argc, argv, &pidPtr, inPipePtr,
- outPipePtr, errFilePtr);
+ numPids = TclCreatePipelinePwd(interp, argc, argv, &pidPtr, inPipePtr,
+ outPipePtr, errFilePtr, pwdPtr);
if (numPids < 0) {
goto error;
}
Index: generic/tclPkg.c
==================================================================
--- generic/tclPkg.c
+++ generic/tclPkg.c
@@ -416,11 +416,11 @@
void *clientDataPtr)
{
Interp *iPtr = (Interp *) interp;
Package *pkgPtr;
PkgAvail *availPtr, *bestPtr, *bestStablePtr;
- char *availVersion, *bestVersion;
+ char *availVersion, *bestVersion, *bestStableVersion;
/* Internal rep. of versions */
int availStable, code, satisfies, pass;
char *script, *pkgVersionI;
Tcl_DString command;
@@ -464,10 +464,11 @@
*/
bestPtr = NULL;
bestStablePtr = NULL;
bestVersion = NULL;
+ bestStableVersion = NULL;
for (availPtr = pkgPtr->availPtr; availPtr != NULL;
availPtr = availPtr->nextPtr) {
if (CheckVersionAndConvert(interp, availPtr->version,
&availVersion, &availStable) != TCL_OK) {
@@ -478,63 +479,85 @@
*/
continue;
}
- if (bestPtr != NULL) {
- int res = CompareVersions(availVersion, bestVersion, NULL);
-
- /*
- * Note: Use internal reps!
- */
-
- if (res <= 0) {
- /*
- * The version of the package sought is not as good as the
- * currently selected version. Ignore it.
- */
-
- ckfree(availVersion);
- availVersion = NULL;
- continue;
- }
- }
-
- /*
- * We have found a version which is better than our max.
- */
-
+ /* Check satisfaction of requirements before considering the current version further. */
if (reqc > 0) {
- /* Check satisfaction of requirements. */
-
satisfies = SomeRequirementSatisfied(availVersion, reqc, reqv);
if (!satisfies) {
ckfree(availVersion);
availVersion = NULL;
continue;
}
}
- bestPtr = availPtr;
-
- if (bestVersion != NULL) {
- ckfree(bestVersion);
- }
- bestVersion = availVersion;
-
- /*
- * If this new best version is stable then it also has to be
- * better than the max stable version found so far.
- */
-
- if (availStable) {
+ if (bestPtr != NULL) {
+ int res = CompareVersions(availVersion, bestVersion, NULL);
+
+ /*
+ * Note: Used internal reps in the comparison!
+ */
+
+ if (res > 0) {
+ /*
+ * The version of the package sought is better than the
+ * currently selected version.
+ */
+ goto newbest;
+ }
+ } else {
+ newbest:
+ /* We have found a version which is better than our max. */
+
+ bestPtr = availPtr;
+ CheckVersionAndConvert(interp, bestPtr->version, &bestVersion, NULL);
+ }
+
+ if (!availStable) {
+ ckfree(availVersion);
+ availVersion = NULL;
+ continue;
+ }
+
+ if (bestStablePtr != NULL) {
+ int res = CompareVersions(availVersion, bestStableVersion, NULL);
+
+ /*
+ * Note: Used internal reps in the comparison!
+ */
+
+ if (res > 0) {
+ /*
+ * This stable version of the package sought is better
+ * than the currently selected stable version.
+ */
+ goto newstable;
+ }
+ } else {
+ newstable:
+ /* We have found a stable version which is better than our max stable. */
bestStablePtr = availPtr;
+ CheckVersionAndConvert(interp, bestStablePtr->version, &bestStableVersion, NULL);
}
- }
+
+ ckfree(availVersion);
+ availVersion = NULL;
+ } /* end for */
+
+ /*
+ * Clean up memorized internal reps, if any.
+ */
if (bestVersion != NULL) {
ckfree(bestVersion);
+ bestVersion = NULL;
+ }
+
+ if (bestStableVersion != NULL) {
+ ckfree(bestStableVersion);
+ bestStableVersion = NULL;
}
/*
* Now choose a version among the two best. For 'latest' we simply
* take (actually keep) the best. For 'stable' we take the best
Index: generic/tclProc.c
==================================================================
--- generic/tclProc.c
+++ generic/tclProc.c
@@ -122,15 +122,14 @@
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
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");
return TCL_ERROR;
}
@@ -139,66 +138,43 @@
* Determine the namespace where the procedure should reside. Unless the
* command name includes namespace qualifiers, this will be the current
* 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;
}
/*
* 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
* later when the procedure is called to determine what namespace the
* procedure will run in. This will be different than the current
@@ -391,17 +367,17 @@
Tcl_Obj *argsPtr, /* Description of arguments. */
Tcl_Obj *bodyPtr, /* Command body. */
Proc **procPtrPtr) /* Returns: pointer to proc data. */
{
Interp *iPtr = (Interp *) interp;
- const char **argArray = NULL;
register Proc *procPtr;
- int i, length, result, numArgs;
- const char *args, *bytes, *p;
+ int i, result, numArgs, plen;
+ const char *bytes, *argname, *argnamei;
+ char argnamelast;
register CompiledLocal *localPtr = NULL;
- Tcl_Obj *defPtr;
+ Tcl_Obj *defPtr, *errorObj, **argArray;
int precompiled = 0;
if (bodyPtr->typePtr == &tclProcBodyType) {
/*
* Because the body is a TclProProcBody, the actual body is already
@@ -434,10 +410,11 @@
* identical. Note that we don't use Tcl_DuplicateObj since we would
* not want any bytecode internal representation.
*/
if (Tcl_IsShared(bodyPtr)) {
+ int length;
Tcl_Obj *sharedBodyPtr = bodyPtr;
bytes = TclGetStringFromObj(bodyPtr, &length);
bodyPtr = Tcl_NewStringObj(bytes, length);
@@ -471,16 +448,13 @@
/*
* Break up the argument list into argument specifiers, then process each
* argument specifier. If the body is precompiled, processing is limited
* to checking that the parsed argument is consistent with the one stored
* in the Proc.
- *
- * THIS FAILS IF THE ARG LIST OBJECT'S STRING REP CONTAINS NULS.
*/
- args = TclGetStringFromObj(argsPtr, &length);
- result = Tcl_SplitList(interp, args, &numArgs, &argArray);
+ result = Tcl_ListObjGetElements(interp , argsPtr ,&numArgs ,&argArray);
if (result != TCL_OK) {
goto procError;
}
if (precompiled) {
@@ -500,77 +474,74 @@
}
for (i = 0; i < numArgs; i++) {
int fieldCount, nameLength;
size_t valueLength;
- const char **fieldValues;
+ Tcl_Obj **fieldValues;
/*
* Now divide the specifier up into name and default.
*/
- result = Tcl_SplitList(interp, argArray[i], &fieldCount,
+ result = Tcl_ListObjGetElements(interp, argArray[i], &fieldCount,
&fieldValues);
if (result != TCL_OK) {
goto procError;
}
if (fieldCount > 2) {
- ckfree(fieldValues);
- Tcl_SetObjResult(interp, Tcl_ObjPrintf(
- "too many fields in argument specifier \"%s\"",
- argArray[i]));
+ errorObj = Tcl_NewStringObj(
+ "too many fields in argument specifier \"", -1);
+ Tcl_AppendObjToObj(errorObj, argArray[i]);
+ Tcl_AppendToObj(errorObj, "\"", -1);
+ Tcl_SetObjResult(interp, errorObj);
Tcl_SetErrorCode(interp, "TCL", "OPERATION", "PROC",
"FORMALARGUMENTFORMAT", NULL);
goto procError;
}
- if ((fieldCount == 0) || (*fieldValues[0] == 0)) {
- ckfree(fieldValues);
+ if ((fieldCount == 0) || (fieldValues[0]->length == 0)) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"argument with no name", -1));
Tcl_SetErrorCode(interp, "TCL", "OPERATION", "PROC",
"FORMALARGUMENTFORMAT", NULL);
goto procError;
}
- nameLength = strlen(fieldValues[0]);
+ nameLength = Tcl_NumUtfChars(Tcl_GetString(fieldValues[0]), fieldValues[0]->length);
if (fieldCount == 2) {
- valueLength = strlen(fieldValues[1]);
+ valueLength = Tcl_NumUtfChars(Tcl_GetString(fieldValues[1]),
+ fieldValues[1]->length);
} else {
valueLength = 0;
}
/*
* Check that the formal parameter name is a scalar.
*/
- p = fieldValues[0];
- while (*p != '\0') {
- if (*p == '(') {
- const char *q = p;
- do {
- q++;
- } while (*q != '\0');
- q--;
- if (*q == ')') { /* We have an array element. */
+ argname = Tcl_GetStringFromObj(fieldValues[0], &plen);
+ argnamei = argname;
+ argnamelast = argname[plen-1];
+ while (plen--) {
+ if (argnamei[0] == '(') {
+ if (argnamelast == ')') { /* We have an array element. */
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"formal parameter \"%s\" is an array element",
- fieldValues[0]));
- ckfree(fieldValues);
+ Tcl_GetString(fieldValues[0])));
Tcl_SetErrorCode(interp, "TCL", "OPERATION", "PROC",
"FORMALARGUMENTFORMAT", NULL);
goto procError;
}
- } else if ((*p == ':') && (*(p+1) == ':')) {
- Tcl_SetObjResult(interp, Tcl_ObjPrintf(
- "formal parameter \"%s\" is not a simple name",
- fieldValues[0]));
- ckfree(fieldValues);
+ } else if ((argnamei[0] == ':') && (argnamei[1] == ':')) {
+ errorObj = Tcl_NewStringObj("formal parameter \"", -1);
+ Tcl_AppendObjToObj(errorObj, fieldValues[0]);
+ Tcl_AppendToObj(errorObj, "\" is not a simple name", -1);
+ Tcl_SetObjResult(interp, errorObj);
Tcl_SetErrorCode(interp, "TCL", "OPERATION", "PROC",
"FORMALARGUMENTFORMAT", NULL);
goto procError;
}
- p++;
+ argnamei = Tcl_UtfNext(argnamei);
}
if (precompiled) {
/*
* Compare the parsed argument with the stored one. Note that the
@@ -582,19 +553,18 @@
* precompiled procs is VAR_TEMPORARY (also unchanged). It is
* needed later when retrieving the variable names.
*/
if ((localPtr->nameLength != nameLength)
- || (strcmp(localPtr->name, fieldValues[0]))
+ || (Tcl_UtfNcmp(localPtr->name, argname, nameLength))
|| (localPtr->frameIndex != i)
|| !(localPtr->flags & VAR_ARGUMENT)
|| (localPtr->defValuePtr == NULL && fieldCount == 2)
|| (localPtr->defValuePtr != NULL && fieldCount != 2)) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"procedure \"%s\": formal parameter %d is "
"inconsistent with precompiled body", procName, i));
- ckfree(fieldValues);
Tcl_SetErrorCode(interp, "TCL", "OPERATION", "PROC",
"BYTECODELIES", NULL);
goto procError;
}
@@ -605,16 +575,17 @@
if (localPtr->defValuePtr != NULL) {
const char *tmpPtr = TclGetString(localPtr->defValuePtr);
size_t tmpLength = localPtr->defValuePtr->length;
if ((valueLength != tmpLength) ||
- strncmp(fieldValues[1], tmpPtr, tmpLength)) {
- Tcl_SetObjResult(interp, Tcl_ObjPrintf(
- "procedure \"%s\": formal parameter \"%s\" has "
- "default value inconsistent with precompiled body",
- procName, fieldValues[0]));
- ckfree(fieldValues);
+ Tcl_UtfNcmp(Tcl_GetString(fieldValues[1]), tmpPtr, tmpLength)) {
+ errorObj = Tcl_ObjPrintf(
+ "procedure \"%s\": formal parameter \"" ,procName);
+ Tcl_AppendObjToObj(errorObj, fieldValues[0]);
+ Tcl_AppendToObj(errorObj, "\" has "
+ "default value inconsistent with precompiled body", -1);
+ Tcl_SetObjResult(interp, errorObj);
Tcl_SetErrorCode(interp, "TCL", "OPERATION", "PROC",
"BYTECODELIES", NULL);
goto procError;
}
}
@@ -630,44 +601,40 @@
/*
* Allocate an entry in the runtime procedure frame's array of
* local variables for the argument.
*/
- localPtr = ckalloc(TclOffset(CompiledLocal, name) + nameLength+1);
+ localPtr = ckalloc(TclOffset(CompiledLocal, name) + fieldValues[0]->length +1);
if (procPtr->firstLocalPtr == NULL) {
procPtr->firstLocalPtr = procPtr->lastLocalPtr = localPtr;
} else {
procPtr->lastLocalPtr->nextPtr = localPtr;
procPtr->lastLocalPtr = localPtr;
}
localPtr->nextPtr = NULL;
- localPtr->nameLength = nameLength;
+ localPtr->nameLength = Tcl_NumUtfChars(argname, fieldValues[0]->length);
localPtr->frameIndex = i;
localPtr->flags = VAR_ARGUMENT;
localPtr->resolveInfo = NULL;
if (fieldCount == 2) {
- localPtr->defValuePtr =
- Tcl_NewStringObj(fieldValues[1], valueLength);
+ localPtr->defValuePtr = fieldValues[1];
Tcl_IncrRefCount(localPtr->defValuePtr);
} else {
localPtr->defValuePtr = NULL;
}
- memcpy(localPtr->name, fieldValues[0], nameLength + 1);
+ memcpy(localPtr->name, argname, fieldValues[0]->length + 1);
if ((i == numArgs - 1)
&& (localPtr->nameLength == 4)
&& (localPtr->name[0] == 'a')
&& (strcmp(localPtr->name, "args") == 0)) {
localPtr->flags |= VAR_IS_ARGS;
}
}
-
- ckfree(fieldValues);
}
*procPtrPtr = procPtr;
- ckfree(argArray);
return TCL_OK;
procError:
if (precompiled) {
procPtr->refCount--;
@@ -684,13 +651,10 @@
ckfree(localPtr);
}
ckfree(procPtr);
}
- if (argArray != NULL) {
- ckfree(argArray);
- }
return TCL_ERROR;
}
/*
*----------------------------------------------------------------------
Index: generic/tclScan.c
==================================================================
--- generic/tclScan.c
+++ generic/tclScan.c
@@ -883,13 +883,21 @@
case 'c':
/*
* Scan a single Unicode character.
*/
- string += TclUtfToUniChar(string, &sch);
+ offset = TclUtfToUniChar(string, &sch);
+ i = (int)sch;
+#if TCL_UTF_MAX == 4
+ if (!offset) {
+ offset = Tcl_UtfToUniChar(string, &sch);
+ i = (((i<<10) & 0x0FFC00) + 0x10000) + (sch & 0x3FF);
+ }
+#endif
+ string += offset;
if (!(flags & SCAN_SUPPRESS)) {
- objPtr = Tcl_NewIntObj((int)sch);
+ objPtr = Tcl_NewIntObj(i);
Tcl_IncrRefCount(objPtr);
CLANG_ASSERT(objs);
objs[objIndex++] = objPtr;
}
break;
Index: generic/tclStringObj.c
==================================================================
--- generic/tclStringObj.c
+++ generic/tclStringObj.c
@@ -3240,44 +3240,48 @@
try++;
}
return -1;
}
+ /*
+ * Check if we have two strings of single-byte characters. If we have, we
+ * can use strstr() to do the search. Note that we can sometimes have
+ * multibyte characters when the string could be minimally represented
+ * using single byte characters; we can't assume that a mismatch here
+ * means no match.
+ */
+
lh = Tcl_GetCharLength(haystack);
- if (haystack->bytes && (lh == haystack->length)) {
- /* haystack is all single-byte chars */
-
- if (needle->bytes && (ln == needle->length)) {
- /* needle is also all single-byte chars */
- char *found = strstr(haystack->bytes + start, needle->bytes);
-
- if (found) {
- return (found - haystack->bytes);
- } else {
- return -1;
- }
- } else {
- /*
- * Cannot find substring with a multi-byte char inside
- * a string with no multi-byte chars.
- */
+ if (haystack->bytes && (lh == haystack->length) && needle->bytes
+ && (ln == needle->length)) {
+ /*
+ * Both haystack and needle are all single-byte chars.
+ */
+
+ char *found = strstr(haystack->bytes + start, needle->bytes);
+
+ if (found) {
+ return (found - haystack->bytes);
+ } else {
return -1;
}
} else {
+ /*
+ * Do the search on the unicode representation for simplicity.
+ */
+
Tcl_UniChar *try, *end, *uh;
Tcl_UniChar *un = Tcl_GetUnicodeFromObj(needle, &ln);
uh = Tcl_GetUnicodeFromObj(haystack, &lh);
end = uh + lh;
- try = uh + start;
- while (try + ln <= end) {
- if ((*try == *un)
- && (0 == memcmp(try+1, un+1, (ln-1)*sizeof(Tcl_UniChar)))) {
+ for (try = uh + start; try + ln <= end; try++) {
+ if ((*try == *un) && (0 ==
+ memcmp(try + 1, un + 1, (ln-1) * sizeof(Tcl_UniChar)))) {
return (try - uh);
}
- try++;
}
return -1;
}
}
@@ -3456,11 +3460,10 @@
/*
* Create a non-empty, pure unicode value, so we can coax
* Tcl_SetObjLength into growing the unicode rep buffer.
*/
- ch = 0;
objPtr = Tcl_NewUnicodeObj(&ch, 1);
Tcl_SetObjLength(objPtr, stringPtr->numChars);
to = Tcl_GetUnicode(objPtr);
while (--src >= from) {
*to++ = *src;
@@ -3559,11 +3562,11 @@
int numBytes,
int numAppendChars)
{
String *stringPtr = GET_STRING(objPtr);
int needed, numOrigChars = 0;
- Tcl_UniChar *dst;
+ Tcl_UniChar *dst, unichar = 0;
if (stringPtr->hasUnicode) {
numOrigChars = stringPtr->numChars;
}
if (numAppendChars == -1) {
@@ -3582,11 +3585,12 @@
stringPtr->numChars = needed;
} else {
numAppendChars = 0;
}
for (dst=stringPtr->unicode + numOrigChars; numAppendChars-- > 0; dst++) {
- bytes += TclUtfToUniChar(bytes, dst);
+ bytes += TclUtfToUniChar(bytes, &unichar);
+ *dst = unichar;
}
*dst = 0;
}
/*
Index: generic/tclStubInit.c
==================================================================
--- generic/tclStubInit.c
+++ generic/tclStubInit.c
@@ -364,10 +364,30 @@
# undef Tcl_GlobalEvalObj
# define Tcl_GlobalEvalObj 0
# 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
# define TclpLocaltime 0
# undef TclpGmtime
@@ -376,10 +396,24 @@
# define TclpGmtime_unix 0
#else /* TCL_NO_DEPRECATED */
# 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
static int
seekOld(
@@ -528,26 +562,26 @@
0, /* 107 */
TclTeardownNamespace, /* 108 */
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 */
Tcl_SetNamespaceResolvers, /* 131 */
TclpHasSockets, /* 132 */
@@ -594,12 +628,12 @@
TclUniCharMatch, /* 173 */
0, /* 174 */
TclCallVarTraces, /* 175 */
TclCleanupVar, /* 176 */
TclVarErrMsg, /* 177 */
- Tcl_SetStartupScript, /* 178 */
- Tcl_GetStartupScript, /* 179 */
+ TclSetStartupScript, /* 178 */
+ TclGetStartupScript, /* 179 */
0, /* 180 */
0, /* 181 */
TclpLocaltime, /* 182 */
TclpGmtime, /* 183 */
0, /* 184 */
Index: generic/tclUtil.c
==================================================================
--- generic/tclUtil.c
+++ generic/tclUtil.c
@@ -972,11 +972,11 @@
const char *src, /* String to convert to Tcl list element. */
int length, /* Number of bytes in src, or -1. */
int *flagPtr) /* Where to store information to guide
* Tcl_ConvertElement. */
{
- int flags = CONVERT_ANY;
+ char flags = CONVERT_ANY;
int numBytes = TclScanElement(src, length, &flags);
*flagPtr = flags;
return numBytes;
}
@@ -1013,11 +1013,11 @@
int
TclScanElement(
const char *src, /* String to convert to Tcl list element. */
int length, /* Number of bytes in src, or -1. */
- int *flagPtr) /* Where to store information to guide
+ char *flagPtr) /* Where to store information to guide
* Tcl_ConvertElement. */
{
const char *p = src;
int nestingLevel = 0; /* Brace nesting count */
int forbidNone = 0; /* Do not permit CONVERT_NONE mode. Something
@@ -1545,15 +1545,14 @@
char *
Tcl_Merge(
int argc, /* How many strings to merge. */
const char *const *argv) /* Array of string values. */
{
-#define LOCAL_SIZE 20
- int localFlags[LOCAL_SIZE], *flagPtr = NULL;
+#define LOCAL_SIZE 64
+ char localFlags[LOCAL_SIZE], *flagPtr = NULL;
int i, bytesNeeded = 0;
char *result, *dst;
- const int maxFlags = UINT_MAX / sizeof(int);
/*
* Handle empty list case first, so logic of the general case can be
* simpler.
*/
@@ -1568,26 +1567,12 @@
* Pass 1: estimate space, gather flags.
*/
if (argc <= LOCAL_SIZE) {
flagPtr = localFlags;
- } else if (argc > maxFlags) {
- /*
- * We cannot allocate a large enough flag array to format this list in
- * one pass. We could imagine converting this routine to a multi-pass
- * implementation, but for sizeof(int) == 4, the limit is a max of
- * 2^30 list elements and since each element is at least one byte
- * formatted, and requires one byte space between it and the next one,
- * that a minimum space requirement of 2^31 bytes, which is already
- * INT_MAX. If we tried to format a list of > maxFlags elements, we're
- * just going to overflow the size limits on the formatted string
- * anyway, so just issue that same panic early.
- */
-
- Tcl_Panic("max size for a Tcl value (%d bytes) exceeded", INT_MAX);
} else {
- flagPtr = ckalloc(argc * sizeof(int));
+ flagPtr = ckalloc(argc);
}
for (i = 0; i < argc; i++) {
flagPtr[i] = ( i ? TCL_DONT_QUOTE_HASH : 0 );
bytesNeeded += TclScanElement(argv[i], -1, &flagPtr[i]);
if (bytesNeeded < 0) {
@@ -2715,11 +2700,11 @@
const char *element) /* String to append. Must be
* null-terminated. */
{
char *dst = dsPtr->string + dsPtr->length;
int needSpace = TclNeedSpace(dsPtr->string, dst);
- int flags = needSpace ? TCL_DONT_QUOTE_HASH : 0;
+ char flags = needSpace ? TCL_DONT_QUOTE_HASH : 0;
int newSize = dsPtr->length + needSpace
+ TclScanElement(element, -1, &flags);
/*
* Allocate a larger buffer for the string if the current one isn't large
Index: library/init.tcl
==================================================================
--- library/init.tcl
+++ library/init.tcl
@@ -71,47 +71,10 @@
if {$Dir ni $Path} {
lappend Path $Dir
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 {}
# Windows specific end of initialization
Index: library/opt/optparse.tcl
==================================================================
--- library/opt/optparse.tcl
+++ library/opt/optparse.tcl
@@ -6,14 +6,14 @@
# WARNING: This code will go away in a future release
# of Tcl. It is NOT supported and you should not rely
# on it. If your code does rely on this package you
# may directly incorporate this code into your application.
-package require Tcl 8.2
+package require Tcl 8.5-
# When this version number changes, update the pkgIndex.tcl file
# and the install directory in the Makefiles.
-package provide opt 0.4.6
+package provide opt 0.4.7
namespace eval ::tcl {
# Exported APIs
namespace export OptKeyRegister OptKeyDelete OptKeyError OptKeyParse \
Index: library/opt/pkgIndex.tcl
==================================================================
--- library/opt/pkgIndex.tcl
+++ library/opt/pkgIndex.tcl
@@ -6,7 +6,7 @@
# information so that packages will be loaded automatically
# in response to "package require" commands. When this
# script is sourced, the variable $dir must contain the
# full path name of this file's directory.
-if {![package vsatisfies [package provide Tcl] 8.2]} {return}
-package ifneeded opt 0.4.6 [list source [file join $dir optparse.tcl]]
+if {![package vsatisfies [package provide Tcl] 8.5-]} {return}
+package ifneeded opt 0.4.7 [list source [file join $dir optparse.tcl]]
Index: library/tcltest/pkgIndex.tcl
==================================================================
--- library/tcltest/pkgIndex.tcl
+++ library/tcltest/pkgIndex.tcl
@@ -6,7 +6,7 @@
# information so that packages will be loaded automatically
# in response to "package require" commands. When this
# script is sourced, the variable $dir must contain the
# full path name of this file's directory.
-if {![package vsatisfies [package provide Tcl] 8.5]} {return}
-package ifneeded tcltest 2.4.0 [list source [file join $dir tcltest.tcl]]
+if {![package vsatisfies [package provide Tcl] 8.5-]} {return}
+package ifneeded tcltest 2.4.1 [list source [file join $dir tcltest.tcl]]
Index: library/tcltest/tcltest.tcl
==================================================================
--- library/tcltest/tcltest.tcl
+++ library/tcltest/tcltest.tcl
@@ -20,11 +20,11 @@
namespace eval tcltest {
# When the version number changes, be sure to update the pkgIndex.tcl file,
# and the install directory in the Makefiles. When the minor version
# changes (new feature) be sure to update the man page as well.
- variable Version 2.4.0
+ variable Version 2.4.1
# Compatibility support for dumb variables defined in tcltest 1
# Do not use these. Call [package provide Tcl] and [info patchlevel]
# yourself. You don't need tcltest to wrap it for you.
variable version [package provide Tcl]
Index: tests/exec.test
==================================================================
--- tests/exec.test
+++ tests/exec.test
@@ -105,10 +105,15 @@
exit
} sleep]
set path(exit) [makeFile {
exit $argv
} exit]
+
+set path(pwd) [makeFile {
+ puts stdout [pwd]
+ exit
+} pwd]
proc readfile filename {
set f [open $filename]
set d [read $f]
close $f
@@ -546,11 +551,11 @@
test exec-14.2 {-keepnewline switch} -constraints {exec} -body {
exec -keepnewline
} -returnCodes error -result {wrong # args: should be "exec ?-option ...? arg ?arg ...?"}
test exec-14.3 {unknown switch} -constraints {exec} -body {
exec -gorp
-} -returnCodes error -result {bad option "-gorp": must be -ignorestderr, -keepnewline, or --}
+} -returnCodes error -result {bad option "-gorp": must be -ignorestderr, -keepnewline, -pwd, or --}
test exec-14.4 {-- switch} -constraints {exec} -body {
exec -- -gorp
} -returnCodes error -result {couldn't execute "-gorp": no such file or directory}
test exec-14.5 {-ignorestderr switch} {exec} {
# Alas, the use of -ignorestderr is buried here :-(
@@ -697,15 +702,86 @@
test exec-20.1 {exec .CMD file} -constraints {win} -body {
set log [makeFile {} exec201.log]
exec [makeFile "echo %1> $log" exec201.CMD] "Testing exec-20.1"
viewFile $log
} -result "\"Testing exec-20.1\""
+
+test exec-20.1 {exec with -pwd flag} {exec} {
+ set res {}
+ lappend res [exec [interpreter] $path(pwd)]
+ # Check that this process is not affected
+ lappend res [pwd]
+} [list [pwd] [pwd]]
+
+test exec-20.2 {exec with -pwd flag} {exec} {
+ set res {}
+ lappend res [exec -pwd .. [interpreter] $path(pwd)]
+ # Check that this process is not affected
+ lappend res [pwd]
+} [list [file normalize [pwd]/..] [pwd]]
+
+test exec-20.3 {exec with -pwd flag} {exec unix} {
+ set res {}
+ lappend res [exec -pwd /usr [interpreter] $path(pwd)]
+ # Check that this process is not affected
+ lappend res [pwd]
+} [list /usr [pwd]]
+
+test exec-20.4 {exec with -pwd flag} -constraints {exec} -body {
+ exec -pwd /_fnurg_/_fnorg_/_gurkmeja_ [interpreter] $path(pwd)
+} -returnCodes 1 -match glob -result \
+ {*couldn't change working directory to "/_fnurg_/_fnorg_/_gurkmeja_"*}
+
+test exec-21.1 {exec with -pwd flag} {exec} {
+ set res {}
+ set ch [open "|[interpreter] $path(pwd)"]
+ lappend res [read $ch]
+ close $ch
+ # Check that this process is not affected
+ lappend res [pwd]
+} [list [pwd]\n [pwd]]
+
+test exec-21.2 {exec with -pwd flag} {exec} {
+ set res {}
+ set ch [open "|[interpreter] $path(pwd)" r 0 ..]
+ lappend res [read $ch]
+ close $ch
+ # Check that this process is not affected
+ lappend res [pwd]
+} [list [file normalize [pwd]/..]\n [pwd]]
+
+test exec-21.3 {exec with -pwd flag} {exec unix} {
+ set res {}
+ set ch [open "|[interpreter] $path(pwd)" r 0 /usr]
+ lappend res [read $ch]
+ close $ch
+ # Check that this process is not affected
+ lappend res [pwd]
+} [list /usr\n [pwd]]
+
+test exec-21.4 {exec with -pwd flag} -constraints {exec} -body {
+ open "|[interpreter] $path(pwd)" r 0 /_fnurg_/_fnorg_/_gurkmeja_
+} -returnCodes 1 -match glob -result \
+ {*couldn't change working directory to "/_fnurg_/_fnorg_/_gurkmeja_"*}
+
+test exec-22.1 {exec with -pwd flag} -constraints {exec} -body {
+ set d [makeDirectory mydir]
+ set f [makeFile {miffo piffo} myfile $d]
+ set dir [file dirname $f]
+ set tail [file tail $f]
+ set res [file exists $tail]
+ set ch [open $tail r 0 $dir]
+ lappend res [read $ch]
+ close $ch
+ set res
+} -result "0 {miffo piffo\n}" -cleanup { removeFile myfile ; removeDirectory mydir }
+
# ----------------------------------------------------------------------
# cleanup
-foreach file {gorp.file gorp.file2 echo echo2 cat wc sh sh2 sleep exit err} {
+foreach file {script gorp.file gorp.file2 echo echo2 cat wc sh sh2 sleep exit err pwd} {
removeFile $file
}
unset -nocomplain path
::tcltest::cleanupTests
Index: tests/expr-old.test
==================================================================
--- tests/expr-old.test
+++ tests/expr-old.test
@@ -1157,40 +1157,52 @@
} -result 0
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}]
test expr-old-40.5 {min math function} -body {
expr {min("a", 0)}
} -returnCodes error -match glob -result *
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)}
} -result 0
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}]
test expr-old-41.5 {max math function} -body {
expr {max("a", 0)}
} -returnCodes error -match glob -result *
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:
if {(4195835.0 - (4195835.0/3145727.0)*3145727.0) == 256.0} {
puts "Warning: this machine contains a defective Pentium processor"
Index: tests/interp.test
==================================================================
--- tests/interp.test
+++ tests/interp.test
@@ -1845,11 +1845,11 @@
lappend l [lsort [interp aliases a]] [lsort [interp hidden a]]
a alias bar {}
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}
} -body {
interp create a
Index: tests/namespace.test
==================================================================
--- tests/namespace.test
+++ tests/namespace.test
@@ -1782,12 +1782,15 @@
namespace ensemble create
}
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}
trace add execution demo enter [namespace code trial]
namespace ensemble create -command foo -map [list bar $target]
@@ -1798,10 +1801,23 @@
rename demo {}
rename trial {}
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*
proc x1 {} {format 1}
proc x2 {} {format 2}
@@ -1918,11 +1934,11 @@
namespace ensemble create -command foobar -subcommands {foobarcget foobarconfigure}
} -body {
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 ...?"}
test namespace-45.1 {ensemble: introspection} {
@@ -2082,11 +2098,11 @@
lappend result [catch {ns a b c} msg] $msg
lappend result [catch {ns b c d} msg] $msg
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]*}
proc Magic {ensemble subcmd args} {
error foobar
@@ -3181,11 +3197,11 @@
} -result\
{0 0\
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}}
test namespace-53.11 {ensembles: nested rewrite} -setup {
namespace eval ns {
@@ -3265,10 +3281,22 @@
} finally {
namespace delete ::testing
}
}
} {::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 {}}
catch {unset l}
catch {unset msg}
Index: tests/package.test
==================================================================
--- tests/package.test
+++ tests/package.test
@@ -18,22 +18,23 @@
}
::tcltest::loadTestedCommands
catch [list package require -exact Tcltest [info patchlevel]]
-testConstraint testpreferstable [llength [info commands testpreferstable]]
-
# Do all this in a slave interp to avoid garbaging the package list
set i [interp create]
tcltest::loadIntoSlaveInterpreter $i {*}$argv
+load {} Tcltest $i
interp eval $i {
namespace import -force ::tcltest::*
-package forget {*}[package names]
+#package forget {*}[package names]
set oldPkgUnknown [package unknown]
package unknown {}
set oldPath $auto_path
set auto_path ""
+
+testConstraint testpreferstable [llength [info commands testpreferstable]]
test package-1.1 {pkg::create gives error on insufficient args} -body {
::pkg::create
} -returnCodes error -match glob -result {wrong # args: should be "*"}
test package-1.2 {pkg::create gives error on bad args} -body {
@@ -137,51 +138,51 @@
} -body {
foreach i {1.4 3.4 2.3 2.4 2.2} {
package ifneeded t $i "set x $i; package provide t $i"
}
package require t
- return $x
+ set x
} -result {3.4}
test package-3.2 {Tcl_PkgRequire procedure, picking best version} -setup {
package forget t
set x xxx
} -body {
foreach i {1.4 3.4 2.3 2.4 2.2 3.5 3.2} {
package ifneeded t $i "set x $i; package provide t $i"
}
package require t
- return $x
+ set x
} -result {3.5}
test package-3.3 {Tcl_PkgRequire procedure, picking best version} -setup {
package forget t
set x xxx
} -body {
foreach i {3.5 2.1 2.3} {
package ifneeded t $i "set x $i; package provide t $i"
}
package require t 2.2
- return $x
+ set x
} -result {2.3}
test package-3.4 {Tcl_PkgRequire procedure, picking best version} -setup {
package forget t
set x xxx
} -body {
foreach i {1.4 3.4 2.3 2.4 2.2} {
package ifneeded t $i "set x $i; package provide t $i"
}
package require -exact t 2.3
- return $x
+ set x
} -result {2.3}
test package-3.5 {Tcl_PkgRequire procedure, picking best version} -setup {
package forget t
set x xxx
} -body {
foreach i {1.4 3.4 2.3 2.4 2.2} {
package ifneeded t $i "set x $i; package provide t $i"
}
package require t 2.1
- return $x
+ set x
} -result {2.4}
test package-3.6 {Tcl_PkgRequire procedure, can't find suitable version} -setup {
package forget t
} -returnCodes error -body {
package unknown {}
@@ -236,11 +237,11 @@
package forget t
set x xxx
} -body {
package ifneeded t 1.2 "package forget t; set x 1.2; package provide t 1.2"
package require t 1.2
- return $x
+ set x
} -result {1.2}
test package-3.13 {Tcl_PkgRequire procedure, "package unknown" support} -setup {
package forget t
set x xxx
} -body {
@@ -254,11 +255,11 @@
foreach i {1.4 3.4 2.3 2.4 2.2} {
package ifneeded t $i "set x $i"
}
package unknown pkgUnknown
package require -exact t 1.5
- return $x
+ set x
} -cleanup {
package unknown {}
} -result {t 1.5-1.5}
test package-3.14 {Tcl_PkgRequire procedure, "package unknown" support} -setup {
package forget t
@@ -281,11 +282,11 @@
global x
set x $args
package provide [lindex $args 0] 2.0
}
package require {a b}
- return $x
+ set x
} -cleanup {
package unknown {}
} -result {{a b} 0-}
test package-3.16 {Tcl_PkgRequire procedure, "package unknown" error} -setup {
package forget t
@@ -573,73 +574,119 @@
package require -exact demo 1.2
} -returnCodes error -cleanup {
package forget demo
} -result {version conflict for package "demo": have 1.2.3, need exactly 1.2}
test package-3.50 {Tcl_PkgRequire procedure, picking best stable version} -constraints testpreferstable -setup {
+ interp create child
+ load {} Tcltest child
+ child eval {
testpreferstable
package forget t
set x xxx
+ }
} -body {
+ child eval {
foreach i {1.4 3.4 4.0a1 2.3 2.4 2.2} {
package ifneeded t $i "set x $i; package provide t $i"
}
package require t
- return $x
+ set x
+ }
+} -cleanup {
+ interp delete child
} -result {3.4}
test package-3.51 {Tcl_PkgRequire procedure, picking best stable version} -setup {
package forget t
set x xxx
} -body {
foreach i {1.2b1 1.2 1.3a2 1.3} {
package ifneeded t $i "set x $i; package provide t $i"
}
package require t
- return $x
+ set x
} -result {1.3}
test package-3.52 {Tcl_PkgRequire procedure, picking best stable version} -setup {
package forget t
set x xxx
} -body {
foreach i {1.2b1 1.2 1.3 1.3a2} {
package ifneeded t $i "set x $i; package provide t $i"
}
package require t
- return $x
+ set x
} -result {1.3}
+test pkg-3.53 {Tcl_PkgRequire procedure, picking best stable version} -constraints testpreferstable -setup {
+ testpreferstable
+ package forget t
+ set x xxx
+} -body {
+ foreach i {1.2b1 1.1} {
+ package ifneeded t $i "set x $i; package provide t $i"
+ }
+ package require t
+ set x
+} -result {1.1}
+
test package-4.1 {Tcl_PackageCmd procedure} -returnCodes error -body {
package
} -result {wrong # args: should be "package option ?arg ...?"}
-test package-4.2 {Tcl_PackageCmd procedure, "forget" option} {
+test package-4.2 {Tcl_PackageCmd procedure, "forget" option} -setup {
+ interp create child
+} -body {
+ child eval {
package forget {*}[package names]
package names
-} {}
-test package-4.3 {Tcl_PackageCmd procedure, "forget" option} {
+ }
+} -cleanup {
+ interp delete child
+} -result {}
+test package-4.3 {Tcl_PackageCmd procedure, "forget" option} -setup {
+ interp create child
+} -body {
+ child eval {
package forget {*}[package names]
package forget foo
-} {}
+ }
+} -cleanup {
+ interp delete child
+} -result {}
test package-4.4 {Tcl_PackageCmd procedure, "forget" option} -setup {
+ interp create child
+ child eval {
package forget {*}[package names]
set result {}
+ }
} -body {
+ child eval {
package ifneeded t 1.1 {first script}
package ifneeded t 2.3 {second script}
package ifneeded x 1.4 {x's script}
lappend result [lsort [package names]] [package versions t]
package forget t
lappend result [lsort [package names]] [package versions t]
+ }
+} -cleanup {
+ interp delete child
} -result {{t x} {1.1 2.3} x {}}
test package-4.5 {Tcl_PackageCmd procedure, "forget" option} -setup {
+ interp create child
+ child eval {
package forget {*}[package names]
+ }
} -body {
+ child eval {
package ifneeded a 1.1 {first script}
package ifneeded b 2.3 {second script}
package ifneeded c 1.4 {third script}
package forget
set result [list [lsort [package names]]]
package forget a c
lappend result [lsort [package names]]
+ }
+} -cleanup {
+ interp delete child
} -result {{a b c} b}
test package-4.5.1 {Tcl_PackageCmd procedure, "forget" option} -body {
# Test for Bug 415273
package ifneeded a 1 "I should have been forgotten"
package forget no-such-package a
@@ -654,32 +701,59 @@
package ifneeded a b c d
} -returnCodes error -result {wrong # args: should be "package ifneeded package version ?script?"}
test package-4.8 {Tcl_PackageCmd procedure, "ifneeded" option} -body {
package ifneeded t xyz
} -returnCodes error -result {expected version number but got "xyz"}
-test package-4.9 {Tcl_PackageCmd procedure, "ifneeded" option} {
+test package-4.9 {Tcl_PackageCmd procedure, "ifneeded" option} -setup {
+ interp create child
+} -body {
+ child eval {
package forget {*}[package names]
list [package ifneeded foo 1.1] [package names]
-} {{} {}}
+ }
+} -cleanup {
+ interp delete child
+} -result {{} {}}
test package-4.10 {Tcl_PackageCmd procedure, "ifneeded" option} -setup {
- package forget t
+ interp create child
+ child eval {
+ package forget {*}[package names]
+ }
} -body {
+ child eval {
package ifneeded t 1.4 "script for t 1.4"
list [package names] [package ifneeded t 1.4] [package versions t]
+ }
+} -cleanup {
+ interp delete child
} -result {t {script for t 1.4} 1.4}
test package-4.11 {Tcl_PackageCmd procedure, "ifneeded" option} -setup {
- package forget t
+ interp create child
+ child eval {
+ package forget {*}[package names]
+ }
} -body {
+ child eval {
package ifneeded t 1.4 "script for t 1.4"
list [package ifneeded t 1.5] [package names] [package versions t]
+ }
+} -cleanup {
+ interp delete child
} -result {{} t 1.4}
test package-4.12 {Tcl_PackageCmd procedure, "ifneeded" option} -setup {
- package forget t
+ interp create child
+ child eval {
+ package forget {*}[package names]
+ }
} -body {
+ child eval {
package ifneeded t 1.4 "script for t 1.4"
package ifneeded t 1.4 "second script for t 1.4"
list [package ifneeded t 1.4] [package names] [package versions t]
+ }
+} -cleanup {
+ interp delete child
} -result {{second script for t 1.4} t 1.4}
test package-4.13 {Tcl_PackageCmd procedure, "ifneeded" option} -setup {
package forget t
} -body {
package ifneeded t 1.4 "script for t 1.4"
@@ -688,22 +762,35 @@
list [package ifneeded t 1.2] [package versions t]
} -result {{second script} {1.4 1.2 3.1}}
test package-4.14 {Tcl_PackageCmd procedure, "names" option} -body {
package names a
} -returnCodes error -result {wrong # args: should be "package names"}
-test package-4.15 {Tcl_PackageCmd procedure, "names" option} {
+test package-4.15 {Tcl_PackageCmd procedure, "names" option} -setup {
+ interp create child
+} -body {
+ child eval {
package forget {*}[package names]
package names
-} {}
+ }
+} -cleanup {
+ interp delete child
+} -result {}
test package-4.16 {Tcl_PackageCmd procedure, "names" option} -setup {
+ interp create child
+ child eval {
package forget {*}[package names]
+ }
} -body {
+ child eval {
package ifneeded x 1.2 {dummy}
package provide x 1.3
package provide y 2.4
catch {package require z 47.16}
lsort [package names]
+ }
+} -cleanup {
+ interp delete child
} -result {x y}
test package-4.17 {Tcl_PackageCmd procedure, "provide" option} -body {
package provide
} -returnCodes error -result {wrong # args: should be "package provide package ?version?"}
test package-4.18 {Tcl_PackageCmd procedure, "provide" option} -body {
@@ -1237,15 +1324,13 @@
} finally {
interp delete $ip
}
}
-test package-13.0 {package prefer defaults} -constraints testpreferstable -setup {
- testpreferstable
-} -body {
+test package-13.0 {package prefer defaults} -body {
prefer
-} -result stable
+} -result [expr {[string match {*[ab]*} [package provide Tcl]] ? "latest" : "stable"}]
test package-13.1 {package prefer defaults} -body {
set ::env(TCL_PKG_PREFER_LATEST) stable ;# value not relevant!
prefer
} -cleanup {
unset -nocomplain ::env(TCL_PKG_PREFER_LATEST)
@@ -1258,27 +1343,29 @@
package prefer foo
} -result {bad preference "foo": must be latest or stable}
test package-15.0 {set, keep} -constraints testpreferstable -setup {
testpreferstable
-} -body {package prefer stable} -result stable
+} -body {package prefer} -result stable
test package-15.1 {set stable, keep} -constraints testpreferstable -setup {
testpreferstable
-} -body {prefer stable} -result {stable stable}
+} -body {package prefer stable} -result stable
test package-15.2 {set latest, change} -constraints testpreferstable -setup {
testpreferstable
-} -body {prefer latest} -result {stable latest}
+} -body {package prefer latest} -result latest
test package-15.3 {set latest, keep} -constraints testpreferstable -setup {
testpreferstable
} -body {
- prefer latest latest
-} -result {stable latest latest}
+ package prefer latest
+ package prefer latest
+} -result latest
test package-15.4 {set stable, rejected} -constraints testpreferstable -setup {
testpreferstable
} -body {
- prefer latest stable
-} -result {stable latest latest}
+ package prefer latest
+ package prefer stable
+} -result latest
rename prefer {}
set auto_path $oldPath
package unknown $oldPkgUnknown
Index: tests/safe.test
==================================================================
--- tests/safe.test
+++ tests/safe.test
@@ -72,11 +72,11 @@
} -body {
interp create a -safe
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}
interp create a -safe
} -body {
Index: tests/split.test
==================================================================
--- tests/split.test
+++ tests/split.test
@@ -68,10 +68,13 @@
split "12,34,56," {,}
} {12 34 56 {}}
test split-1.14 {basic split commands} {
split ",12,,,34,56," {,}
} {{} 12 {} {} 34 56 {}}
+test split-1.15 {basic split commands} -body {
+ split "a\U01f4a9b" {}
+} -result "a \U01f4a9 b"
test split-2.1 {split errors} {
list [catch split msg] $msg $errorCode
} {1 {wrong # args: should be "split string ?splitChars?"} {TCL WRONGARGS}}
test split-2.2 {split errors} {
Index: tests/string.test
==================================================================
--- tests/string.test
+++ tests/string.test
@@ -26,10 +26,15 @@
testConstraint testindexobj [expr {[info commands testindexobj] != {}}]
# Used for constraining memory leak tests
testConstraint memory [llength [info commands memory]]
+proc representationpoke s {
+ set r [::tcl::unsupported::representation $s]
+ list [lindex $r 3] [string match {*, string representation "*"} $r]
+}
+
test string-1.1 {error conditions} {
list [catch {string gorp a b} msg] $msg
} {1 {unknown or ambiguous subcommand "gorp": must be bytelength, cat, compare, equal, first, index, is, last, length, map, match, range, repeat, replace, reverse, tolower, totitle, toupper, trim, trimleft, trimright, wordend, or wordstart}}
test string-1.2 {error conditions} {
list [catch {string} msg] $msg
@@ -222,10 +227,17 @@
# strings was incorrect, leading to an index returned by [string first]
# which pointed past the end of the string.
set uchar \u057e ;# character with two-byte encoding in utf-8
string first % %#$uchar$uchar#$uchar$uchar#% 3
} 8
+test string-4.16 {string first, normal string vs pure unicode string} {
+ set s hello
+ regexp ll $s m
+ # Representation checks are canaries
+ list [representationpoke $s] [representationpoke $m] \
+ [string first $m $s]
+} {{string 1} {string 0} 2}
test string-5.1 {string index} {
list [catch {string index} msg] $msg
} {1 {wrong # args: should be "string index string charIndex"}}
test string-5.2 {string index} {
@@ -1683,44 +1695,44 @@
set x abc
set y de
string reverse $x$y
} edcba
test string-24.5 {string reverse command - shared unicode string} {
- set x abcde\udead
+ set x abcde\ud0ad
string reverse $x
-} \udeadedcba
+} \ud0adedcba
test string-24.6 {string reverse command - unshared string} {
set x abc
- set y de\udead
+ set y de\ud0ad
string reverse $x$y
-} \udeadedcba
+} \ud0adedcba
test string-24.7 {string reverse command - simple case} {
string reverse a
} a
test string-24.8 {string reverse command - simple case} {
- string reverse \udead
-} \udead
+ string reverse \ud0ad
+} \ud0ad
test string-24.9 {string reverse command - simple case} {
string reverse {}
} {}
test string-24.10 {string reverse command - corner case} {
- set x \ubeef\udead
+ set x \ubeef\ud0ad
string reverse $x
-} \udead\ubeef
+} \ud0ad\ubeef
test string-24.11 {string reverse command - corner case} {
set x \ubeef
- set y \udead
+ set y \ud0ad
string reverse $x$y
-} \udead\ubeef
+} \ud0ad\ubeef
test string-24.12 {string reverse command - corner case} {
set x \ubeef
- set y \udead
+ set y \ud0ad
string is ascii [string reverse $x$y]
} 0
test string-24.13 {string reverse command - pure Unicode string} {
- string reverse [string range \ubeef\udead\ubeef\udead\ubeef\udead 1 5]
-} \udead\ubeef\udead\ubeef\udead
+ string reverse [string range \ubeef\ud0ad\ubeef\ud0ad\ubeef\ud0ad 1 5]
+} \ud0ad\ubeef\ud0ad\ubeef\ud0ad
test string-24.14 {string reverse command - pure bytearray} {
binary scan [string reverse [binary format H* 010203]] H* x
set x
} 030201
test string-24.15 {string reverse command - pure bytearray} {
@@ -2040,17 +2052,15 @@
} -cleanup {
unset e f
} -body {
tcl::unsupported::representation [string cat $e $f $e $f [list x]]
} -match glob -result {*no string representation}
-
-
-
+
# cleanup
rename MemStress {}
catch {rename foo {}}
::tcltest::cleanupTests
return
# Local Variables:
# mode: tcl
# End:
Index: tests/stringObj.test
==================================================================
--- tests/stringObj.test
+++ tests/stringObj.test
@@ -478,14 +478,17 @@
} fooo
test stringObj-15.8 {Tcl_Append*ToObj: self appends} testobj {
teststringobj set 1 foo
teststringobj appendself2 1 3
} foo
-
if {[testConstraint testobj]} {
testobj freeallvars
}
# cleanup
::tcltest::cleanupTests
return
+
+# Local Variables:
+# mode: tcl
+# End:
Index: tests/utf.test
==================================================================
--- tests/utf.test
+++ tests/utf.test
@@ -66,14 +66,14 @@
test utf-2.7 {Tcl_UtfToUniChar: lead (3-byte) followed by 2 trail} testbytestring {
string length [testbytestring "\xE4\xb9\x8e"]
} {1}
test utf-2.8 {Tcl_UtfToUniChar: lead (4-byte) followed by 3 trail} -constraints {fullutf testbytestring} -body {
string length [testbytestring "\xF0\x90\x80\x80"]
-} -result {1}
+} -result {2}
test utf-2.9 {Tcl_UtfToUniChar: lead (4-byte) followed by 3 trail} -constraints {fullutf testbytestring} -body {
string length [testbytestring "\xF4\x8F\xBF\xBF"]
-} -result {1}
+} -result {2}
test utf-2.10 {Tcl_UtfToUniChar: lead (4-byte) followed by 3 trail, underflow} testbytestring {
string length [testbytestring "\xF0\x8F\xBF\xBF"]
} {4}
test utf-2.11 {Tcl_UtfToUniChar: lead (4-byte) followed by 3 trail, overflow} testbytestring {
string length [testbytestring "\xF4\x90\x80\x80"]
Index: unix/Makefile.in
==================================================================
--- unix/Makefile.in
+++ unix/Makefile.in
@@ -855,12 +855,12 @@
do \
$(INSTALL_DATA) $$i "$(SCRIPT_INSTALL_DIR)"/opt0.4; \
done;
@echo "Installing package msgcat 1.6.1 as a Tcl Module";
@$(INSTALL_DATA) $(TOP_DIR)/library/msgcat/msgcat.tcl "$(SCRIPT_INSTALL_DIR)"/../tcl8/8.5/msgcat-1.6.1.tm;
- @echo "Installing package tcltest 2.4.0 as a Tcl Module";
- @$(INSTALL_DATA) $(TOP_DIR)/library/tcltest/tcltest.tcl "$(SCRIPT_INSTALL_DIR)"/../tcl8/8.5/tcltest-2.4.0.tm;
+ @echo "Installing package tcltest 2.4.1 as a Tcl Module";
+ @$(INSTALL_DATA) $(TOP_DIR)/library/tcltest/tcltest.tcl "$(SCRIPT_INSTALL_DIR)"/../tcl8/8.5/tcltest-2.4.1.tm;
@echo "Installing package platform 1.0.14 as a Tcl Module";
@$(INSTALL_DATA) $(TOP_DIR)/library/platform/platform.tcl "$(SCRIPT_INSTALL_DIR)"/../tcl8/8.4/platform-1.0.14.tm;
@echo "Installing package platform::shell 1.1.4 as a Tcl Module";
@$(INSTALL_DATA) $(TOP_DIR)/library/platform/shell.tcl "$(SCRIPT_INSTALL_DIR)"/../tcl8/8.4/platform/shell-1.1.4.tm;
Index: unix/configure
==================================================================
--- unix/configure
+++ unix/configure
@@ -3730,30 +3730,10 @@
if test $tcl_cv_dirent_h = no; then
$as_echo "#define NO_DIRENT_H 1" >>confdefs.h
fi
-
- ac_fn_c_check_header_mongrel "$LINENO" "float.h" "ac_cv_header_float_h" "$ac_includes_default"
-if test "x$ac_cv_header_float_h" = xyes; then :
-
-else
-
-$as_echo "#define NO_FLOAT_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
else
Index: unix/tcl.m4
==================================================================
--- unix/tcl.m4
+++ unix/tcl.m4
@@ -2038,11 +2038,10 @@
#
# Results:
#
# Defines some of the following vars:
# NO_DIRENT_H
-# NO_VALUES_H
# NO_STDLIB_H
# NO_STRING_H
# NO_SYS_WAIT_H
# NO_DLFCN_H
# HAVE_SYS_PARAM_H
@@ -2076,12 +2075,10 @@
if test $tcl_cv_dirent_h = no; then
AC_DEFINE(NO_DIRENT_H, 1, [Do we have ?])
fi
- AC_CHECK_HEADER(float.h, , [AC_DEFINE(NO_FLOAT_H, 1, [Do we have ?])])
- AC_CHECK_HEADER(values.h, , [AC_DEFINE(NO_VALUES_H, 1, [Do we have ?])])
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)
AC_EGREP_HEADER(strtod, stdlib.h, , tcl_ok=0)
if test $tcl_ok = 0; then
Index: unix/tclConfig.h.in
==================================================================
--- unix/tclConfig.h.in
+++ unix/tclConfig.h.in
@@ -293,13 +293,10 @@
#undef NO_DLFCN_H
/* Do we have fd_set? */
#undef NO_FD_SET
-/* Do we have ? */
-#undef NO_FLOAT_H
-
/* Do we have fstatfs()? */
#undef NO_FSTATFS
/* Do we have gettimeofday()? */
#undef NO_GETTOD
@@ -332,13 +329,10 @@
#undef NO_UNAME
/* Do we have a usable 'union wait'? */
#undef NO_UNION_WAIT
-/* Do we have ? */
-#undef NO_VALUES_H
-
/* Do we have wait3() */
#undef NO_WAIT3
/* Define to the address where bug reports for this package should be sent. */
#undef PACKAGE_BUGREPORT
Index: unix/tclUnixPipe.c
==================================================================
--- unix/tclUnixPipe.c
+++ unix/tclUnixPipe.c
@@ -402,10 +402,45 @@
* from the child will be discarded. errorFile
* may be the same as outputFile. */
Tcl_Pid *pidPtr) /* If this function is successful, pidPtr is
* filled with the process id of the child
* process. */
+{
+ return TclpCreateProcessPwd(interp, argc, argv, inputFile, outputFile,
+ errorFile, NULL, pidPtr);
+}
+
+int
+TclpCreateProcessPwd(
+ Tcl_Interp *interp, /* Interpreter in which to leave errors that
+ * occurred when creating the child process.
+ * Error messages from the child process
+ * itself are sent to errorFile. */
+ int argc, /* Number of arguments in following array. */
+ const char **argv, /* Array of argument strings in UTF-8.
+ * argv[0] contains the name of the executable
+ * translated using Tcl_TranslateFileName
+ * call). Additional arguments have not been
+ * converted. */
+ TclFile inputFile, /* If non-NULL, gives the file to use as input
+ * for the child process. If inputFile file is
+ * not readable or is NULL, the child will
+ * receive no standard input. */
+ TclFile outputFile, /* If non-NULL, gives the file that receives
+ * output from the child process. If
+ * outputFile file is not writeable or is
+ * NULL, output from the child will be
+ * discarded. */
+ TclFile errorFile, /* If non-NULL, gives the file that receives
+ * errors from the child process. If errorFile
+ * file is not writeable or is NULL, errors
+ * from the child will be discarded. errorFile
+ * may be the same as outputFile. */
+ Tcl_Obj *pwdPtr,
+ Tcl_Pid *pidPtr) /* If this function is successful, pidPtr is
+ * filled with the process id of the child
+ * process. */
{
TclFile errPipeIn, errPipeOut;
int count, status, fd;
char errSpace[200 + TCL_INTEGER_SPACE];
Tcl_DString *dsArray;
@@ -464,10 +499,20 @@
size_t len;
int joinThisError = errorFile && (errorFile == outputFile);
fd = GetFd(errPipeOut);
+ if (pwdPtr != NULL) {
+ int result = Tcl_FSChdir(pwdPtr);
+ if (result != TCL_OK) {
+ sprintf(errSpace,
+ "couldn't change working directory to \"%s\": %s",
+ TclGetString(pwdPtr), Tcl_PosixError(interp));
+ write(fd, errSpace, (size_t) strlen(errSpace));
+ _exit(1);
+ }
+ }
/*
* Set up stdio file handles for the child process.
*/
if (!SetupStdFile(inputFile, TCL_STDIN)
Index: unix/tclUnixPort.h
==================================================================
--- unix/tclUnixPort.h
+++ unix/tclUnixPort.h
@@ -179,17 +179,11 @@
* for an alternative definition. If no other alternative is available we use
* a reasonable guess.
*---------------------------------------------------------------------------
*/
-#ifndef NO_FLOAT_H
-# include
-#else
-#ifndef NO_VALUES_H
-# include
-#endif
-#endif
+#include
#ifndef FLT_MAX
# ifdef MAXFLOAT
# define FLT_MAX MAXFLOAT
# else
Index: unix/tclUnixThrd.c
==================================================================
--- unix/tclUnixThrd.c
+++ unix/tclUnixThrd.c
@@ -13,15 +13,17 @@
#include "tclInt.h"
#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,
* and thread local storage. This is the only place that can count on the
* ability to statically initialize the mutex.
Index: win/tcl.dsp
==================================================================
--- win/tcl.dsp
+++ win/tcl.dsp
@@ -148,14 +148,10 @@
# End Source File
# Begin Source File
SOURCE=..\compat\fixstrtod.c
# End Source File
-# Begin Source File
-
-SOURCE=..\compat\float.h
-# End Source File
# Begin Source File
SOURCE=..\compat\gettod.c
# End Source File
# Begin Source File
Index: win/tcl.hpj.in
==================================================================
--- win/tcl.hpj.in
+++ win/tcl.hpj.in
@@ -3,17 +3,17 @@
[OPTIONS]
HCW=0
LCID=0x409 0x0 0x0 ;English (United States)
REPORT=Yes
TITLE=Tcl/Tk Reference Manual
-CNT=tcl86.cnt
+CNT=tcl87.cnt
COPYRIGHT=Copyright © 2000 Ajuba Solutions
-HLP=tcl86.hlp
+HLP=tcl87.hlp
[FILES]
tcl.rtf
[WINDOWS]
main="Tcl/Tk Reference Manual",,0
[CONFIG]
BrowseButtons()
Index: win/tclWinError.c
==================================================================
--- win/tclWinError.c
+++ win/tclWinError.c
@@ -28,11 +28,11 @@
ENOMEM, /* ERROR_INVALID_BLOCK 9 */
E2BIG, /* ERROR_BAD_ENVIRONMENT 10 */
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 */
ENOENT, /* ERROR_NO_MORE_FILES 18 */
EROFS, /* ERROR_WRITE_PROTECT 19 */
Index: win/tclWinPipe.c
==================================================================
--- win/tclWinPipe.c
+++ win/tclWinPipe.c
@@ -932,18 +932,54 @@
* from the child will be discarded. errorFile
* may be the same as outputFile. */
Tcl_Pid *pidPtr) /* If this function is successful, pidPtr is
* filled with the process id of the child
* process. */
+{
+ return TclpCreateProcessPwd(interp, argc, argv, inputFile, outputFile,
+ errorFile, NULL, pidPtr);
+}
+
+int
+TclpCreateProcessPwd(
+ Tcl_Interp *interp, /* Interpreter in which to leave errors that
+ * occurred when creating the child process.
+ * Error messages from the child process
+ * itself are sent to errorFile. */
+ int argc, /* Number of arguments in following array. */
+ const char **argv, /* Array of argument strings. argv[0] contains
+ * the name of the executable converted to
+ * native format (using the
+ * Tcl_TranslateFileName call). Additional
+ * arguments have not been converted. */
+ TclFile inputFile, /* If non-NULL, gives the file to use as input
+ * for the child process. If inputFile file is
+ * not readable or is NULL, the child will
+ * receive no standard input. */
+ TclFile outputFile, /* If non-NULL, gives the file that receives
+ * output from the child process. If
+ * outputFile file is not writeable or is
+ * NULL, output from the child will be
+ * discarded. */
+ TclFile errorFile, /* If non-NULL, gives the file that receives
+ * errors from the child process. If errorFile
+ * file is not writeable or is NULL, errors
+ * from the child will be discarded. errorFile
+ * may be the same as outputFile. */
+ Tcl_Obj *pwdPtr,
+ Tcl_Pid *pidPtr) /* If this function is successful, pidPtr is
+ * filled with the process id of the child
+ * process. */
{
int result, applType, createFlags;
Tcl_DString cmdLine; /* Complete command line (TCHAR). */
STARTUPINFO startInfo;
PROCESS_INFORMATION procInfo;
SECURITY_ATTRIBUTES secAtts;
HANDLE hProcess, h, inputHandle, outputHandle, errorHandle;
char execPath[MAX_PATH * TCL_UTF_MAX];
+ char *pwdStr = NULL;
WinFile *filePtr;
PipeInit();
applType = ApplicationType(interp, argv[0], execPath);
@@ -1128,10 +1164,14 @@
Tcl_SetErrorCode(interp, "TCL", "OPERATION", "EXEC", "DOS_APP",
NULL);
goto end;
}
}
+
+ if (pwdPtr != NULL) {
+ pwdStr = Tcl_GetString(pwdPtr);
+ }
/*
* cmdLine gets the full command line used to invoke the executable,
* including the name of the executable itself. The command line arguments
* in argv[] are stored in cmdLine separated by spaces. Special characters
@@ -1150,12 +1190,12 @@
*/
BuildCommandLine(execPath, argc, argv, &cmdLine);
if (CreateProcess(NULL, (TCHAR *) Tcl_DStringValue(&cmdLine),
- NULL, NULL, TRUE, (DWORD) createFlags, NULL, NULL, &startInfo,
- &procInfo) == 0) {
+ (DWORD) createFlags, NULL, (TCHAR *) pwdStr, &startInfo,
+ &procInfo) == 0) {
TclWinConvertError(GetLastError());
Tcl_SetObjResult(interp, Tcl_ObjPrintf("couldn't execute \"%s\": %s",
argv[0], Tcl_PosixError(interp)));
goto end;
}
Index: win/tclWinThrd.c
==================================================================
--- win/tclWinThrd.c
+++ win/tclWinThrd.c
@@ -11,12 +11,10 @@
* this file, and for a DISCLAIMER OF ALL WARRANTIES.
*/
#include "tclWinInt.h"
-#include
-
/* Workaround for mingw versions which don't provide this in float.h */
#ifndef _MCW_EM
# define _MCW_EM 0x0008001F /* Error masks */
# define _MCW_RC 0x00000300 /* Rounding */
# define _MCW_PC 0x00030000 /* Precision */