summaryrefslogtreecommitdiffstats
path: root/generic
diff options
context:
space:
mode:
authordkf <donal.k.fellows@manchester.ac.uk>2012-08-04 07:47:22 (GMT)
committerdkf <donal.k.fellows@manchester.ac.uk>2012-08-04 07:47:22 (GMT)
commita8d394eeafa043ca1cfc2daa1ba0d5f15a59b802 (patch)
treefd7b6368f954a4c1a95289f5dc388a409605c11c /generic
parent2fffc3d3e95c03bbba314e2edb43007273079c16 (diff)
parent1121067971e449803e3964d69958d35e2187af2a (diff)
downloadtcl-a8d394eeafa043ca1cfc2daa1ba0d5f15a59b802.zip
tcl-a8d394eeafa043ca1cfc2daa1ba0d5f15a59b802.tar.gz
tcl-a8d394eeafa043ca1cfc2daa1ba0d5f15a59b802.tar.bz2
merge trunk
Diffstat (limited to 'generic')
-rw-r--r--generic/regc_locale.c2
-rw-r--r--generic/tcl.decls12
-rw-r--r--generic/tclAssembly.c8
-rw-r--r--generic/tclBasic.c161
-rw-r--r--generic/tclBinary.c24
-rw-r--r--generic/tclCkalloc.c53
-rw-r--r--generic/tclClock.c12
-rw-r--r--generic/tclCmdAH.c112
-rw-r--r--generic/tclCmdIL.c251
-rw-r--r--generic/tclCmdMZ.c102
-rw-r--r--generic/tclCompCmds.c4
-rw-r--r--generic/tclCompCmdsSZ.c3
-rw-r--r--generic/tclCompExpr.c2
-rw-r--r--generic/tclCompile.c19
-rw-r--r--generic/tclCompile.h13
-rw-r--r--generic/tclConfig.c12
-rw-r--r--generic/tclDecls.h6
-rw-r--r--generic/tclDictObj.c39
-rw-r--r--generic/tclEncoding.c10
-rw-r--r--generic/tclEnsemble.c183
-rw-r--r--generic/tclEnv.c5
-rw-r--r--generic/tclEvent.c9
-rw-r--r--generic/tclExecute.c38
-rw-r--r--generic/tclFCmd.c139
-rw-r--r--generic/tclFileName.c131
-rw-r--r--generic/tclFileSystem.h55
-rw-r--r--generic/tclIO.c61
-rw-r--r--generic/tclIO.h7
-rw-r--r--generic/tclIOCmd.c4
-rw-r--r--generic/tclIORChan.c191
-rw-r--r--generic/tclIORTrans.c12
-rw-r--r--generic/tclIOSock.c47
-rw-r--r--generic/tclIOUtil.c239
-rw-r--r--generic/tclIndexObj.c112
-rw-r--r--generic/tclInt.decls114
-rw-r--r--generic/tclInt.h20
-rw-r--r--generic/tclIntPlatDecls.h353
-rw-r--r--generic/tclInterp.c109
-rw-r--r--generic/tclLoad.c97
-rw-r--r--generic/tclLoadNone.c4
-rw-r--r--generic/tclMain.c23
-rw-r--r--generic/tclNamesp.c81
-rw-r--r--generic/tclOO.c150
-rw-r--r--generic/tclOOBasic.c240
-rw-r--r--generic/tclOODefineCmds.c239
-rw-r--r--generic/tclOOInfo.c64
-rw-r--r--generic/tclOOInt.h9
-rw-r--r--generic/tclOOMethod.c17
-rw-r--r--generic/tclOOStubLib.c11
-rw-r--r--generic/tclObj.c42
-rw-r--r--generic/tclPanic.c15
-rw-r--r--generic/tclParse.c33
-rw-r--r--generic/tclPathObj.c176
-rw-r--r--generic/tclPipe.c103
-rw-r--r--generic/tclPkg.c114
-rw-r--r--generic/tclPlatDecls.h30
-rw-r--r--generic/tclPort.h13
-rw-r--r--generic/tclProc.c101
-rw-r--r--generic/tclRegexp.c8
-rw-r--r--generic/tclResult.c43
-rw-r--r--generic/tclScan.c55
-rwxr-xr-xgeneric/tclStrToD.c3
-rw-r--r--generic/tclStubInit.c204
-rw-r--r--generic/tclTest.c121
-rw-r--r--generic/tclTimer.c18
-rw-r--r--generic/tclTomMathStubLib.c8
-rw-r--r--generic/tclTrace.c48
-rw-r--r--generic/tclUniData.c2
-rw-r--r--generic/tclUtil.c139
-rw-r--r--generic/tclVar.c73
-rw-r--r--generic/tclZlib.c599
71 files changed, 3112 insertions, 2445 deletions
diff --git a/generic/regc_locale.c b/generic/regc_locale.c
index 188d6de..40791f4 100644
--- a/generic/regc_locale.c
+++ b/generic/regc_locale.c
@@ -617,7 +617,7 @@ static const crange graphRangeTable[] = {
{0x1f48, 0x1f4d}, {0x1f50, 0x1f57}, {0x1f5f, 0x1f7d}, {0x1f80, 0x1fb4},
{0x1fb6, 0x1fc4}, {0x1fc6, 0x1fd3}, {0x1fd6, 0x1fdb}, {0x1fdd, 0x1fef},
{0x1ff2, 0x1ff4}, {0x1ff6, 0x1ffe}, {0x2010, 0x2027}, {0x2030, 0x205e},
- {0x2074, 0x208e}, {0x2090, 0x209c}, {0x20a0, 0x20b9}, {0x20d0, 0x20f0},
+ {0x2074, 0x208e}, {0x2090, 0x209c}, {0x20a0, 0x20ba}, {0x20d0, 0x20f0},
{0x2100, 0x2189}, {0x2190, 0x23f3}, {0x2400, 0x2426}, {0x2440, 0x244a},
{0x2460, 0x26ff}, {0x2701, 0x2b4c}, {0x2b50, 0x2b59}, {0x2c00, 0x2c2e},
{0x2c30, 0x2c5e}, {0x2c60, 0x2cf3}, {0x2cf9, 0x2d25}, {0x2d30, 0x2d67},
diff --git a/generic/tcl.decls b/generic/tcl.decls
index 8355d99..b421ae2 100644
--- a/generic/tcl.decls
+++ b/generic/tcl.decls
@@ -2346,12 +2346,12 @@ declare 1 win {
################################
# Mac OS X specific functions
-declare 0 {unix macosx} {
+declare 0 macosx {
int Tcl_MacOSXOpenBundleResources(Tcl_Interp *interp,
const char *bundleName, int hasResourceFile,
int maxPathLen, char *libraryPath)
}
-declare 1 {unix macosx} {
+declare 1 macosx {
int Tcl_MacOSXOpenVersionedBundleResources(Tcl_Interp *interp,
const char *bundleName, const char *bundleVersion,
int hasResourceFile, int maxPathLen, char *libraryPath)
@@ -2365,6 +2365,14 @@ export {
void Tcl_Main(int argc, char **argv, Tcl_AppInitProc *appInitProc)
}
export {
+ const char *Tcl_InitStubs(Tcl_Interp *interp, const char *version,
+ int exact)
+}
+export {
+ const char *TclTomMathInitializeStubs(Tcl_Interp* interp,
+ const char* version, int epoch, int revision)
+}
+export {
const char *Tcl_PkgInitStubsCheck(Tcl_Interp *interp, const char *version,
int exact)
}
diff --git a/generic/tclAssembly.c b/generic/tclAssembly.c
index 7bfaac1..a266350 100644
--- a/generic/tclAssembly.c
+++ b/generic/tclAssembly.c
@@ -265,7 +265,7 @@ static int CheckStrictlyPositive(Tcl_Interp*, int);
static ByteCode * CompileAssembleObj(Tcl_Interp *interp,
Tcl_Obj *objPtr);
static void CompileEmbeddedScript(AssemblyEnv*, Tcl_Token*,
- TalInstDesc*);
+ const TalInstDesc*);
static int DefineLabel(AssemblyEnv* envPtr, const char* label);
static void DeleteMirrorJumpTable(JumptableInfo* jtPtr);
static void DupAssembleCodeInternalRep(Tcl_Obj* src,
@@ -350,7 +350,7 @@ static const Tcl_ObjType assembleCodeType = {
* Source instructions recognized in the Tcl Assembly Language (TAL)
*/
-TalInstDesc TalInstructionTable[] = {
+static const TalInstDesc TalInstructionTable[] = {
/* PUSH must be first, see the code near the end of TclAssembleCode */
{"push", ASSEM_PUSH, (INST_PUSH1<<8
| INST_PUSH4), 0, 1},
@@ -496,7 +496,7 @@ TalInstDesc TalInstructionTable[] = {
* The instructions must be in ascending order by numeric operation code.
*/
-static unsigned char NonThrowingByteCodes[] = {
+static const unsigned char NonThrowingByteCodes[] = {
INST_PUSH1, INST_PUSH4, INST_POP, INST_DUP, /* 1-4 */
INST_JUMP1, INST_JUMP4, /* 34-35 */
INST_END_CATCH, INST_PUSH_RESULT, INST_PUSH_RETURN_CODE, /* 70-72 */
@@ -1775,7 +1775,7 @@ static void
CompileEmbeddedScript(
AssemblyEnv* assemEnvPtr, /* Assembly environment */
Tcl_Token* tokenPtr, /* Tcl_Token containing the script */
- TalInstDesc* instPtr) /* Instruction that determines whether
+ const TalInstDesc* instPtr) /* Instruction that determines whether
* the script is 'expr' or 'eval' */
{
CompileEnv* envPtr = assemEnvPtr->envPtr;
diff --git a/generic/tclBasic.c b/generic/tclBasic.c
index e09ea1e..db365e3 100644
--- a/generic/tclBasic.c
+++ b/generic/tclBasic.c
@@ -81,8 +81,6 @@ TCL_DECLARE_MUTEX(cancelLock)
* are used to save the evaluation state between NR calls to each coro.
*/
-static const CorContext NULL_CONTEXT = {NULL, NULL, NULL, NULL};
-
#define SAVE_CONTEXT(context) \
(context).framePtr = iPtr->framePtr; \
(context).varFramePtr = iPtr->varFramePtr; \
@@ -136,6 +134,8 @@ static void MathFuncWrongNumArgs(Tcl_Interp *interp, int expected,
static Tcl_NRPostProc NRCoroutineActivateCallback;
static Tcl_NRPostProc NRCoroutineCallerCallback;
static Tcl_NRPostProc NRCoroutineExitCallback;
+static int NRCommand(ClientData data[], Tcl_Interp *interp, int result);
+
static Tcl_NRPostProc NRRunObjProc;
static Tcl_NRPostProc NRTailcallEval;
static Tcl_ObjCmdProc OldMathFuncProc;
@@ -1557,12 +1557,16 @@ DeleteInterpProc(
hPtr != NULL;
hPtr = Tcl_NextHashEntry(&search)) {
CmdFrame *cfPtr = Tcl_GetHashValue(hPtr);
+ Proc *procPtr = (Proc *) Tcl_GetHashKey(iPtr->linePBodyPtr, hPtr);
- if (cfPtr->type == TCL_LOCATION_SOURCE) {
- Tcl_DecrRefCount(cfPtr->data.eval.path);
+ procPtr->iPtr = NULL;
+ if (cfPtr) {
+ if (cfPtr->type == TCL_LOCATION_SOURCE) {
+ Tcl_DecrRefCount(cfPtr->data.eval.path);
+ }
+ ckfree(cfPtr->line);
+ ckfree(cfPtr);
}
- ckfree(cfPtr->line);
- ckfree(cfPtr);
Tcl_DeleteHashEntry(hPtr);
}
Tcl_DeleteHashTable(iPtr->linePBodyPtr);
@@ -1704,9 +1708,9 @@ Tcl_HideCommand(
*/
if (strstr(hiddenCmdToken, "::") != NULL) {
- Tcl_AppendResult(interp,
+ Tcl_SetObjResult(interp, Tcl_NewStringObj(
"cannot use namespace qualifiers in hidden command"
- " token (rename)", NULL);
+ " token (rename)", -1));
Tcl_SetErrorCode(interp, "TCL", "VALUE", "HIDDENTOKEN", NULL);
return TCL_ERROR;
}
@@ -1729,8 +1733,9 @@ Tcl_HideCommand(
*/
if (cmdPtr->nsPtr != iPtr->globalNsPtr) {
- Tcl_AppendResult(interp, "can only hide global namespace commands"
- " (use rename then hide)", NULL);
+ Tcl_SetObjResult(interp, Tcl_NewStringObj(
+ "can only hide global namespace commands (use rename then hide)",
+ -1));
Tcl_SetErrorCode(interp, "TCL", "HIDE", "NON_GLOBAL", NULL);
return TCL_ERROR;
}
@@ -1754,8 +1759,9 @@ Tcl_HideCommand(
hPtr = Tcl_CreateHashEntry(hiddenCmdTablePtr, hiddenCmdToken, &isNew);
if (!isNew) {
- Tcl_AppendResult(interp, "hidden command named \"", hiddenCmdToken,
- "\" already exists", NULL);
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "hidden command named \"%s\" already exists",
+ hiddenCmdToken));
Tcl_SetErrorCode(interp, "TCL", "HIDE", "ALREADY_HIDDEN", NULL);
return TCL_ERROR;
}
@@ -1857,8 +1863,9 @@ Tcl_ExposeCommand(
*/
if (strstr(cmdName, "::") != NULL) {
- Tcl_AppendResult(interp, "cannot expose to a namespace "
- "(use expose to toplevel, then rename)", NULL);
+ Tcl_SetObjResult(interp, Tcl_NewStringObj(
+ "cannot expose to a namespace (use expose to toplevel, then rename)",
+ -1));
Tcl_SetErrorCode(interp, "TCL", "EXPOSE", "NON_GLOBAL", NULL);
return TCL_ERROR;
}
@@ -1873,8 +1880,8 @@ Tcl_ExposeCommand(
hPtr = Tcl_FindHashEntry(hiddenCmdTablePtr, hiddenCmdToken);
}
if (hPtr == NULL) {
- Tcl_AppendResult(interp, "unknown hidden command \"", hiddenCmdToken,
- "\"", NULL);
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "unknown hidden command \"%s\"", hiddenCmdToken));
Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "HIDDENTOKEN",
hiddenCmdToken, NULL);
return TCL_ERROR;
@@ -1893,9 +1900,9 @@ Tcl_ExposeCommand(
* than 'nicely' erroring out ?
*/
- Tcl_AppendResult(interp,
+ Tcl_SetObjResult(interp, Tcl_NewStringObj(
"trying to expose a non-global command namespace command",
- NULL);
+ -1));
return TCL_ERROR;
}
@@ -1912,8 +1919,8 @@ Tcl_ExposeCommand(
hPtr = Tcl_CreateHashEntry(&nsPtr->cmdTable, cmdName, &isNew);
if (!isNew) {
- Tcl_AppendResult(interp, "exposed command \"", cmdName,
- "\" already exists", NULL);
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "exposed command \"%s\" already exists", cmdName));
Tcl_SetErrorCode(interp, "TCL", "EXPOSE", "COMMAND_EXISTS", NULL);
return TCL_ERROR;
}
@@ -2493,9 +2500,10 @@ TclRenameCommand(
cmd = Tcl_FindCommand(interp, oldName, NULL, /*flags*/ 0);
cmdPtr = (Command *) cmd;
if (cmdPtr == NULL) {
- Tcl_AppendResult(interp, "can't ",
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "can't %s \"%s\": command doesn't exist",
((newName == NULL)||(*newName == '\0'))? "delete":"rename",
- " \"", oldName, "\": command doesn't exist", NULL);
+ oldName));
Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "COMMAND", oldName, NULL);
return TCL_ERROR;
}
@@ -2525,15 +2533,15 @@ TclRenameCommand(
TCL_CREATE_NS_IF_UNKNOWN, &newNsPtr, &dummy1, &dummy2, &newTail);
if ((newNsPtr == NULL) || (newTail == NULL)) {
- Tcl_AppendResult(interp, "can't rename to \"", newName,
- "\": bad command name", NULL);
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "can't rename to \"%s\": bad command name", newName));
Tcl_SetErrorCode(interp, "TCL", "VALUE", "COMMAND", NULL);
result = TCL_ERROR;
goto done;
}
if (Tcl_FindHashEntry(&newNsPtr->cmdTable, newTail) != NULL) {
- Tcl_AppendResult(interp, "can't rename to \"", newName,
- "\": command already exists", NULL);
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "can't rename to \"%s\": command already exists", newName));
Tcl_SetErrorCode(interp, "TCL", "OPERATION", "RENAME",
"TARGET_EXISTS", NULL);
result = TCL_ERROR;
@@ -2608,7 +2616,7 @@ TclRenameCommand(
Tcl_DStringInit(&newFullName);
Tcl_DStringAppend(&newFullName, newNsPtr->fullName, -1);
if (newNsPtr != iPtr->globalNsPtr) {
- Tcl_DStringAppend(&newFullName, "::", 2);
+ TclDStringAppendLiteral(&newFullName, "::");
}
Tcl_DStringAppend(&newFullName, newTail, -1);
cmdPtr->refCount++;
@@ -3466,7 +3474,7 @@ Tcl_CreateMathFunc(
data->clientData = clientData;
Tcl_DStringInit(&bigName);
- Tcl_DStringAppend(&bigName, "::tcl::mathfunc::", -1);
+ TclDStringAppendLiteral(&bigName, "::tcl::mathfunc::");
Tcl_DStringAppend(&bigName, name, -1);
Tcl_CreateObjCommand(interp, Tcl_DStringValue(&bigName),
@@ -3534,9 +3542,9 @@ OldMathFuncProc(
* We have a non-numeric argument.
*/
- Tcl_SetResult(interp,
+ Tcl_SetObjResult(interp, Tcl_NewStringObj(
"argument to math function didn't have numeric value",
- TCL_STATIC);
+ -1));
TclCheckBadOctal(interp, Tcl_GetString(valuePtr));
ckfree(args);
return TCL_ERROR;
@@ -3823,9 +3831,8 @@ TclInterpReady(
*/
if (iPtr->flags & DELETED) {
- /* JJM - Superfluous Tcl_ResetResult call removed. */
- Tcl_AppendResult(interp,
- "attempt to call eval in deleted interpreter", NULL);
+ Tcl_SetObjResult(interp, Tcl_NewStringObj(
+ "attempt to call eval in deleted interpreter", -1));
Tcl_SetErrorCode(interp, "TCL", "IDELETE",
"attempt to call eval in deleted interpreter", NULL);
return TCL_ERROR;
@@ -3853,8 +3860,8 @@ TclInterpReady(
return TCL_OK;
}
- Tcl_AppendResult(interp,
- "too many nested evaluations (infinite loop?)", NULL);
+ Tcl_SetObjResult(interp, Tcl_NewStringObj(
+ "too many nested evaluations (infinite loop?)", -1));
Tcl_SetErrorCode(interp, "TCL", "LIMIT", "STACK", NULL);
return TCL_ERROR;
}
@@ -3988,8 +3995,7 @@ Tcl_Canceled(
}
}
- Tcl_ResetResult(interp);
- Tcl_AppendResult(interp, message, NULL);
+ Tcl_SetObjResult(interp, Tcl_NewStringObj(message, -1));
Tcl_SetErrorCode(interp, "TCL", "CANCEL", id, message, NULL);
}
@@ -4361,7 +4367,7 @@ TclNRRunCallbacks(
return result;
}
-int
+static int
NRCommand(
ClientData data[],
Tcl_Interp *interp,
@@ -4612,8 +4618,8 @@ TEOV_NotFound(
cmdPtr = TEOV_LookupCmdFromObj(interp, newObjv[0], lookupNsPtr);
if (cmdPtr == NULL) {
- Tcl_AppendResult(interp, "invalid command name \"",
- TclGetString(objv[0]), "\"", NULL);
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "invalid command name \"%s\"", TclGetString(objv[0])));
Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "COMMAND",
TclGetString(objv[0]), NULL);
@@ -6281,11 +6287,11 @@ ProcessUnexpectedResult(
Tcl_ResetResult(interp);
if (returnCode == TCL_BREAK) {
- Tcl_AppendResult(interp,
- "invoked \"break\" outside of a loop", NULL);
+ Tcl_SetObjResult(interp, Tcl_NewStringObj(
+ "invoked \"break\" outside of a loop", -1));
} else if (returnCode == TCL_CONTINUE) {
- Tcl_AppendResult(interp,
- "invoked \"continue\" outside of a loop", NULL);
+ Tcl_SetObjResult(interp, Tcl_NewStringObj(
+ "invoked \"continue\" outside of a loop", -1));
} else {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"command returned bad code: %d", returnCode));
@@ -6620,7 +6626,8 @@ TclObjInvoke(
}
if ((objc < 1) || (objv == NULL)) {
- Tcl_AppendResult(interp, "illegal argument vector", NULL);
+ Tcl_SetObjResult(interp, Tcl_NewStringObj(
+ "illegal argument vector", -1));
return TCL_ERROR;
}
@@ -6638,8 +6645,8 @@ TclObjInvoke(
hPtr = Tcl_FindHashEntry(hTblPtr, cmdName);
}
if (hPtr == NULL) {
- Tcl_AppendResult(interp, "invalid hidden command name \"",
- cmdName, "\"", NULL);
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "invalid hidden command name \"%s\"", cmdName));
Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "HIDDENTOKEN", cmdName,
NULL);
return TCL_ERROR;
@@ -7265,7 +7272,8 @@ ExprIsqrtFunc(
return TCL_OK;
negarg:
- Tcl_SetResult(interp, "square root of negative argument", TCL_STATIC);
+ Tcl_SetObjResult(interp, Tcl_NewStringObj(
+ "square root of negative argument", -1));
Tcl_SetErrorCode(interp, "ARITH", "DOMAIN",
"domain error: argument not in valid range", NULL);
return TCL_ERROR;
@@ -8315,9 +8323,8 @@ TclNRTailcallObjCmd(
}
if (!iPtr->varFramePtr->isProcCallFrame) { /* or is upleveled */
- Tcl_SetResult(interp,
- "tailcall can only be called from a proc or lambda",
- TCL_STATIC);
+ Tcl_SetObjResult(interp, Tcl_NewStringObj(
+ "tailcall can only be called from a proc or lambda", -1));
Tcl_SetErrorCode(interp, "TCL", "TAILCALL", "ILLEGAL", NULL);
return TCL_ERROR;
}
@@ -8476,8 +8483,8 @@ TclNRYieldObjCmd(
}
if (!corPtr) {
- Tcl_SetResult(interp, "yield can only be called in a coroutine",
- TCL_STATIC);
+ Tcl_SetObjResult(interp, Tcl_NewStringObj(
+ "yield can only be called in a coroutine", -1));
Tcl_SetErrorCode(interp, "TCL", "COROUTINE", "ILLEGAL_YIELD", NULL);
return TCL_ERROR;
}
@@ -8510,8 +8517,8 @@ TclNRYieldToObjCmd(
}
if (!corPtr) {
- Tcl_SetResult(interp, "yieldto can only be called in a coroutine",
- TCL_STATIC);
+ Tcl_SetObjResult(interp, Tcl_NewStringObj(
+ "yieldto can only be called in a coroutine", -1));
Tcl_SetErrorCode(interp, "TCL", "COROUTINE", "ILLEGAL_YIELD", NULL);
return TCL_ERROR;
}
@@ -8591,7 +8598,7 @@ RewindCoroutine(
corPtr->eePtr->rewind = 1;
TclNRAddCallback(interp, RewindCoroutineCallback, state,
NULL, NULL, NULL);
- return NRInterpCoroutine(corPtr, interp, 0, NULL);
+ return TclNRInterpCoroutine(corPtr, interp, 0, NULL);
}
static void
@@ -8759,8 +8766,8 @@ NRCoroutineActivateCallback(
*/
if (corPtr->stackLevel != stackLevel) {
- Tcl_SetResult(interp, "cannot yield: C stack busy",
- TCL_STATIC);
+ Tcl_SetObjResult(interp, Tcl_NewStringObj(
+ "cannot yield: C stack busy", -1));
Tcl_SetErrorCode(interp, "TCL", "COROUTINE", "CANT_YIELD",
NULL);
return TCL_ERROR;
@@ -8818,9 +8825,9 @@ NRCoroInjectObjCmd(
}
cmdPtr = (Command *) Tcl_GetCommandFromObj(interp, objv[1]);
- if ((!cmdPtr) || (cmdPtr->nreProc != NRInterpCoroutine)) {
- Tcl_AppendResult(interp, "can only inject a command into a coroutine",
- NULL);
+ if ((!cmdPtr) || (cmdPtr->nreProc != TclNRInterpCoroutine)) {
+ Tcl_SetObjResult(interp, Tcl_NewStringObj(
+ "can only inject a command into a coroutine", -1));
Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "COROUTINE",
TclGetString(objv[1]), NULL);
return TCL_ERROR;
@@ -8828,8 +8835,8 @@ NRCoroInjectObjCmd(
corPtr = cmdPtr->objClientData;
if (!COR_IS_SUSPENDED(corPtr)) {
- Tcl_AppendResult(interp,
- "can only inject a command into a suspended coroutine", NULL);
+ Tcl_SetObjResult(interp, Tcl_NewStringObj(
+ "can only inject a command into a suspended coroutine", -1));
Tcl_SetErrorCode(interp, "TCL", "COROUTINE", "ACTIVE", NULL);
return TCL_ERROR;
}
@@ -8847,7 +8854,7 @@ NRCoroInjectObjCmd(
}
int
-NRInterpCoroutine(
+TclNRInterpCoroutine(
ClientData clientData,
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
@@ -8856,9 +8863,9 @@ NRInterpCoroutine(
CoroutineData *corPtr = clientData;
if (!COR_IS_SUSPENDED(corPtr)) {
- Tcl_ResetResult(interp);
- Tcl_AppendResult(interp, "coroutine \"", Tcl_GetString(objv[0]),
- "\" is already running", NULL);
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "coroutine \"%s\" is already running",
+ Tcl_GetString(objv[0])));
Tcl_SetErrorCode(interp, "TCL", "COROUTINE", "BUSY", NULL);
return TCL_ERROR;
}
@@ -8939,22 +8946,24 @@ TclNRCoroutineObjCmd(
&nsPtr, &altNsPtr, &cxtNsPtr, &procName);
if (nsPtr == NULL) {
- Tcl_AppendResult(interp, "can't create procedure \"", fullName,
- "\": unknown namespace", NULL);
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "can't create procedure \"%s\": unknown namespace",
+ fullName));
Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "NAMESPACE", NULL);
return TCL_ERROR;
}
if (procName == NULL) {
- Tcl_AppendResult(interp, "can't create procedure \"", fullName,
- "\": bad procedure name", 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_AppendResult(interp, "can't create procedure \"", procName,
- "\" in non-global namespace with name starting with \":\"",
- NULL);
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "can't create procedure \"%s\" in non-global namespace with"
+ " name starting with \":\"", procName));
Tcl_SetErrorCode(interp, "TCL", "VALUE", "COMMAND", procName, NULL);
return TCL_ERROR;
}
@@ -8969,12 +8978,12 @@ TclNRCoroutineObjCmd(
Tcl_DStringInit(&ds);
if (nsPtr != iPtr->globalNsPtr) {
Tcl_DStringAppend(&ds, nsPtr->fullName, -1);
- Tcl_DStringAppend(&ds, "::", 2);
+ TclDStringAppendLiteral(&ds, "::");
}
Tcl_DStringAppend(&ds, procName, -1);
cmdPtr = (Command *) Tcl_NRCreateCommand(interp, Tcl_DStringValue(&ds),
- /*objProc*/ NULL, NRInterpCoroutine, corPtr, DeleteCoroutine);
+ /*objProc*/ NULL, TclNRInterpCoroutine, corPtr, DeleteCoroutine);
Tcl_DStringFree(&ds);
corPtr->cmdPtr = cmdPtr;
diff --git a/generic/tclBinary.c b/generic/tclBinary.c
index 444e7fa..a1e836e 100644
--- a/generic/tclBinary.c
+++ b/generic/tclBinary.c
@@ -873,9 +873,9 @@ BinaryFormatCmd(
if (count == BINARY_ALL) {
count = listc;
} else if (count > listc) {
- Tcl_AppendResult(interp,
+ Tcl_SetObjResult(interp, Tcl_NewStringObj(
"number of elements in list does not match count",
- NULL);
+ -1));
return TCL_ERROR;
}
}
@@ -884,9 +884,8 @@ BinaryFormatCmd(
case 'x':
if (count == BINARY_ALL) {
- Tcl_AppendResult(interp,
- "cannot use \"*\" in format string with \"x\"",
- NULL);
+ Tcl_SetObjResult(interp, Tcl_NewStringObj(
+ "cannot use \"*\" in format string with \"x\"", -1));
return TCL_ERROR;
} else if (count == BINARY_NOCOUNT) {
count = 1;
@@ -1198,8 +1197,9 @@ BinaryFormatCmd(
badValue:
Tcl_ResetResult(interp);
- Tcl_AppendResult(interp, "expected ", errorString,
- " string but got \"", errorValue, "\" instead", NULL);
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "expected %s string but got \"%s\" instead",
+ errorString, errorValue));
return TCL_ERROR;
badCount:
@@ -1217,12 +1217,13 @@ BinaryFormatCmd(
Tcl_UtfToUniChar(errorString, &ch);
buf[Tcl_UniCharToUtf(ch, buf)] = '\0';
- Tcl_AppendResult(interp, "bad field specifier \"", buf, "\"", NULL);
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "bad field specifier \"%s\"", buf));
return TCL_ERROR;
}
error:
- Tcl_AppendResult(interp, errorString, NULL);
+ Tcl_SetObjResult(interp, Tcl_NewStringObj(errorString, -1));
return TCL_ERROR;
}
@@ -1586,12 +1587,13 @@ BinaryScanCmd(
Tcl_UtfToUniChar(errorString, &ch);
buf[Tcl_UniCharToUtf(ch, buf)] = '\0';
- Tcl_AppendResult(interp, "bad field specifier \"", buf, "\"", NULL);
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "bad field specifier \"%s\"", buf));
return TCL_ERROR;
}
error:
- Tcl_AppendResult(interp, errorString, NULL);
+ Tcl_SetObjResult(interp, Tcl_NewStringObj(errorString, -1));
return TCL_ERROR;
}
diff --git a/generic/tclCkalloc.c b/generic/tclCkalloc.c
index 5b5a0d6..6443975 100644
--- a/generic/tclCkalloc.c
+++ b/generic/tclCkalloc.c
@@ -815,15 +815,16 @@ MemoryCmd(
size_t len;
if (argc < 2) {
- Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
- " option [args..]\"", NULL);
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "wrong # args: should be \"%s option [args..]\"", argv[0]));
return TCL_ERROR;
}
- if ((strcmp(argv[1],"active") == 0) || (strcmp(argv[1],"display") == 0)) {
+ if (strcmp(argv[1], "active") == 0 || strcmp(argv[1], "display") == 0) {
if (argc != 3) {
- Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
- " ", argv[1], " file\"", NULL);
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "wrong # args: should be \"%s %s file\"",
+ argv[0], argv[1]));
return TCL_ERROR;
}
fileName = Tcl_TranslateFileName(interp, argv[2], &buffer);
@@ -833,7 +834,8 @@ MemoryCmd(
result = Tcl_DumpActiveMemory(fileName);
Tcl_DStringFree(&buffer);
if (result != TCL_OK) {
- Tcl_AppendResult(interp, "error accessing ", argv[2], NULL);
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf("error accessing %s: %s",
+ argv[2], Tcl_PosixError(interp)));
return TCL_ERROR;
}
return TCL_OK;
@@ -857,17 +859,17 @@ MemoryCmd(
"maximum bytes allocated", (unsigned long)maximum_bytes_malloced));
return TCL_OK;
}
- if (strcmp(argv[1],"init") == 0) {
+ if (strcmp(argv[1], "init") == 0) {
if (argc != 3) {
goto bad_suboption;
}
init_malloced_bodies = (strcmp(argv[2],"on") == 0);
return TCL_OK;
}
- if (strcmp(argv[1],"objs") == 0) {
+ if (strcmp(argv[1], "objs") == 0) {
if (argc != 3) {
- Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
- " objs file\"", NULL);
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "wrong # args: should be \"%s objs file\"", argv[0]));
return TCL_ERROR;
}
fileName = Tcl_TranslateFileName(interp, argv[2], &buffer);
@@ -876,7 +878,9 @@ MemoryCmd(
}
fileP = fopen(fileName, "w");
if (fileP == NULL) {
- Tcl_AppendResult(interp, "cannot open output file", NULL);
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "cannot open output file: %s",
+ Tcl_PosixError(interp)));
return TCL_ERROR;
}
TclDbDumpActiveObjects(fileP);
@@ -886,8 +890,8 @@ MemoryCmd(
}
if (strcmp(argv[1],"onexit") == 0) {
if (argc != 3) {
- Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
- " onexit file\"", NULL);
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "wrong # args: should be \"%s onexit file\"", argv[0]));
return TCL_ERROR;
}
fileName = Tcl_TranslateFileName(interp, argv[2], &buffer);
@@ -901,8 +905,8 @@ MemoryCmd(
}
if (strcmp(argv[1],"tag") == 0) {
if (argc != 3) {
- Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
- " tag string\"", NULL);
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "wrong # args: should be \"%s tag string\"", argv[0]));
return TCL_ERROR;
}
if ((curTagPtr != NULL) && (curTagPtr->refCount == 0)) {
@@ -939,19 +943,20 @@ MemoryCmd(
return TCL_OK;
}
- Tcl_AppendResult(interp, "bad option \"", argv[1],
- "\": should be active, break_on_malloc, info, init, objs, onexit, "
- "tag, trace, trace_on_at_malloc, or validate", NULL);
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "bad option \"%s\": should be active, break_on_malloc, info, "
+ "init, objs, onexit, tag, trace, trace_on_at_malloc, or validate",
+ argv[1]));
return TCL_ERROR;
argError:
- Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
- " ", argv[1], " count\"", NULL);
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "wrong # args: should be \"%s %s count\"", argv[0], argv[1]));
return TCL_ERROR;
bad_suboption:
- Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
- " ", argv[1], " on|off\"", NULL);
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "wrong # args: should be \"%s %s on|off\"", argv[0], argv[1]));
return TCL_ERROR;
}
@@ -981,8 +986,8 @@ CheckmemCmd(
const char *argv[]) /* String values of arguments. */
{
if (argc != 2) {
- Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
- " fileName\"", NULL);
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "wrong # args: should be \"%s fileName\"", argv[0]));
return TCL_ERROR;
}
tclMemDumpFileName = dumpFile;
diff --git a/generic/tclClock.c b/generic/tclClock.c
index 7fa4017..6d2976d 100644
--- a/generic/tclClock.c
+++ b/generic/tclClock.c
@@ -878,8 +878,8 @@ ConvertLocalToUTCUsingC(
if (localErrno != 0
|| (fields->seconds == -1 && timeVal.tm_yday == -1)) {
- Tcl_SetResult(interp, "time value too large/small to represent",
- TCL_STATIC);
+ Tcl_SetObjResult(interp, Tcl_NewStringObj(
+ "time value too large/small to represent", -1));
return TCL_ERROR;
}
return TCL_OK;
@@ -1018,17 +1018,17 @@ ConvertUTCToLocalUsingC(
tock = (time_t) fields->seconds;
if ((Tcl_WideInt) tock != fields->seconds) {
- Tcl_AppendResult(interp,
- "number too large to represent as a Posix time", NULL);
+ Tcl_SetObjResult(interp, Tcl_NewStringObj(
+ "number too large to represent as a Posix time", -1));
Tcl_SetErrorCode(interp, "CLOCK", "argTooLarge", NULL);
return TCL_ERROR;
}
TzsetIfNecessary();
timeVal = ThreadSafeLocalTime(&tock);
if (timeVal == NULL) {
- Tcl_AppendResult(interp,
+ Tcl_SetObjResult(interp, Tcl_NewStringObj(
"localtime failed (clock value may be too "
- "large/small to represent)", NULL);
+ "large/small to represent)", -1));
Tcl_SetErrorCode(interp, "CLOCK", "localtimeFailed", NULL);
return TCL_ERROR;
}
diff --git a/generic/tclCmdAH.c b/generic/tclCmdAH.c
index 1cbc4d2..5ca5cf8 100644
--- a/generic/tclCmdAH.c
+++ b/generic/tclCmdAH.c
@@ -61,6 +61,7 @@ static Tcl_NRPostProc ForPostNextCallback;
static Tcl_NRPostProc ForeachLoopStep;
static Tcl_NRPostProc EvalCmdErrMsg;
+static Tcl_ObjCmdProc BadFileSubcommand;
static Tcl_ObjCmdProc FileAttrAccessTimeCmd;
static Tcl_ObjCmdProc FileAttrIsDirectoryCmd;
static Tcl_ObjCmdProc FileAttrIsExecutableCmd;
@@ -193,7 +194,8 @@ Tcl_CaseObjCmd(
if (i == caseObjc-1) {
Tcl_ResetResult(interp);
- Tcl_AppendResult(interp, "extra case pattern with no body", NULL);
+ Tcl_SetObjResult(interp, Tcl_NewStringObj(
+ "extra case pattern with no body", -1));
return TCL_ERROR;
}
@@ -408,8 +410,9 @@ Tcl_CdObjCmd(
} else {
result = Tcl_FSChdir(dir);
if (result != TCL_OK) {
- Tcl_AppendResult(interp, "couldn't change working directory to \"",
- TclGetString(dir), "\": ", Tcl_PosixError(interp), NULL);
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "couldn't change working directory to \"%s\": %s",
+ TclGetString(dir), Tcl_PosixError(interp)));
result = TCL_ERROR;
}
}
@@ -563,9 +566,7 @@ Tcl_EncodingObjCmd(
* truncate the string at the first null byte.
*/
- Tcl_SetObjResult(interp, Tcl_NewStringObj(
- Tcl_DStringValue(&ds), Tcl_DStringLength(&ds)));
- Tcl_DStringFree(&ds);
+ Tcl_SetObjResult(interp, TclDStringToObj(&ds));
} else {
/*
* Store the result as binary data.
@@ -583,7 +584,7 @@ Tcl_EncodingObjCmd(
break;
}
case ENC_DIRS:
- return EncodingDirsObjCmd(dummy, interp, objc-1, objv+1);
+ return EncodingDirsObjCmd(dummy, interp, objc, objv);
case ENC_NAMES:
if (objc > 2) {
Tcl_WrongNumArgs(interp, 2, objv, NULL);
@@ -630,22 +631,27 @@ EncodingDirsObjCmd(
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
- if (objc > 2) {
- Tcl_WrongNumArgs(interp, 1, objv, "?dirList?");
+ Tcl_Obj *dirListObj;
+
+ if (objc > 3) {
+ Tcl_WrongNumArgs(interp, 2, objv, "?dirList?");
return TCL_ERROR;
}
- if (objc == 1) {
+ if (objc == 2) {
Tcl_SetObjResult(interp, Tcl_GetEncodingSearchPath());
return TCL_OK;
}
- if (Tcl_SetEncodingSearchPath(objv[1]) == TCL_ERROR) {
- Tcl_AppendResult(interp, "expected directory list but got \"",
- TclGetString(objv[1]), "\"", NULL);
+
+ dirListObj = objv[2];
+ if (Tcl_SetEncodingSearchPath(dirListObj) == TCL_ERROR) {
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "expected directory list but got \"%s\"",
+ TclGetString(dirListObj)));
Tcl_SetErrorCode(interp, "TCL", "OPERATION", "ENCODING", "BADPATH",
NULL);
return TCL_ERROR;
}
- Tcl_SetObjResult(interp, objv[1]);
+ Tcl_SetObjResult(interp, dirListObj);
return TCL_OK;
}
@@ -1042,9 +1048,9 @@ TclMakeFileCommandSafe(
Tcl_DString oldBuf, newBuf;
Tcl_DStringInit(&oldBuf);
- Tcl_DStringAppend(&oldBuf, "::tcl::file::", -1);
+ TclDStringAppendLiteral(&oldBuf, "::tcl::file::");
Tcl_DStringInit(&newBuf);
- Tcl_DStringAppend(&newBuf, "tcl:file:", -1);
+ TclDStringAppendLiteral(&newBuf, "tcl:file:");
for (i=0 ; unsafeInfo[i].cmdName != NULL ; i++) {
if (unsafeInfo[i].unsafe) {
const char *oldName, *newName;
@@ -1059,6 +1065,8 @@ TclMakeFileCommandSafe(
unsafeInfo[i].cmdName,
Tcl_GetString(Tcl_GetObjResult(interp)));
}
+ Tcl_CreateObjCommand(interp, oldName, BadFileSubcommand,
+ (ClientData) unsafeInfo[i].cmdName, NULL);
}
}
Tcl_DStringFree(&oldBuf);
@@ -1080,6 +1088,39 @@ TclMakeFileCommandSafe(
/*
*----------------------------------------------------------------------
*
+ * BadFileSubcommand --
+ *
+ * Command used to act as a backstop implementation when subcommands of
+ * "file" are unsafe (the real implementations of the subcommands are
+ * hidden). The clientData is always the full official subcommand name.
+ *
+ * Results:
+ * A standard Tcl result (always a TCL_ERROR).
+ *
+ * Side effects:
+ * None.
+ *
+ *----------------------------------------------------------------------
+ */
+
+static int
+BadFileSubcommand(
+ ClientData clientData,
+ Tcl_Interp *interp,
+ int objc,
+ Tcl_Obj *const objv[])
+{
+ const char *subcommandName = (const char *) clientData;
+
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "not allowed to invoke subcommand %s of file", subcommandName));
+ Tcl_SetErrorCode(interp, "TCL", "SAFE", "SUBCOMMAND", NULL);
+ return TCL_ERROR;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
* FileAttrAccessTimeCmd --
*
* This function is invoked to process the "file atime" Tcl command. See
@@ -1127,9 +1168,9 @@ FileAttrAccessTimeCmd(
tval.modtime = buf.st_mtime;
if (Tcl_FSUtime(objv[1], &tval) != 0) {
- Tcl_AppendResult(interp, "could not set access time for file \"",
- TclGetString(objv[1]), "\": ", Tcl_PosixError(interp),
- NULL);
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "could not set access time for file \"%s\": %s",
+ TclGetString(objv[1]), Tcl_PosixError(interp)));
return TCL_ERROR;
}
@@ -1199,9 +1240,9 @@ FileAttrModifyTimeCmd(
tval.modtime = newTime;
if (Tcl_FSUtime(objv[1], &tval) != 0) {
- Tcl_AppendResult(interp, "could not set modification time for "
- "file \"", TclGetString(objv[1]), "\": ",
- Tcl_PosixError(interp), NULL);
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "could not set modification time for file \"%s\": %s",
+ TclGetString(objv[1]), Tcl_PosixError(interp)));
return TCL_ERROR;
}
@@ -1804,7 +1845,7 @@ PathFilesystemCmd(
}
fsInfo = Tcl_FSFileSystemInfo(objv[1]);
if (fsInfo == NULL) {
- Tcl_SetResult(interp, "unrecognised path", TCL_STATIC);
+ Tcl_SetObjResult(interp, Tcl_NewStringObj("unrecognised path", -1));
Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "FILESYSTEM",
Tcl_GetString(objv[1]), NULL);
return TCL_ERROR;
@@ -1869,20 +1910,16 @@ PathNativeNameCmd(
int objc,
Tcl_Obj *const objv[])
{
- const char *fileName;
Tcl_DString ds;
if (objc != 2) {
Tcl_WrongNumArgs(interp, 1, objv, "name");
return TCL_ERROR;
}
- fileName = Tcl_TranslateFileName(interp, TclGetString(objv[1]), &ds);
- if (fileName == NULL) {
+ if (Tcl_TranslateFileName(interp, TclGetString(objv[1]), &ds) == NULL) {
return TCL_ERROR;
}
- Tcl_SetObjResult(interp, Tcl_NewStringObj(fileName,
- Tcl_DStringLength(&ds)));
- Tcl_DStringFree(&ds);
+ Tcl_SetObjResult(interp, TclDStringToObj(&ds));
return TCL_OK;
}
@@ -1956,8 +1993,9 @@ PathSplitCmd(
}
res = Tcl_FSSplitPath(objv[1], NULL);
if (res == NULL) {
- Tcl_AppendResult(interp, "could not read \"", TclGetString(objv[1]),
- "\": no such file or directory", NULL);
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "could not read \"%s\": no such file or directory",
+ TclGetString(objv[1])));
Tcl_SetErrorCode(interp, "TCL", "OPERATION", "PATHSPLIT", "NONESUCH",
NULL);
return TCL_ERROR;
@@ -2058,7 +2096,8 @@ FilesystemSeparatorCmd(
Tcl_Obj *separatorObj = Tcl_FSPathSeparator(objv[1]);
if (separatorObj == NULL) {
- Tcl_SetResult(interp, "unrecognised path", TCL_STATIC);
+ Tcl_SetObjResult(interp, Tcl_NewStringObj(
+ "unrecognised path", -1));
Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "FILESYSTEM",
Tcl_GetString(objv[1]), NULL);
return TCL_ERROR;
@@ -2177,9 +2216,9 @@ GetStatBuf(
if (status < 0) {
if (interp != NULL) {
- Tcl_AppendResult(interp, "could not read \"",
- TclGetString(pathPtr), "\": ",
- Tcl_PosixError(interp), NULL);
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "could not read \"%s\": %s",
+ TclGetString(pathPtr), Tcl_PosixError(interp)));
}
return TCL_ERROR;
}
@@ -2614,7 +2653,8 @@ TclNRForeachCmd(
TclListObjGetElements(NULL, statePtr->vCopyList[i],
&statePtr->varcList[i], &statePtr->varvList[i]);
if (statePtr->varcList[i] < 1) {
- Tcl_AppendResult(interp, "foreach varlist is empty", NULL);
+ Tcl_SetObjResult(interp, Tcl_NewStringObj(
+ "foreach varlist is empty", -1));
Tcl_SetErrorCode(interp, "TCL", "OPERATION", "FOREACH",
"NEEDVARS", NULL);
result = TCL_ERROR;
diff --git a/generic/tclCmdIL.c b/generic/tclCmdIL.c
index 3af577b..14e9f0e 100644
--- a/generic/tclCmdIL.c
+++ b/generic/tclCmdIL.c
@@ -27,15 +27,15 @@
*/
typedef struct SortElement {
- union { /* The value that we sorting by. */
+ union { /* The value that we sorting by. */
const char *strValuePtr;
long intValue;
double doubleValue;
Tcl_Obj *objValuePtr;
} collationKey;
- union { /* Object being sorted, or its index. */
- Tcl_Obj *objPtr;
- int index;
+ union { /* Object being sorted, or its index. */
+ Tcl_Obj *objPtr;
+ int index;
} payload;
struct SortElement *nextPtr;/* Next element in the list, or NULL for end
* of list. */
@@ -229,8 +229,9 @@ TclNRIfObjCmd(
Tcl_Obj *boolObj;
if (objc <= 1) {
- Tcl_AppendResult(interp, "wrong # args: no expression after \"",
- TclGetString(objv[0]), "\" argument", NULL);
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "wrong # args: no expression after \"%s\" argument",
+ TclGetString(objv[0])));
Tcl_SetErrorCode(interp, "TCL", "WRONGARGS", NULL);
return TCL_ERROR;
}
@@ -319,8 +320,9 @@ IfConditionCallback(
*/
if (i >= objc) {
- Tcl_AppendResult(interp, "wrong # args: ",
- "no expression after \"", clause, "\" argument", NULL);
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "wrong # args: no expression after \"%s\" argument",
+ clause));
Tcl_SetErrorCode(interp, "TCL", "WRONGARGS", NULL);
return TCL_ERROR;
}
@@ -345,8 +347,9 @@ IfConditionCallback(
}
}
if (i < objc - 1) {
- Tcl_AppendResult(interp, "wrong # args: ",
- "extra words after \"else\" clause in \"if\" command", NULL);
+ Tcl_SetObjResult(interp, Tcl_NewStringObj(
+ "wrong # args: extra words after \"else\" clause in \"if\" command",
+ -1));
Tcl_SetErrorCode(interp, "TCL", "WRONGARGS", NULL);
return TCL_ERROR;
}
@@ -361,9 +364,9 @@ IfConditionCallback(
return TclNREvalObjEx(interp, objv[i], 0, iPtr->cmdFramePtr, i);
missingScript:
- clause = TclGetString(objv[i-1]);
- Tcl_AppendResult(interp, "wrong # args: no script following \"", clause,
- "\" argument", NULL);
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "wrong # args: no script following \"%s\" argument",
+ TclGetString(objv[i-1])));
Tcl_SetErrorCode(interp, "TCL", "WRONGARGS", NULL);
return TCL_ERROR;
}
@@ -491,7 +494,8 @@ InfoArgsCmd(
name = TclGetString(objv[1]);
procPtr = TclFindProc(iPtr, name);
if (procPtr == NULL) {
- Tcl_AppendResult(interp, "\"", name, "\" isn't a procedure", NULL);
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "\"%s\" isn't a procedure", name));
Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "PROCEDURE", name, NULL);
return TCL_ERROR;
}
@@ -552,7 +556,8 @@ InfoBodyCmd(
name = TclGetString(objv[1]);
procPtr = TclFindProc(iPtr, name);
if (procPtr == NULL) {
- Tcl_AppendResult(interp, "\"", name, "\" isn't a procedure", NULL);
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "\"%s\" isn't a procedure", name));
Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "PROCEDURE", name, NULL);
return TCL_ERROR;
}
@@ -981,7 +986,8 @@ InfoDefaultCmd(
procPtr = TclFindProc(iPtr, procName);
if (procPtr == NULL) {
- Tcl_AppendResult(interp, "\"", procName, "\" isn't a procedure",NULL);
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "\"%s\" isn't a procedure", procName));
Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "PROCEDURE", procName,
NULL);
return TCL_ERROR;
@@ -1012,8 +1018,9 @@ InfoDefaultCmd(
}
}
- Tcl_AppendResult(interp, "procedure \"", procName,
- "\" doesn't have an argument \"", argName, "\"", NULL);
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "procedure \"%s\" doesn't have an argument \"%s\"",
+ procName, argName));
Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "ARGUMENT", argName, NULL);
return TCL_ERROR;
}
@@ -1055,10 +1062,10 @@ InfoErrorStackCmd(
target = interp;
if (objc == 2) {
- target = Tcl_GetSlave(interp, Tcl_GetString(objv[1]));
- if (target == NULL) {
- return TCL_ERROR;
- }
+ target = Tcl_GetSlave(interp, Tcl_GetString(objv[1]));
+ if (target == NULL) {
+ return TCL_ERROR;
+ }
}
iPtr = (Interp *) target;
@@ -1158,12 +1165,13 @@ InfoFrameCmd(
* A coroutine: must fix the level computations AND the cmdFrame chain,
* which is interrupted at the base.
*/
+
CmdFrame *lastPtr = NULL;
- runPtr = iPtr->cmdFramePtr;
+ runPtr = iPtr->cmdFramePtr;
/* TODO - deal with overflow */
- topLevel += corPtr->caller.cmdFramePtr->level;
+ topLevel += corPtr->caller.cmdFramePtr->level;
while (runPtr) {
runPtr->level += corPtr->caller.cmdFramePtr->level;
lastPtr = runPtr;
@@ -1196,8 +1204,8 @@ InfoFrameCmd(
if ((level > topLevel) || (level <= - topLevel)) {
levelError:
- Tcl_AppendResult(interp, "bad level \"", TclGetString(objv[1]), "\"",
- NULL);
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "bad level \"%s\"", TclGetString(objv[1])));
Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "STACK_FRAME",
TclGetString(objv[1]), NULL);
code = TCL_ERROR;
@@ -1401,15 +1409,15 @@ TclInfoFrame(
Tcl_HashEntry *namePtr = procPtr->cmdPtr->hPtr;
if (namePtr) {
- Tcl_Obj *procNameObj;
+ Tcl_Obj *procNameObj;
/*
* This is a regular command.
*/
- TclNewObj(procNameObj);
- Tcl_GetCommandFullName(interp, (Tcl_Command) procPtr->cmdPtr,
- procNameObj);
+ TclNewObj(procNameObj);
+ Tcl_GetCommandFullName(interp, (Tcl_Command) procPtr->cmdPtr,
+ procNameObj);
ADD_PAIR("proc", procNameObj);
} else if (procPtr->cmdPtr->clientData) {
ExtraFrameInfo *efiPtr = procPtr->cmdPtr->clientData;
@@ -1538,7 +1546,9 @@ InfoHostnameCmd(
Tcl_SetObjResult(interp, Tcl_NewStringObj(name, -1));
return TCL_OK;
}
- Tcl_SetResult(interp, "unable to determine name of host", TCL_STATIC);
+
+ Tcl_SetObjResult(interp, Tcl_NewStringObj(
+ "unable to determine name of host", -1));
Tcl_SetErrorCode(interp, "TCL", "OPERATION", "HOSTNAME", "UNKNOWN", NULL);
return TCL_ERROR;
}
@@ -1609,8 +1619,8 @@ InfoLevelCmd(
return TCL_ERROR;
levelError:
- Tcl_AppendResult(interp, "bad level \"", TclGetString(objv[1]), "\"",
- NULL);
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "bad level \"%s\"", TclGetString(objv[1])));
Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "STACK_LEVEL",
TclGetString(objv[1]), NULL);
return TCL_ERROR;
@@ -1656,7 +1666,9 @@ InfoLibraryCmd(
Tcl_SetObjResult(interp, Tcl_NewStringObj(libDirName, -1));
return TCL_OK;
}
- Tcl_SetResult(interp, "no library has been specified for Tcl",TCL_STATIC);
+
+ Tcl_SetObjResult(interp, Tcl_NewStringObj(
+ "no library has been specified for Tcl", -1));
Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "VARIABLE", "tcl_library",NULL);
return TCL_ERROR;
}
@@ -2590,9 +2602,10 @@ Tcl_LrepeatObjCmd(
return TCL_ERROR;
}
if (elementCount < 0) {
- Tcl_SetObjResult(interp, Tcl_Format(NULL,
- "bad count \"%d\": must be integer >= 0", 1, objv+1));
- Tcl_SetErrorCode(interp, "TCL","OPERATION","LREPEAT","NEGARG", NULL);
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "bad count \"%d\": must be integer >= 0", elementCount));
+ Tcl_SetErrorCode(interp, "TCL", "OPERATION", "LREPEAT", "NEGARG",
+ NULL);
return TCL_ERROR;
}
@@ -2608,7 +2621,7 @@ Tcl_LrepeatObjCmd(
if (elementCount && objc > LIST_MAX/elementCount) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"max length of a Tcl list (%d elements) exceeded", LIST_MAX));
- Tcl_SetErrorCode(interp, "TCL", "MEMORY", NULL);
+ Tcl_SetErrorCode(interp, "TCL", "MEMORY", NULL);
return TCL_ERROR;
}
totalElems = objc * elementCount;
@@ -2723,9 +2736,10 @@ Tcl_LreplaceObjCmd(
*/
if ((first >= listLen) && (listLen > 0)) {
- Tcl_AppendResult(interp, "list doesn't contain element ",
- TclGetString(objv[2]), NULL);
- Tcl_SetErrorCode(interp, "TCL","OPERATION","LREPLACE","BADIDX", NULL);
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "list doesn't contain element %s", TclGetString(objv[2])));
+ Tcl_SetErrorCode(interp, "TCL", "OPERATION", "LREPLACE", "BADIDX",
+ NULL);
return TCL_ERROR;
}
if (last >= listLen) {
@@ -2996,8 +3010,9 @@ Tcl_LsearchObjCmd(
Tcl_DecrRefCount(startPtr);
}
if (i > objc-4) {
- Tcl_AppendResult(interp, "missing starting index", NULL);
- Tcl_SetErrorCode(interp, "TCL", "ARGUMENT", "MISSING", NULL);
+ Tcl_SetObjResult(interp, Tcl_NewStringObj(
+ "missing starting index", -1));
+ Tcl_SetErrorCode(interp, "TCL", "ARGUMENT", "MISSING", NULL);
result = TCL_ERROR;
goto done;
}
@@ -3027,10 +3042,10 @@ Tcl_LsearchObjCmd(
if (startPtr != NULL) {
Tcl_DecrRefCount(startPtr);
}
- Tcl_AppendResult(interp,
+ Tcl_SetObjResult(interp, Tcl_NewStringObj(
"\"-index\" option must be followed by list index",
- NULL);
- Tcl_SetErrorCode(interp, "TCL", "ARGUMENT", "MISSING", NULL);
+ -1));
+ Tcl_SetErrorCode(interp, "TCL", "ARGUMENT", "MISSING", NULL);
return TCL_ERROR;
}
@@ -3088,18 +3103,18 @@ Tcl_LsearchObjCmd(
if (startPtr != NULL) {
Tcl_DecrRefCount(startPtr);
}
- Tcl_AppendResult(interp,
- "-subindices cannot be used without -index option", NULL);
- Tcl_SetErrorCode(interp, "TCL", "OPERATION", "LSEARCH",
- "BAD_OPTION_MIX", NULL);
+ Tcl_SetObjResult(interp, Tcl_NewStringObj(
+ "-subindices cannot be used without -index option", -1));
+ Tcl_SetErrorCode(interp, "TCL", "OPERATION", "LSEARCH",
+ "BAD_OPTION_MIX", NULL);
return TCL_ERROR;
}
if (bisect && (allMatches || negatedMatch)) {
- Tcl_AppendResult(interp,
- "-bisect is not compatible with -all or -not", NULL);
- Tcl_SetErrorCode(interp, "TCL", "OPERATION", "LSEARCH",
- "BAD_OPTION_MIX", NULL);
+ Tcl_SetObjResult(interp, Tcl_NewStringObj(
+ "-bisect is not compatible with -all or -not", -1));
+ Tcl_SetErrorCode(interp, "TCL", "OPERATION", "LSEARCH",
+ "BAD_OPTION_MIX", NULL);
return TCL_ERROR;
}
@@ -3531,7 +3546,7 @@ Tcl_LsetObjCmd(
if (objc < 3) {
Tcl_WrongNumArgs(interp, 1, objv,
- "listVar ?index? ?index ...? value");
+ "listVar ?index? ?index ...? value");
return TCL_ERROR;
}
@@ -3664,10 +3679,10 @@ Tcl_LsortObjCmd(
break;
case LSORT_COMMAND:
if (i == objc-2) {
- Tcl_AppendResult(interp,
+ Tcl_SetObjResult(interp, Tcl_NewStringObj(
"\"-command\" option must be followed "
- "by comparison command", NULL);
- Tcl_SetErrorCode(interp, "TCL", "ARGUMENT", "MISSING", NULL);
+ "by comparison command", -1));
+ Tcl_SetErrorCode(interp, "TCL", "ARGUMENT", "MISSING", NULL);
sortInfo.resultCode = TCL_ERROR;
goto done2;
}
@@ -3685,29 +3700,30 @@ Tcl_LsortObjCmd(
sortInfo.isIncreasing = 1;
break;
case LSORT_INDEX: {
- int indexc, dummy;
+ int indexc, dummy;
Tcl_Obj **indexv;
if (i == objc-2) {
- Tcl_AppendResult(interp, "\"-index\" option must be "
- "followed by list index", NULL);
- Tcl_SetErrorCode(interp, "TCL", "ARGUMENT", "MISSING", NULL);
- sortInfo.resultCode = TCL_ERROR;
- goto done2;
+ Tcl_SetObjResult(interp, Tcl_NewStringObj(
+ "\"-index\" option must be followed by list index",
+ -1));
+ Tcl_SetErrorCode(interp, "TCL", "ARGUMENT", "MISSING", NULL);
+ sortInfo.resultCode = TCL_ERROR;
+ goto done2;
}
if (TclListObjGetElements(interp, objv[i+1], &indexc,
&indexv) != TCL_OK) {
- sortInfo.resultCode = TCL_ERROR;
- goto done2;
+ sortInfo.resultCode = TCL_ERROR;
+ goto done2;
}
- /*
- * Check each of the indices for syntactic correctness. Note that
- * we do not store the converted values here because we do not
- * know if this is the only -index option yet and so we can't
- * allocate any space; that happens after the scan through all the
- * options is done.
- */
+ /*
+ * Check each of the indices for syntactic correctness. Note that
+ * we do not store the converted values here because we do not
+ * know if this is the only -index option yet and so we can't
+ * allocate any space; that happens after the scan through all the
+ * options is done.
+ */
for (j=0 ; j<indexc ; j++) {
if (TclGetIntForIndexM(interp, indexv[j], SORTIDX_END,
@@ -3719,7 +3735,7 @@ Tcl_LsortObjCmd(
}
}
indexPtr = objv[i+1];
- i++;
+ i++;
break;
}
case LSORT_INTEGER:
@@ -3739,9 +3755,10 @@ Tcl_LsortObjCmd(
break;
case LSORT_STRIDE:
if (i == objc-2) {
- Tcl_AppendResult(interp, "\"-stride\" option must be ",
- "followed by stride length", NULL);
- Tcl_SetErrorCode(interp, "TCL", "ARGUMENT", "MISSING", NULL);
+ Tcl_SetObjResult(interp, Tcl_NewStringObj(
+ "\"-stride\" option must be "
+ "followed by stride length", -1));
+ Tcl_SetErrorCode(interp, "TCL", "ARGUMENT", "MISSING", NULL);
sortInfo.resultCode = TCL_ERROR;
goto done2;
}
@@ -3750,10 +3767,10 @@ Tcl_LsortObjCmd(
goto done2;
}
if (groupSize < 2) {
- Tcl_AppendResult(interp, "stride length must be at least 2",
- NULL);
- Tcl_SetErrorCode(interp, "TCL", "OPERATION", "LSORT",
- "BADSTRIDE", NULL);
+ Tcl_SetObjResult(interp, Tcl_NewStringObj(
+ "stride length must be at least 2", -1));
+ Tcl_SetErrorCode(interp, "TCL", "OPERATION", "LSORT",
+ "BADSTRIDE", NULL);
sortInfo.resultCode = TCL_ERROR;
goto done2;
}
@@ -3773,26 +3790,26 @@ Tcl_LsortObjCmd(
*/
if (indexPtr) {
- Tcl_Obj **indexv;
-
- TclListObjGetElements(interp, indexPtr, &sortInfo.indexc, &indexv);
- switch (sortInfo.indexc) {
- case 0:
- sortInfo.indexv = NULL;
- break;
- case 1:
- sortInfo.indexv = &sortInfo.singleIndex;
- break;
- default:
- sortInfo.indexv =
+ Tcl_Obj **indexv;
+
+ TclListObjGetElements(interp, indexPtr, &sortInfo.indexc, &indexv);
+ switch (sortInfo.indexc) {
+ case 0:
+ sortInfo.indexv = NULL;
+ break;
+ case 1:
+ sortInfo.indexv = &sortInfo.singleIndex;
+ break;
+ default:
+ sortInfo.indexv =
TclStackAlloc(interp, sizeof(int) * sortInfo.indexc);
- allocatedIndexVector = 1; /* Cannot use indexc field, as it
- * might be decreased by 1 later. */
- }
- for (j=0 ; j<sortInfo.indexc ; j++) {
- TclGetIntForIndexM(interp, indexv[j], SORTIDX_END,
+ allocatedIndexVector = 1; /* Cannot use indexc field, as it
+ * might be decreased by 1 later. */
+ }
+ for (j=0 ; j<sortInfo.indexc ; j++) {
+ TclGetIntForIndexM(interp, indexv[j], SORTIDX_END,
&sortInfo.indexv[j]);
- }
+ }
}
listObj = objv[objc-1];
@@ -3847,11 +3864,11 @@ Tcl_LsortObjCmd(
if (group) {
if (length % groupSize) {
- Tcl_AppendResult(interp,
+ Tcl_SetObjResult(interp, Tcl_NewStringObj(
"list size must be a multiple of the stride length",
+ -1));
+ Tcl_SetErrorCode(interp, "TCL", "OPERATION", "LSORT", "BADSTRIDE",
NULL);
- Tcl_SetErrorCode(interp, "TCL", "OPERATION", "LSORT", "BADSTRIDE",
- NULL);
sortInfo.resultCode = TCL_ERROR;
goto done;
}
@@ -3867,11 +3884,11 @@ Tcl_LsortObjCmd(
groupOffset = (groupOffset - SORTIDX_END) + groupSize - 1;
}
if (groupOffset < 0 || groupOffset >= groupSize) {
- Tcl_AppendResult(interp, "when used with \"-stride\", the "
- "leading \"-index\" value must be within the group",
- NULL);
- Tcl_SetErrorCode(interp, "TCL", "OPERATION", "LSORT",
- "BADINDEX", NULL);
+ Tcl_SetObjResult(interp, Tcl_NewStringObj(
+ "when used with \"-stride\", the leading \"-index\""
+ " value must be within the group", -1));
+ Tcl_SetErrorCode(interp, "TCL", "OPERATION", "LSORT",
+ "BADINDEX", NULL);
sortInfo.resultCode = TCL_ERROR;
goto done;
}
@@ -4255,11 +4272,10 @@ SortCompare(
if (TclGetIntFromObj(infoPtr->interp,
Tcl_GetObjResult(infoPtr->interp), &order) != TCL_OK) {
- Tcl_ResetResult(infoPtr->interp);
- Tcl_AppendResult(infoPtr->interp,
- "-compare command returned non-integer result", NULL);
- Tcl_SetErrorCode(infoPtr->interp, "TCL", "OPERATION", "LSORT",
- "COMPARISONFAILED", NULL);
+ Tcl_SetObjResult(infoPtr->interp, Tcl_NewStringObj(
+ "-compare command returned non-integer result", -1));
+ Tcl_SetErrorCode(infoPtr->interp, "TCL", "OPERATION", "LSORT",
+ "COMPARISONFAILED", NULL);
infoPtr->resultCode = TCL_ERROR;
return 0;
}
@@ -4470,11 +4486,11 @@ SelectObjFromSublist(
return NULL;
}
if (currentObj == NULL) {
- Tcl_SetObjResult(infoPtr->interp, Tcl_ObjPrintf(
- "element %d missing from sublist \"%s\"",
- index, TclGetString(objPtr)));
- Tcl_SetErrorCode(infoPtr->interp, "TCL", "OPERATION", "LSORT",
- "INDEXFAILED", NULL);
+ Tcl_SetObjResult(infoPtr->interp, Tcl_ObjPrintf(
+ "element %d missing from sublist \"%s\"",
+ index, TclGetString(objPtr)));
+ Tcl_SetErrorCode(infoPtr->interp, "TCL", "OPERATION", "LSORT",
+ "INDEXFAILED", NULL);
infoPtr->resultCode = TCL_ERROR;
return NULL;
}
@@ -4489,6 +4505,5 @@ SelectObjFromSublist(
* c-basic-offset: 4
* fill-column: 78
* tab-width: 8
- * indent-tabs-mode: nil
* End:
*/
diff --git a/generic/tclCmdMZ.c b/generic/tclCmdMZ.c
index c5bb72d..9e720ea 100644
--- a/generic/tclCmdMZ.c
+++ b/generic/tclCmdMZ.c
@@ -204,8 +204,8 @@ Tcl_RegexpObjCmd(
*/
if (doinline && ((objc - 2) != 0)) {
- Tcl_AppendResult(interp, "regexp match variables not allowed"
- " when using -inline", NULL);
+ Tcl_SetObjResult(interp, Tcl_NewStringObj(
+ "regexp match variables not allowed when using -inline", -1));
goto optionError;
}
@@ -1839,8 +1839,8 @@ StringMapCmd(
strncmp(string, "-nocase", (size_t) length2) == 0) {
nocase = 1;
} else {
- Tcl_AppendResult(interp, "bad option \"", string,
- "\": must be -nocase", NULL);
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "bad option \"%s\": must be -nocase", string));
Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "INDEX", "option",
string, NULL);
return TCL_ERROR;
@@ -2106,8 +2106,8 @@ StringMatchCmd(
strncmp(string, "-nocase", (size_t) length) == 0) {
nocase = TCL_MATCH_NOCASE;
} else {
- Tcl_AppendResult(interp, "bad option \"", string,
- "\": must be -nocase", NULL);
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "bad option \"%s\": must be -nocase", string));
Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "INDEX", "option",
string, NULL);
return TCL_ERROR;
@@ -2567,8 +2567,9 @@ StringEqualCmd(
return TCL_ERROR;
}
} else {
- Tcl_AppendResult(interp, "bad option \"", string2,
- "\": must be -nocase or -length", NULL);
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "bad option \"%s\": must be -nocase or -length",
+ string2));
Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "INDEX", "option",
string2, NULL);
return TCL_ERROR;
@@ -2716,8 +2717,9 @@ StringCmpCmd(
return TCL_ERROR;
}
} else {
- Tcl_AppendResult(interp, "bad option \"", string2,
- "\": must be -nocase or -length", NULL);
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "bad option \"%s\": must be -nocase or -length",
+ string2));
Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "INDEX", "option",
string2, NULL);
return TCL_ERROR;
@@ -3515,9 +3517,9 @@ TclNRSwitchObjCmd(
* Mode already set via -exact, -glob, or -regexp.
*/
- Tcl_AppendResult(interp, "bad option \"",
- TclGetString(objv[i]), "\": ", options[mode],
- " option already found", NULL);
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "bad option \"%s\": %s option already found",
+ TclGetString(objv[i]), options[mode]));
Tcl_SetErrorCode(interp, "TCL", "OPERATION", "SWITCH",
"DOUBLEOPT", NULL);
return TCL_ERROR;
@@ -3534,8 +3536,9 @@ TclNRSwitchObjCmd(
case OPT_INDEXV:
i++;
if (i >= objc-2) {
- Tcl_AppendResult(interp, "missing variable name argument to ",
- "-indexvar", " option", NULL);
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "missing variable name argument to %s option",
+ "-indexvar"));
Tcl_SetErrorCode(interp, "TCL", "OPERATION", "SWITCH",
"NOVAR", NULL);
return TCL_ERROR;
@@ -3546,8 +3549,9 @@ TclNRSwitchObjCmd(
case OPT_MATCHV:
i++;
if (i >= objc-2) {
- Tcl_AppendResult(interp, "missing variable name argument to ",
- "-matchvar", " option", NULL);
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "missing variable name argument to %s option",
+ "-matchvar"));
Tcl_SetErrorCode(interp, "TCL", "OPERATION", "SWITCH",
"NOVAR", NULL);
return TCL_ERROR;
@@ -3565,15 +3569,15 @@ TclNRSwitchObjCmd(
return TCL_ERROR;
}
if (indexVarObj != NULL && mode != OPT_REGEXP) {
- Tcl_AppendResult(interp,
- "-indexvar option requires -regexp option", NULL);
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "%s option requires -regexp option", "-indexvar"));
Tcl_SetErrorCode(interp, "TCL", "OPERATION", "SWITCH",
"MODERESTRICTION", NULL);
return TCL_ERROR;
}
if (matchVarObj != NULL && mode != OPT_REGEXP) {
- Tcl_AppendResult(interp,
- "-matchvar option requires -regexp option", NULL);
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "%s option requires -regexp option", "-matchvar"));
Tcl_SetErrorCode(interp, "TCL", "OPERATION", "SWITCH",
"MODERESTRICTION", NULL);
return TCL_ERROR;
@@ -3622,7 +3626,8 @@ TclNRSwitchObjCmd(
if (objc % 2) {
Tcl_ResetResult(interp);
- Tcl_AppendResult(interp, "extra switch pattern with no body", NULL);
+ Tcl_SetObjResult(interp, Tcl_NewStringObj(
+ "extra switch pattern with no body", -1));
Tcl_SetErrorCode(interp, "TCL", "OPERATION", "SWITCH", "BADARM",
NULL);
@@ -3637,10 +3642,10 @@ TclNRSwitchObjCmd(
if (splitObjs) {
for (i=0 ; i<objc ; i+=2) {
if (TclGetString(objv[i])[0] == '#') {
- Tcl_AppendResult(interp, ", this may be due to a "
- "comment incorrectly placed outside of a "
- "switch body - see the \"switch\" "
- "documentation", NULL);
+ Tcl_AppendToObj(Tcl_GetObjResult(interp),
+ ", this may be due to a comment incorrectly"
+ " placed outside of a switch body - see the"
+ " \"switch\" documentation", -1);
Tcl_SetErrorCode(interp, "TCL", "OPERATION", "SWITCH",
"BADARM", "COMMENT?", NULL);
break;
@@ -3657,9 +3662,9 @@ TclNRSwitchObjCmd(
*/
if (strcmp(TclGetString(objv[objc-1]), "-") == 0) {
- Tcl_ResetResult(interp);
- Tcl_AppendResult(interp, "no body specified for pattern \"",
- TclGetString(objv[objc-2]), "\"", NULL);
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "no body specified for pattern \"%s\"",
+ TclGetString(objv[objc-2])));
Tcl_SetErrorCode(interp, "TCL", "OPERATION", "SWITCH", "BADARM",
"FALLTHROUGH", NULL);
return TCL_ERROR;
@@ -3758,8 +3763,12 @@ TclNRSwitchObjCmd(
if (indexVarObj != NULL) {
Tcl_Obj *rangeObjAry[2];
- rangeObjAry[0] = Tcl_NewLongObj(info.matches[j].start);
- rangeObjAry[1] = Tcl_NewLongObj(info.matches[j].end);
+ if (info.matches[j].end > 0) {
+ rangeObjAry[0] = Tcl_NewLongObj(info.matches[j].start);
+ rangeObjAry[1] = Tcl_NewLongObj(info.matches[j].end-1);
+ } else {
+ rangeObjAry[0] = rangeObjAry[1] = Tcl_NewIntObj(-1);
+ }
/*
* Never fails; the object is always clean at this point.
@@ -3981,7 +3990,8 @@ Tcl_ThrowObjCmd(
if (Tcl_ListObjLength(interp, objv[1], &len) != TCL_OK) {
return TCL_ERROR;
} else if (len < 1) {
- Tcl_AppendResult(interp, "type must be non-empty list", NULL);
+ Tcl_SetObjResult(interp, Tcl_NewStringObj(
+ "type must be non-empty list", -1));
Tcl_SetErrorCode(interp, "TCL", "OPERATION", "THROW", "BADEXCEPTION",
NULL);
return TCL_ERROR;
@@ -4165,15 +4175,16 @@ TclNRTryObjCmd(
switch ((enum Handlers) type) {
case TryFinally: /* finally script */
if (i < objc-2) {
- Tcl_AppendResult(interp, "finally clause must be last", NULL);
+ Tcl_SetObjResult(interp, Tcl_NewStringObj(
+ "finally clause must be last", -1));
Tcl_DecrRefCount(handlersObj);
Tcl_SetErrorCode(interp, "TCL", "OPERATION", "TRY", "FINALLY",
"NONTERMINAL", NULL);
return TCL_ERROR;
} else if (i == objc-1) {
- Tcl_AppendResult(interp, "wrong # args to finally clause: ",
- "must be \"", TclGetString(objv[0]),
- " ... finally script\"", NULL);
+ Tcl_SetObjResult(interp, Tcl_NewStringObj(
+ "wrong # args to finally clause: must be"
+ " \"... finally script\"", -1));
Tcl_DecrRefCount(handlersObj);
Tcl_SetErrorCode(interp, "TCL", "OPERATION", "TRY", "FINALLY",
"ARGUMENT", NULL);
@@ -4184,15 +4195,16 @@ TclNRTryObjCmd(
case TryOn: /* on code variableList script */
if (i > objc-4) {
- Tcl_AppendResult(interp, "wrong # args to on clause: ",
- "must be \"", TclGetString(objv[0]),
- " ... on code variableList script\"", NULL);
+ Tcl_SetObjResult(interp, Tcl_NewStringObj(
+ "wrong # args to on clause: must be \"... on code"
+ " variableList script\"", -1));
Tcl_DecrRefCount(handlersObj);
Tcl_SetErrorCode(interp, "TCL", "OPERATION", "TRY", "ON",
"ARGUMENT", NULL);
return TCL_ERROR;
}
- if (TCL_ERROR == TclGetCompletionCodeFromObj(interp, objv[i+1], &code)) {
+ if (TclGetCompletionCodeFromObj(interp, objv[i+1],
+ &code) != TCL_OK) {
Tcl_DecrRefCount(handlersObj);
return TCL_ERROR;
}
@@ -4201,9 +4213,10 @@ TclNRTryObjCmd(
case TryTrap: /* trap pattern variableList script */
if (i > objc-4) {
- Tcl_AppendResult(interp, "wrong # args to trap clause: ",
+ Tcl_SetObjResult(interp, Tcl_NewStringObj(
+ "wrong # args to trap clause: "
"must be \"... trap pattern variableList script\"",
- NULL);
+ -1));
Tcl_DecrRefCount(handlersObj);
Tcl_SetErrorCode(interp, "TCL", "OPERATION", "TRY", "TRAP",
"ARGUMENT", NULL);
@@ -4244,9 +4257,8 @@ TclNRTryObjCmd(
}
}
if (bodyShared) {
- Tcl_AppendResult(interp,
- "last non-finally clause must not have a body of \"-\"",
- NULL);
+ Tcl_SetObjResult(interp, Tcl_NewStringObj(
+ "last non-finally clause must not have a body of \"-\"", -1));
Tcl_DecrRefCount(handlersObj);
Tcl_SetErrorCode(interp, "TCL", "OPERATION", "TRY", "BADFALLTHROUGH",
NULL);
diff --git a/generic/tclCompCmds.c b/generic/tclCompCmds.c
index 79d29e9..1ec6bd0 100644
--- a/generic/tclCompCmds.c
+++ b/generic/tclCompCmds.c
@@ -820,7 +820,7 @@ TclCompileDictForCmd(
*/
Tcl_DStringInit(&buffer);
- Tcl_DStringAppend(&buffer, varsTokenPtr[1].start, varsTokenPtr[1].size);
+ TclDStringAppendToken(&buffer, &varsTokenPtr[1]);
if (Tcl_SplitList(NULL, Tcl_DStringValue(&buffer), &numVars,
&argv) != TCL_OK) {
Tcl_DStringFree(&buffer);
@@ -1961,7 +1961,7 @@ TclCompileForeachCmd(
*/
Tcl_DStringInit(&varList);
- Tcl_DStringAppend(&varList, tokenPtr[1].start, tokenPtr[1].size);
+ TclDStringAppendToken(&varList, &tokenPtr[1]);
code = Tcl_SplitList(interp, Tcl_DStringValue(&varList),
&varcList[loopIndex], &varvList[loopIndex]);
Tcl_DStringFree(&varList);
diff --git a/generic/tclCompCmdsSZ.c b/generic/tclCompCmdsSZ.c
index b950e21..8ed3a95 100644
--- a/generic/tclCompCmdsSZ.c
+++ b/generic/tclCompCmdsSZ.c
@@ -1558,8 +1558,7 @@ IssueSwitchJumpTable(
*/
Tcl_DStringInit(&buffer);
- Tcl_DStringAppend(&buffer, bodyToken[i]->start,
- bodyToken[i]->size);
+ TclDStringAppendToken(&buffer, bodyToken[i]);
hPtr = Tcl_CreateHashEntry(&jtPtr->hashTable,
Tcl_DStringValue(&buffer), &isNew);
if (isNew) {
diff --git a/generic/tclCompExpr.c b/generic/tclCompExpr.c
index 4212b6d..890d518 100644
--- a/generic/tclCompExpr.c
+++ b/generic/tclCompExpr.c
@@ -2296,7 +2296,7 @@ CompileExprTree(
int length;
Tcl_DStringInit(&cmdName);
- Tcl_DStringAppend(&cmdName, "tcl::mathfunc::", -1);
+ TclDStringAppendLiteral(&cmdName, "tcl::mathfunc::");
p = TclGetStringFromObj(*funcObjv, &length);
funcObjv++;
Tcl_DStringAppend(&cmdName, p, length);
diff --git a/generic/tclCompile.c b/generic/tclCompile.c
index 6f3f778..4c84953 100644
--- a/generic/tclCompile.c
+++ b/generic/tclCompile.c
@@ -1675,8 +1675,8 @@ TclCompileScript(
* have side effects that rely on the unmodified string.
*/
- Tcl_DStringSetLength(&ds, 0);
- Tcl_DStringAppend(&ds, tokenPtr[1].start,tokenPtr[1].size);
+ TclDStringClear(&ds);
+ TclDStringAppendToken(&ds, &tokenPtr[1]);
cmdPtr = (Command *) Tcl_FindCommand(interp,
Tcl_DStringValue(&ds),
@@ -2058,7 +2058,7 @@ TclCompileTokens(
for ( ; count > 0; count--, tokenPtr++) {
switch (tokenPtr->type) {
case TCL_TOKEN_TEXT:
- Tcl_DStringAppend(&textBuffer, tokenPtr->start, tokenPtr->size);
+ TclDStringAppendToken(&textBuffer, tokenPtr);
TclAdvanceLines(&envPtr->line, tokenPtr->start,
tokenPtr->start + tokenPtr->size);
break;
@@ -2105,9 +2105,7 @@ TclCompileTokens(
*/
if (Tcl_DStringLength(&textBuffer) > 0) {
- int literal = TclRegisterNewLiteral(envPtr,
- Tcl_DStringValue(&textBuffer),
- Tcl_DStringLength(&textBuffer));
+ int literal = TclRegisterDStringLiteral(envPtr, &textBuffer);
TclEmitPush(literal, envPtr);
numObjsToConcat++;
@@ -2134,9 +2132,7 @@ TclCompileTokens(
if (Tcl_DStringLength(&textBuffer) > 0) {
int literal;
- literal = TclRegisterNewLiteral(envPtr,
- Tcl_DStringValue(&textBuffer),
- Tcl_DStringLength(&textBuffer));
+ literal = TclRegisterDStringLiteral(envPtr, &textBuffer);
TclEmitPush(literal, envPtr);
numObjsToConcat++;
Tcl_DStringFree(&textBuffer);
@@ -2159,13 +2155,10 @@ TclCompileTokens(
*/
if (Tcl_DStringLength(&textBuffer) > 0) {
- int literal;
+ int literal = TclRegisterDStringLiteral(envPtr, &textBuffer);
- literal = TclRegisterNewLiteral(envPtr, Tcl_DStringValue(&textBuffer),
- Tcl_DStringLength(&textBuffer));
TclEmitPush(literal, envPtr);
numObjsToConcat++;
-
if (numCL) {
TclContinuationsEnter(envPtr->literalArrayPtr[literal].objPtr,
numCL, clPosition);
diff --git a/generic/tclCompile.h b/generic/tclCompile.h
index e12debf..4e039a2 100644
--- a/generic/tclCompile.h
+++ b/generic/tclCompile.h
@@ -872,8 +872,7 @@ typedef struct {
*----------------------------------------------------------------
*/
-MODULE_SCOPE Tcl_NRPostProc NRCommand;
-MODULE_SCOPE Tcl_ObjCmdProc NRInterpCoroutine;
+MODULE_SCOPE Tcl_ObjCmdProc TclNRInterpCoroutine;
/*
*----------------------------------------------------------------
@@ -1371,6 +1370,16 @@ MODULE_SCOPE Tcl_Obj *TclNewInstNameObj(unsigned char inst);
(envPtr->procPtr || envPtr->iPtr->varFramePtr->localCachePtr)
/*
+ * Macros for making it easier to deal with tokens and DStrings.
+ */
+
+#define TclDStringAppendToken(dsPtr, tokenPtr) \
+ Tcl_DStringAppend((dsPtr), (tokenPtr)->start, (tokenPtr)->size)
+#define TclRegisterDStringLiteral(envPtr, dsPtr) \
+ TclRegisterLiteral(envPtr, Tcl_DStringValue(dsPtr), \
+ Tcl_DStringLength(dsPtr), /*flags*/ 0)
+
+/*
* DTrace probe macros (NOPs if DTrace support is not enabled).
*/
diff --git a/generic/tclConfig.c b/generic/tclConfig.c
index b4735e8..a4ba71a 100644
--- a/generic/tclConfig.c
+++ b/generic/tclConfig.c
@@ -155,7 +155,7 @@ Tcl_RegisterConfig(
*/
Tcl_DStringInit(&cmdName);
- Tcl_DStringAppend(&cmdName, "::", -1);
+ TclDStringAppendLiteral(&cmdName, "::");
Tcl_DStringAppend(&cmdName, pkgName, -1);
/*
@@ -173,7 +173,7 @@ Tcl_RegisterConfig(
}
}
- Tcl_DStringAppend(&cmdName, "::pkgconfig", -1);
+ TclDStringAppendLiteral(&cmdName, "::pkgconfig");
if (Tcl_CreateObjCommand(interp, Tcl_DStringValue(&cmdName),
QueryConfigObjCmd, cdPtr, QueryConfigDelete) == NULL) {
@@ -236,7 +236,7 @@ QueryConfigObjCmd(
* present.
*/
- Tcl_SetResult(interp, "package not known", TCL_STATIC);
+ Tcl_SetObjResult(interp, Tcl_NewStringObj("package not known", -1));
Tcl_SetErrorCode(interp, "TCL", "FATAL", "PKGCFG_BASE",
Tcl_GetString(pkgName), NULL);
return TCL_ERROR;
@@ -251,7 +251,7 @@ QueryConfigObjCmd(
if (Tcl_DictObjGet(interp, pkgDict, objv[2], &val) != TCL_OK
|| val == NULL) {
- Tcl_SetResult(interp, "key not known", TCL_STATIC);
+ Tcl_SetObjResult(interp, Tcl_NewStringObj("key not known", -1));
Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "CONFIG",
Tcl_GetString(objv[2]), NULL);
return TCL_ERROR;
@@ -270,8 +270,8 @@ QueryConfigObjCmd(
listPtr = Tcl_NewListObj(n, NULL);
if (!listPtr) {
- Tcl_SetResult(interp, "insufficient memory to create list",
- TCL_STATIC);
+ Tcl_SetObjResult(interp, Tcl_NewStringObj(
+ "insufficient memory to create list", -1));
Tcl_SetErrorCode(interp, "TCL", "MEMORY", NULL);
return TCL_ERROR;
}
diff --git a/generic/tclDecls.h b/generic/tclDecls.h
index 75dbd9a..1e2a68b 100644
--- a/generic/tclDecls.h
+++ b/generic/tclDecls.h
@@ -1830,7 +1830,7 @@ typedef struct TclStubs {
#if !defined(__WIN32__) && !defined(MAC_OSX_TCL) /* UNIX */
void (*tcl_CreateFileHandler) (int fd, int mask, Tcl_FileProc *proc, ClientData clientData); /* 9 */
#endif /* UNIX */
-#ifdef __WIN32__ /* WIN */
+#if defined(__WIN32__) /* WIN */
void (*reserved9)(void);
#endif /* WIN */
#ifdef MAC_OSX_TCL /* MACOSX */
@@ -1839,7 +1839,7 @@ typedef struct TclStubs {
#if !defined(__WIN32__) && !defined(MAC_OSX_TCL) /* UNIX */
void (*tcl_DeleteFileHandler) (int fd); /* 10 */
#endif /* UNIX */
-#ifdef __WIN32__ /* WIN */
+#if defined(__WIN32__) /* WIN */
void (*reserved10)(void);
#endif /* WIN */
#ifdef MAC_OSX_TCL /* MACOSX */
@@ -2004,7 +2004,7 @@ typedef struct TclStubs {
#if !defined(__WIN32__) && !defined(MAC_OSX_TCL) /* UNIX */
int (*tcl_GetOpenFile) (Tcl_Interp *interp, const char *chanID, int forWriting, int checkUsage, ClientData *filePtr); /* 167 */
#endif /* UNIX */
-#ifdef __WIN32__ /* WIN */
+#if defined(__WIN32__) /* WIN */
void (*reserved167)(void);
#endif /* WIN */
#ifdef MAC_OSX_TCL /* MACOSX */
diff --git a/generic/tclDictObj.c b/generic/tclDictObj.c
index ac2cb62..691fab9 100644
--- a/generic/tclDictObj.c
+++ b/generic/tclDictObj.c
@@ -700,7 +700,8 @@ SetDictFromAny(
missingValue:
if (interp != NULL) {
- Tcl_SetResult(interp, "missing value to go with key", TCL_STATIC);
+ Tcl_SetObjResult(interp, Tcl_NewStringObj(
+ "missing value to go with key", -1));
Tcl_SetErrorCode(interp, "TCL", "VALUE", "DICTIONARY", NULL);
}
result = TCL_ERROR;
@@ -779,9 +780,9 @@ TclTraceDictPath(
}
if ((flags & DICT_PATH_CREATE) != DICT_PATH_CREATE) {
if (interp != NULL) {
- Tcl_ResetResult(interp);
- Tcl_AppendResult(interp, "key \"", TclGetString(keyv[i]),
- "\" not known in dictionary", NULL);
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "key \"%s\" not known in dictionary",
+ TclGetString(keyv[i])));
Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "DICT",
TclGetString(keyv[i]), NULL);
}
@@ -1571,9 +1572,9 @@ DictGetCmd(
return result;
}
if (valuePtr == NULL) {
- Tcl_ResetResult(interp);
- Tcl_AppendResult(interp, "key \"", TclGetString(objv[objc-1]),
- "\" not known in dictionary", NULL);
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "key \"%s\" not known in dictionary",
+ TclGetString(objv[objc-1])));
Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "DICT",
TclGetString(objv[objc-1]), NULL);
return TCL_ERROR;
@@ -2027,6 +2028,7 @@ DictInfoCmd(
{
Tcl_Obj *dictPtr;
Dict *dict;
+ char *statsStr;
if (objc != 2) {
Tcl_WrongNumArgs(interp, 1, objv, "dictionary");
@@ -2042,7 +2044,9 @@ DictInfoCmd(
}
dict = dictPtr->internalRep.otherValuePtr;
- Tcl_SetResult(interp, Tcl_HashStats(&dict->table), TCL_DYNAMIC);
+ statsStr = Tcl_HashStats(&dict->table);
+ Tcl_SetObjResult(interp, Tcl_NewStringObj(statsStr, -1));
+ ckfree(statsStr);
return TCL_OK;
}
@@ -2371,8 +2375,8 @@ DictForNRCmd(
return TCL_ERROR;
}
if (varc != 2) {
- Tcl_SetResult(interp, "must have exactly two variable names",
- TCL_STATIC);
+ Tcl_SetObjResult(interp, Tcl_NewStringObj(
+ "must have exactly two variable names", -1));
return TCL_ERROR;
}
searchPtr = TclStackAlloc(interp, sizeof(Tcl_DictSearch));
@@ -2787,8 +2791,8 @@ DictFilterCmd(
return TCL_ERROR;
}
if (varc != 2) {
- Tcl_SetResult(interp, "must have exactly two variable names",
- TCL_STATIC);
+ Tcl_SetObjResult(interp, Tcl_NewStringObj(
+ "must have exactly two variable names", -1));
return TCL_ERROR;
}
keyVarObj = varv[0];
@@ -2828,16 +2832,19 @@ DictFilterCmd(
if (Tcl_ObjSetVar2(interp, keyVarObj, NULL, keyObj,
TCL_LEAVE_ERR_MSG) == NULL) {
Tcl_ResetResult(interp);
- Tcl_AppendResult(interp, "couldn't set key variable: \"",
- TclGetString(keyVarObj), "\"", NULL);
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "couldn't set key variable: \"%s\"",
+ TclGetString(keyVarObj)));
result = TCL_ERROR;
goto abnormalResult;
}
if (Tcl_ObjSetVar2(interp, valueVarObj, NULL, valueObj,
TCL_LEAVE_ERR_MSG) == NULL) {
Tcl_ResetResult(interp);
- Tcl_AppendResult(interp, "couldn't set value variable: \"",
- TclGetString(valueVarObj), "\"", NULL);
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "couldn't set value variable: \"%s\"",
+ TclGetString(valueVarObj)));
+ result = TCL_ERROR;
goto abnormalResult;
}
diff --git a/generic/tclEncoding.c b/generic/tclEncoding.c
index 49418c9..7a55724 100644
--- a/generic/tclEncoding.c
+++ b/generic/tclEncoding.c
@@ -1542,7 +1542,8 @@ OpenEncodingFileChannel(
}
if ((NULL == chan) && (interp != NULL)) {
- Tcl_AppendResult(interp, "unknown encoding \"", name, "\"", NULL);
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "unknown encoding \"%s\"", name));
Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "ENCODING", name, NULL);
}
Tcl_DecrRefCount(fileNameObj);
@@ -1616,7 +1617,8 @@ LoadEncodingFile(
break;
}
if ((encoding == NULL) && (interp != NULL)) {
- Tcl_AppendResult(interp, "invalid encoding file \"", name, "\"", NULL);
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "invalid encoding file \"%s\"", name));
Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "ENCODING", name, NULL);
}
Tcl_Close(NULL, chan);
@@ -1872,9 +1874,9 @@ LoadTableEncoding(
* Read lines from the encoding until EOF.
*/
- for (Tcl_DStringSetLength(&lineString, 0);
+ for (TclDStringClear(&lineString);
(len = Tcl_Gets(chan, &lineString)) >= 0;
- Tcl_DStringSetLength(&lineString, 0)) {
+ TclDStringClear(&lineString)) {
const unsigned char *p;
int to, from;
diff --git a/generic/tclEnsemble.c b/generic/tclEnsemble.c
index 1e1a901..b76c603 100644
--- a/generic/tclEnsemble.c
+++ b/generic/tclEnsemble.c
@@ -17,6 +17,7 @@
* Declarations for functions local to this file:
*/
+static inline Tcl_Obj * NewNsObj(Tcl_Namespace *namespacePtr);
static inline int EnsembleUnknownCallback(Tcl_Interp *interp,
EnsembleConfig *ensemblePtr, int objc,
Tcl_Obj *const objv[], Tcl_Obj **prefixObjPtr);
@@ -78,6 +79,19 @@ const Tcl_ObjType tclEnsembleCmdType = {
NULL /* setFromAnyProc */
};
+static inline Tcl_Obj *
+NewNsObj(
+ Tcl_Namespace *namespacePtr)
+{
+ register Namespace *nsPtr = (Namespace *) namespacePtr;
+
+ if (namespacePtr == TclGetGlobalNamespace(nsPtr->interp)) {
+ return Tcl_NewStringObj("::", 2);
+ } else {
+ return Tcl_NewStringObj(nsPtr->fullName, -1);
+ }
+}
+
/*
*----------------------------------------------------------------------
*
@@ -116,9 +130,10 @@ TclNamespaceEnsembleCmd(
if (nsPtr == NULL || nsPtr->flags & NS_DYING) {
if (!Tcl_InterpDeleted(interp)) {
- Tcl_AppendResult(interp,
+ Tcl_SetObjResult(interp, Tcl_NewStringObj(
"tried to manipulate ensemble of deleted namespace",
- NULL);
+ -1));
+ Tcl_SetErrorCode(interp, "TCL", "ENSEMBLE", "DEAD", NULL);
}
return TCL_ERROR;
}
@@ -235,9 +250,11 @@ TclNamespaceEnsembleCmd(
return TCL_ERROR;
}
if (len < 1) {
- Tcl_SetResult(interp,
+ Tcl_SetObjResult(interp, Tcl_NewStringObj(
"ensemble subcommand implementations "
- "must be non-empty lists", TCL_STATIC);
+ "must be non-empty lists", -1));
+ Tcl_SetErrorCode(interp, "TCL", "ENSEMBLE",
+ "EMPTY_TARGET", NULL);
Tcl_DictObjDone(&search);
if (patchedDict) {
Tcl_DecrRefCount(patchedDict);
@@ -250,7 +267,7 @@ TclNamespaceEnsembleCmd(
cmd = TclGetString(listv[0]);
if (!(cmd[0] == ':' && cmd[1] == ':')) {
Tcl_Obj *newList = Tcl_NewListObj(len, listv);
- Tcl_Obj *newCmd = Tcl_NewStringObj(nsPtr->fullName,-1);
+ Tcl_Obj *newCmd = NewNsObj((Tcl_Namespace *) nsPtr);
if (nsPtr->parentPtr) {
Tcl_AppendStringsToObj(newCmd, "::", NULL);
@@ -370,8 +387,7 @@ TclNamespaceEnsembleCmd(
case CONF_NAMESPACE:
namespacePtr = NULL; /* silence gcc 4 warning */
Tcl_GetEnsembleNamespace(NULL, token, &namespacePtr);
- Tcl_SetResult(interp, ((Namespace *) namespacePtr)->fullName,
- TCL_VOLATILE);
+ Tcl_SetObjResult(interp, NewNsObj(namespacePtr));
break;
case CONF_PREFIX: {
int flags = 0; /* silence gcc 4 warning */
@@ -411,9 +427,7 @@ TclNamespaceEnsembleCmd(
-1));
namespacePtr = NULL; /* silence gcc 4 warning */
Tcl_GetEnsembleNamespace(NULL, token, &namespacePtr);
- Tcl_ListObjAppendElement(NULL, resultObj,
- Tcl_NewStringObj(((Namespace *) namespacePtr)->fullName,
- -1));
+ Tcl_ListObjAppendElement(NULL, resultObj, NewNsObj(namespacePtr));
/* -parameters option */
Tcl_ListObjAppendElement(NULL, resultObj,
@@ -515,9 +529,11 @@ TclNamespaceEnsembleCmd(
goto freeMapAndError;
}
if (len < 1) {
- Tcl_SetResult(interp,
+ Tcl_SetObjResult(interp, Tcl_NewStringObj(
"ensemble subcommand implementations "
- "must be non-empty lists", TCL_STATIC);
+ "must be non-empty lists", -1));
+ Tcl_SetErrorCode(interp, "TCL", "ENSEMBLE",
+ "EMPTY_TARGET", NULL);
Tcl_DictObjDone(&search);
if (patchedDict) {
Tcl_DecrRefCount(patchedDict);
@@ -527,8 +543,7 @@ TclNamespaceEnsembleCmd(
cmd = TclGetString(listv[0]);
if (!(cmd[0] == ':' && cmd[1] == ':')) {
Tcl_Obj *newList = Tcl_DuplicateObj(listObj);
- Tcl_Obj *newCmd =
- Tcl_NewStringObj(nsPtr->fullName, -1);
+ Tcl_Obj *newCmd = NewNsObj((Tcl_Namespace*)nsPtr);
if (nsPtr->parentPtr) {
Tcl_AppendStringsToObj(newCmd, "::", NULL);
@@ -554,7 +569,9 @@ TclNamespaceEnsembleCmd(
continue;
}
case CONF_NAMESPACE:
- Tcl_AppendResult(interp, "option -namespace is read-only",
+ Tcl_SetObjResult(interp, Tcl_NewStringObj(
+ "option -namespace is read-only", -1));
+ Tcl_SetErrorCode(interp, "TCL", "ENSEMBLE", "READ_ONLY",
NULL);
goto freeMapAndError;
case CONF_PREFIX:
@@ -629,7 +646,7 @@ Tcl_CreateEnsemble(
*/
if (!(name[0] == ':' && name[1] == ':')) {
- nameObj = Tcl_NewStringObj(nsPtr->fullName, -1);
+ nameObj = NewNsObj((Tcl_Namespace *) nsPtr);
if (nsPtr->parentPtr == NULL) {
Tcl_AppendStringsToObj(nameObj, name, NULL);
} else {
@@ -702,7 +719,9 @@ Tcl_SetEnsembleSubcommandList(
Tcl_Obj *oldList;
if (cmdPtr->objProc != NsEnsembleImplementationCmd) {
- Tcl_AppendResult(interp, "command is not an ensemble", NULL);
+ Tcl_SetObjResult(interp, Tcl_NewStringObj(
+ "command is not an ensemble", -1));
+ Tcl_SetErrorCode(interp, "TCL", "ENSEMBLE", "NOT_ENSEMBLE", NULL);
return TCL_ERROR;
}
if (subcmdList != NULL) {
@@ -776,7 +795,9 @@ Tcl_SetEnsembleParameterList(
int length;
if (cmdPtr->objProc != NsEnsembleImplementationCmd) {
- Tcl_AppendResult(interp, "command is not an ensemble", NULL);
+ Tcl_SetObjResult(interp, Tcl_NewStringObj(
+ "command is not an ensemble", -1));
+ Tcl_SetErrorCode(interp, "TCL", "ENSEMBLE", "NOT_ENSEMBLE", NULL);
return TCL_ERROR;
}
if (paramList == NULL) {
@@ -850,7 +871,9 @@ Tcl_SetEnsembleMappingDict(
Tcl_Obj *oldDict;
if (cmdPtr->objProc != NsEnsembleImplementationCmd) {
- Tcl_AppendResult(interp, "command is not an ensemble", NULL);
+ Tcl_SetObjResult(interp, Tcl_NewStringObj(
+ "command is not an ensemble", -1));
+ Tcl_SetErrorCode(interp, "TCL", "ENSEMBLE", "NOT_ENSEMBLE", NULL);
return TCL_ERROR;
}
if (mapDict != NULL) {
@@ -873,9 +896,11 @@ Tcl_SetEnsembleMappingDict(
}
bytes = TclGetString(cmdObjPtr);
if (bytes[0] != ':' || bytes[1] != ':') {
- Tcl_AppendResult(interp,
+ Tcl_SetObjResult(interp, Tcl_NewStringObj(
"ensemble target is not a fully-qualified command",
- NULL);
+ -1));
+ Tcl_SetErrorCode(interp, "TCL", "ENSEMBLE",
+ "UNQUALIFIED_TARGET", NULL);
Tcl_DictObjDone(&search);
return TCL_ERROR;
}
@@ -945,7 +970,9 @@ Tcl_SetEnsembleUnknownHandler(
Tcl_Obj *oldList;
if (cmdPtr->objProc != NsEnsembleImplementationCmd) {
- Tcl_AppendResult(interp, "command is not an ensemble", NULL);
+ Tcl_SetObjResult(interp, Tcl_NewStringObj(
+ "command is not an ensemble", -1));
+ Tcl_SetErrorCode(interp, "TCL", "ENSEMBLE", "NOT_ENSEMBLE", NULL);
return TCL_ERROR;
}
if (unknownList != NULL) {
@@ -1009,7 +1036,9 @@ Tcl_SetEnsembleFlags(
int wasCompiled;
if (cmdPtr->objProc != NsEnsembleImplementationCmd) {
- Tcl_AppendResult(interp, "command is not an ensemble", NULL);
+ Tcl_SetObjResult(interp, Tcl_NewStringObj(
+ "command is not an ensemble", -1));
+ Tcl_SetErrorCode(interp, "TCL", "ENSEMBLE", "NOT_ENSEMBLE", NULL);
return TCL_ERROR;
}
@@ -1084,7 +1113,9 @@ Tcl_GetEnsembleSubcommandList(
if (cmdPtr->objProc != NsEnsembleImplementationCmd) {
if (interp != NULL) {
- Tcl_AppendResult(interp, "command is not an ensemble", NULL);
+ Tcl_SetObjResult(interp, Tcl_NewStringObj(
+ "command is not an ensemble", -1));
+ Tcl_SetErrorCode(interp, "TCL", "ENSEMBLE", "NOT_ENSEMBLE", NULL);
}
return TCL_ERROR;
}
@@ -1124,7 +1155,9 @@ Tcl_GetEnsembleParameterList(
if (cmdPtr->objProc != NsEnsembleImplementationCmd) {
if (interp != NULL) {
- Tcl_AppendResult(interp, "command is not an ensemble", NULL);
+ Tcl_SetObjResult(interp, Tcl_NewStringObj(
+ "command is not an ensemble", -1));
+ Tcl_SetErrorCode(interp, "TCL", "ENSEMBLE", "NOT_ENSEMBLE", NULL);
}
return TCL_ERROR;
}
@@ -1164,7 +1197,9 @@ Tcl_GetEnsembleMappingDict(
if (cmdPtr->objProc != NsEnsembleImplementationCmd) {
if (interp != NULL) {
- Tcl_AppendResult(interp, "command is not an ensemble", NULL);
+ Tcl_SetObjResult(interp, Tcl_NewStringObj(
+ "command is not an ensemble", -1));
+ Tcl_SetErrorCode(interp, "TCL", "ENSEMBLE", "NOT_ENSEMBLE", NULL);
}
return TCL_ERROR;
}
@@ -1203,7 +1238,9 @@ Tcl_GetEnsembleUnknownHandler(
if (cmdPtr->objProc != NsEnsembleImplementationCmd) {
if (interp != NULL) {
- Tcl_AppendResult(interp, "command is not an ensemble", NULL);
+ Tcl_SetObjResult(interp, Tcl_NewStringObj(
+ "command is not an ensemble", -1));
+ Tcl_SetErrorCode(interp, "TCL", "ENSEMBLE", "NOT_ENSEMBLE", NULL);
}
return TCL_ERROR;
}
@@ -1242,7 +1279,9 @@ Tcl_GetEnsembleFlags(
if (cmdPtr->objProc != NsEnsembleImplementationCmd) {
if (interp != NULL) {
- Tcl_AppendResult(interp, "command is not an ensemble", NULL);
+ Tcl_SetObjResult(interp, Tcl_NewStringObj(
+ "command is not an ensemble", -1));
+ Tcl_SetErrorCode(interp, "TCL", "ENSEMBLE", "NOT_ENSEMBLE", NULL);
}
return TCL_ERROR;
}
@@ -1281,7 +1320,9 @@ Tcl_GetEnsembleNamespace(
if (cmdPtr->objProc != NsEnsembleImplementationCmd) {
if (interp != NULL) {
- Tcl_AppendResult(interp, "command is not an ensemble", NULL);
+ Tcl_SetObjResult(interp, Tcl_NewStringObj(
+ "command is not an ensemble", -1));
+ Tcl_SetErrorCode(interp, "TCL", "ENSEMBLE", "NOT_ENSEMBLE", NULL);
}
return TCL_ERROR;
}
@@ -1337,8 +1378,9 @@ Tcl_FindEnsemble(
if (cmdPtr == NULL || cmdPtr->objProc != NsEnsembleImplementationCmd){
if (flags & TCL_LEAVE_ERR_MSG) {
- Tcl_AppendResult(interp, "\"", TclGetString(cmdNameObj),
- "\" is not an ensemble command", NULL);
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "\"%s\" is not an ensemble command",
+ TclGetString(cmdNameObj)));
Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "ENSEMBLE",
TclGetString(cmdNameObj), NULL);
}
@@ -1425,9 +1467,9 @@ TclMakeEnsemble(
Tcl_DStringInit(&buf);
Tcl_DStringInit(&hiddenBuf);
- Tcl_DStringAppend(&hiddenBuf, "tcl:", -1);
+ TclDStringAppendLiteral(&hiddenBuf, "tcl:");
Tcl_DStringAppend(&hiddenBuf, name, -1);
- Tcl_DStringAppend(&hiddenBuf, ":", -1);
+ TclDStringAppendLiteral(&hiddenBuf, ":");
hiddenLen = Tcl_DStringLength(&hiddenBuf);
if (name[0] == ':' && name[1] == ':') {
/*
@@ -1443,14 +1485,14 @@ TclMakeEnsemble(
* multi-word list differently to a single word.
*/
- Tcl_DStringAppend(&buf, "::tcl", -1);
+ TclDStringAppendLiteral(&buf, "::tcl");
if (Tcl_SplitList(NULL, name, &nameCount, &nameParts) != TCL_OK) {
Tcl_Panic("invalid ensemble name '%s'", name);
}
for (i = 0; i < nameCount; ++i) {
- Tcl_DStringAppend(&buf, "::", 2);
+ TclDStringAppendLiteral(&buf, "::");
Tcl_DStringAppend(&buf, nameParts[i], -1);
}
}
@@ -1485,7 +1527,7 @@ TclMakeEnsemble(
Tcl_Obj *mapDict, *fromObj, *toObj;
Command *cmdPtr;
- Tcl_DStringAppend(&buf, "::", 2);
+ TclDStringAppendLiteral(&buf, "::");
TclNewObj(mapDict);
for (i=0 ; map[i].name != NULL ; i++) {
fromObj = Tcl_NewStringObj(map[i].name, -1);
@@ -1591,6 +1633,7 @@ NsEnsembleImplementationCmdNR(
* specified but not yet cached command
* names. */
int reparseCount = 0; /* Number of reparses. */
+ Tcl_Obj *errorObj; /* Used for building error messages. */
/*
* Must recheck objc, since numParameters might have changed. Cf. test
@@ -1615,10 +1658,10 @@ NsEnsembleImplementationCmdNR(
Tcl_Panic("List of ensemble parameters is not a list");
}
for (; len>0; len--,elemPtrs++) {
- Tcl_DStringAppend(&buf, Tcl_GetString(*elemPtrs), -1);
- Tcl_DStringAppend(&buf, " ", -1);
+ TclDStringAppendObj(&buf, *elemPtrs);
+ TclDStringAppendLiteral(&buf, " ");
}
- Tcl_DStringAppend(&buf, "subcommand ?arg ...?", -1);
+ TclDStringAppendLiteral(&buf, "subcommand ?arg ...?");
Tcl_WrongNumArgs(interp, 1, objv, Tcl_DStringValue(&buf));
Tcl_DStringFree(&buf);
@@ -1631,8 +1674,9 @@ NsEnsembleImplementationCmdNR(
*/
if (!Tcl_InterpDeleted(interp)) {
- Tcl_AppendResult(interp,
- "ensemble activated for deleted namespace", NULL);
+ Tcl_SetObjResult(interp, Tcl_NewStringObj(
+ "ensemble activated for deleted namespace", -1));
+ Tcl_SetErrorCode(interp, "TCL", "ENSEMBLE", "DEAD", NULL);
}
return TCL_ERROR;
}
@@ -1880,35 +1924,34 @@ NsEnsembleImplementationCmdNR(
*/
Tcl_ResetResult(interp);
- Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "ENSEMBLE",
+ Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "SUBCOMMAND",
TclGetString(objv[1+ensemblePtr->numParameters]), NULL);
if (ensemblePtr->subcommandTable.numEntries == 0) {
- Tcl_AppendResult(interp, "unknown subcommand \"",
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "unknown subcommand \"%s\": namespace %s does not"
+ " export any commands",
TclGetString(objv[1+ensemblePtr->numParameters]),
- "\": namespace ", ensemblePtr->nsPtr->fullName,
- " does not export any commands", NULL);
+ ensemblePtr->nsPtr->fullName));
Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "SUBCOMMAND",
TclGetString(objv[1+ensemblePtr->numParameters]), NULL);
return TCL_ERROR;
}
- Tcl_AppendResult(interp, "unknown ",
- (ensemblePtr->flags & TCL_ENSEMBLE_PREFIX ? "or ambiguous " : ""),
- "subcommand \"", TclGetString(objv[1+ensemblePtr->numParameters]),
- "\": must be ", NULL);
+ errorObj = Tcl_ObjPrintf("unknown%s subcommand \"%s\": must be ",
+ (ensemblePtr->flags & TCL_ENSEMBLE_PREFIX ? " or ambiguous" : ""),
+ TclGetString(objv[1+ensemblePtr->numParameters]));
if (ensemblePtr->subcommandTable.numEntries == 1) {
- Tcl_AppendResult(interp, ensemblePtr->subcommandArrayPtr[0], NULL);
+ Tcl_AppendToObj(errorObj, ensemblePtr->subcommandArrayPtr[0], -1);
} else {
int i;
for (i=0 ; i<ensemblePtr->subcommandTable.numEntries-1 ; i++) {
- Tcl_AppendResult(interp,
- ensemblePtr->subcommandArrayPtr[i], ", ", NULL);
+ Tcl_AppendToObj(errorObj, ensemblePtr->subcommandArrayPtr[i], -1);
+ Tcl_AppendToObj(errorObj, ", ", 2);
}
- Tcl_AppendResult(interp, "or ",
- ensemblePtr->subcommandArrayPtr[i], NULL);
+ Tcl_AppendPrintfToObj(errorObj, "or %s",
+ ensemblePtr->subcommandArrayPtr[i]);
}
- Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "SUBCOMMAND",
- TclGetString(objv[1+ensemblePtr->numParameters]), NULL);
+ Tcl_SetObjResult(interp, errorObj);
return TCL_ERROR;
}
@@ -2034,7 +2077,6 @@ EnsembleUnknownCallback(
{
int paramc, i, result, prefixObjc;
Tcl_Obj **paramv, *unknownCmd, *ensObj;
- char buf[TCL_INTEGER_SPACE];
/*
* Create the unknown command callback to determine what to do.
@@ -2061,9 +2103,12 @@ EnsembleUnknownCallback(
((Interp *) interp)->evalFlags |= TCL_EVAL_REDIRECT;
result = Tcl_EvalObjv(interp, paramc, paramv, 0);
if ((result == TCL_OK) && (ensemblePtr->flags & ENSEMBLE_DEAD)) {
- Tcl_SetResult(interp,
- "unknown subcommand handler deleted its ensemble",
- TCL_STATIC);
+ if (!Tcl_InterpDeleted(interp)) {
+ Tcl_SetObjResult(interp, Tcl_NewStringObj(
+ "unknown subcommand handler deleted its ensemble", -1));
+ Tcl_SetErrorCode(interp, "TCL", "ENSEMBLE", "UNKNOWN_DELETED",
+ NULL);
+ }
result = TCL_ERROR;
}
Tcl_Release(ensemblePtr);
@@ -2112,26 +2157,26 @@ EnsembleUnknownCallback(
if (!Tcl_InterpDeleted(interp)) {
if (result != TCL_ERROR) {
Tcl_ResetResult(interp);
- Tcl_SetResult(interp,
- "unknown subcommand handler returned bad code: ",
- TCL_STATIC);
+ Tcl_SetObjResult(interp, Tcl_NewStringObj(
+ "unknown subcommand handler returned bad code: ", -1));
switch (result) {
case TCL_RETURN:
- Tcl_AppendResult(interp, "return", NULL);
+ Tcl_AppendToObj(Tcl_GetObjResult(interp), "return", -1);
break;
case TCL_BREAK:
- Tcl_AppendResult(interp, "break", NULL);
+ Tcl_AppendToObj(Tcl_GetObjResult(interp), "break", -1);
break;
case TCL_CONTINUE:
- Tcl_AppendResult(interp, "continue", NULL);
+ Tcl_AppendToObj(Tcl_GetObjResult(interp), "continue", -1);
break;
default:
- sprintf(buf, "%d", result);
- Tcl_AppendResult(interp, buf, NULL);
+ Tcl_AppendPrintfToObj(Tcl_GetObjResult(interp), "%d", result);
}
Tcl_AddErrorInfo(interp, "\n result of "
"ensemble unknown subcommand handler: ");
Tcl_AddErrorInfo(interp, TclGetString(unknownCmd));
+ Tcl_SetErrorCode(interp, "TCL", "ENSEMBLE", "UNKNOWN_RESULT",
+ NULL);
} else {
Tcl_AddErrorInfo(interp,
"\n (ensemble unknown subcommand handler)");
@@ -2392,7 +2437,7 @@ BuildEnsembleConfig(
* the programmer's responsibility (or [::unknown] of course).
*/
- cmdObj = Tcl_NewStringObj(ensemblePtr->nsPtr->fullName, -1);
+ cmdObj = NewNsObj((Tcl_Namespace *) ensemblePtr->nsPtr);
if (ensemblePtr->nsPtr->parentPtr != NULL) {
Tcl_AppendStringsToObj(cmdObj, "::", name, NULL);
} else {
diff --git a/generic/tclEnv.c b/generic/tclEnv.c
index 72d6fba..b5ae6ea 100644
--- a/generic/tclEnv.c
+++ b/generic/tclEnv.c
@@ -698,6 +698,7 @@ TclFinalizeEnvironment(void)
* fork) and the Windows environment (in case the application TCL code calls
* exec, which calls the Windows CreateProcess function).
*/
+DLLIMPORT extern void __stdcall SetEnvironmentVariableA(const char*, const char *);
static void
TclCygwinPutenv(
@@ -771,9 +772,9 @@ TclCygwinPutenv(
} else {
int size;
- size = cygwin_posix_to_win32_path_list_buf_size(value);
+ size = cygwin_conv_path_list(0, value, NULL, 0);
buf = alloca(size + 1);
- cygwin_posix_to_win32_path_list(value, buf);
+ cygwin_conv_path_list(0, value, buf, size);
}
SetEnvironmentVariableA(name, buf);
diff --git a/generic/tclEvent.c b/generic/tclEvent.c
index e65862c..0b585b6 100644
--- a/generic/tclEvent.c
+++ b/generic/tclEvent.c
@@ -1416,7 +1416,7 @@ Tcl_VwaitObjCmd(
}
if (Tcl_LimitExceeded(interp)) {
Tcl_ResetResult(interp);
- Tcl_AppendResult(interp, "limit exceeded", NULL);
+ Tcl_SetObjResult(interp, Tcl_NewStringObj("limit exceeded", -1));
break;
}
}
@@ -1426,8 +1426,9 @@ Tcl_VwaitObjCmd(
if (!foundEvent) {
Tcl_ResetResult(interp);
- Tcl_AppendResult(interp, "can't wait for variable \"", nameString,
- "\": would wait forever", NULL);
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "can't wait for variable \"%s\": would wait forever",
+ nameString));
Tcl_SetErrorCode(interp, "TCL", "EVENT", "NO_SOURCES", NULL);
return TCL_ERROR;
}
@@ -1519,7 +1520,7 @@ Tcl_UpdateObjCmd(
}
if (Tcl_LimitExceeded(interp)) {
Tcl_ResetResult(interp);
- Tcl_AppendResult(interp, "limit exceeded", NULL);
+ Tcl_SetObjResult(interp, Tcl_NewStringObj("limit exceeded", -1));
return TCL_ERROR;
}
}
diff --git a/generic/tclExecute.c b/generic/tclExecute.c
index 0c0de20..1041f65 100644
--- a/generic/tclExecute.c
+++ b/generic/tclExecute.c
@@ -4960,8 +4960,8 @@ TEBCresume(
case INST_RSHIFT:
if (l2 < 0) {
- Tcl_SetResult(interp, "negative shift argument",
- TCL_STATIC);
+ Tcl_SetObjResult(interp, Tcl_NewStringObj(
+ "negative shift argument", -1));
#if 0
DECACHE_STACK_INFO();
Tcl_SetErrorCode(interp, "ARITH", "DOMAIN",
@@ -5008,8 +5008,8 @@ TEBCresume(
case INST_LSHIFT:
if (l2 < 0) {
- Tcl_SetResult(interp, "negative shift argument",
- TCL_STATIC);
+ Tcl_SetObjResult(interp, Tcl_NewStringObj(
+ "negative shift argument", -1));
#if 0
DECACHE_STACK_INFO();
Tcl_SetErrorCode(interp, "ARITH", "DOMAIN",
@@ -5031,9 +5031,8 @@ TEBCresume(
* good place to draw the line.
*/
- Tcl_SetResult(interp,
- "integer value too large to represent",
- TCL_STATIC);
+ Tcl_SetObjResult(interp, Tcl_NewStringObj(
+ "integer value too large to represent", -1));
#if 0
DECACHE_STACK_INFO();
Tcl_SetErrorCode(interp, "ARITH", "IOVERFLOW",
@@ -5735,9 +5734,9 @@ TEBCresume(
NEXT_INST_V(5, opnd+1, 1);
}
DECACHE_STACK_INFO();
- Tcl_ResetResult(interp);
- Tcl_AppendResult(interp, "key \"", TclGetString(OBJ_AT_TOS),
- "\" not known in dictionary", NULL);
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "key \"%s\" not known in dictionary",
+ TclGetString(OBJ_AT_TOS)));
Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "DICT",
TclGetString(OBJ_AT_TOS), NULL);
CACHE_STACK_INFO();
@@ -6368,7 +6367,7 @@ TEBCresume(
divideByZero:
DECACHE_STACK_INFO();
- Tcl_SetResult(interp, "divide by zero", TCL_STATIC);
+ Tcl_SetObjResult(interp, Tcl_NewStringObj("divide by zero", -1));
Tcl_SetErrorCode(interp, "ARITH", "DIVZERO", "divide by zero", NULL);
CACHE_STACK_INFO();
goto gotError;
@@ -6380,8 +6379,8 @@ TEBCresume(
exponOfZero:
DECACHE_STACK_INFO();
- Tcl_SetResult(interp, "exponentiation of zero by negative power",
- TCL_STATIC);
+ Tcl_SetObjResult(interp, Tcl_NewStringObj(
+ "exponentiation of zero by negative power", -1));
Tcl_SetErrorCode(interp, "ARITH", "DOMAIN",
"exponentiation of zero by negative power", NULL);
CACHE_STACK_INFO();
@@ -6757,7 +6756,8 @@ ExecuteExtendedBinaryMathOp(
invalid = 0;
}
if (invalid) {
- Tcl_SetResult(interp, "negative shift argument", TCL_STATIC);
+ Tcl_SetObjResult(interp, Tcl_NewStringObj(
+ "negative shift argument", -1));
return GENERAL_ARITHMETIC_ERROR;
}
@@ -6787,8 +6787,8 @@ ExecuteExtendedBinaryMathOp(
* place to draw the line.
*/
- Tcl_SetResult(interp, "integer value too large to represent",
- TCL_STATIC);
+ Tcl_SetObjResult(interp, Tcl_NewStringObj(
+ "integer value too large to represent", -1));
return GENERAL_ARITHMETIC_ERROR;
}
shift = (int)(*((const long *)ptr2));
@@ -7189,7 +7189,8 @@ ExecuteExtendedBinaryMathOp(
*/
if (type2 != TCL_NUMBER_LONG) {
- Tcl_SetResult(interp, "exponent too large", TCL_STATIC);
+ Tcl_SetObjResult(interp, Tcl_NewStringObj(
+ "exponent too large", -1));
return GENERAL_ARITHMETIC_ERROR;
}
@@ -7427,7 +7428,8 @@ ExecuteExtendedBinaryMathOp(
Tcl_TakeBignumFromObj(NULL, value2Ptr, &big2);
if (big2.used > 1) {
mp_clear(&big2);
- Tcl_SetResult(interp, "exponent too large", TCL_STATIC);
+ Tcl_SetObjResult(interp, Tcl_NewStringObj(
+ "exponent too large", -1));
return GENERAL_ARITHMETIC_ERROR;
}
Tcl_TakeBignumFromObj(NULL, valuePtr, &big1);
diff --git a/generic/tclFCmd.c b/generic/tclFCmd.c
index a868fe3..032dda7 100644
--- a/generic/tclFCmd.c
+++ b/generic/tclFCmd.c
@@ -152,9 +152,9 @@ FileCopyRename(
if ((objc - i) > 2) {
errno = ENOTDIR;
Tcl_PosixError(interp);
- Tcl_AppendResult(interp, "error ",
- (copyFlag ? "copying" : "renaming"), ": target \"",
- TclGetString(target), "\" is not a directory", NULL);
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "error %s: target \"%s\" is not a directory",
+ (copyFlag?"copying":"renaming"), TclGetString(target)));
result = TCL_ERROR;
} else {
/*
@@ -304,8 +304,9 @@ TclFileMakeDirsCmd(
done:
if (errfile != NULL) {
- Tcl_AppendResult(interp, "can't create directory \"",
- TclGetString(errfile), "\": ", Tcl_PosixError(interp), NULL);
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "can't create directory \"%s\": %s",
+ TclGetString(errfile), Tcl_PosixError(interp)));
result = TCL_ERROR;
}
if (split != NULL) {
@@ -384,9 +385,9 @@ TclFileDeleteCmd(
result = Tcl_FSRemoveDirectory(objv[i], force, &errorBuffer);
if (result != TCL_OK) {
if ((force == 0) && (errno == EEXIST)) {
- Tcl_AppendResult(interp, "error deleting \"",
- TclGetString(objv[i]), "\": directory not empty",
- NULL);
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "error deleting \"%s\": directory not empty",
+ TclGetString(objv[i])));
Tcl_PosixError(interp);
goto done;
}
@@ -426,12 +427,13 @@ TclFileDeleteCmd(
* We try to accomodate poor error results from our Tcl_FS calls.
*/
- Tcl_AppendResult(interp, "error deleting unknown file: ",
- Tcl_PosixError(interp), NULL);
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "error deleting unknown file: %s",
+ Tcl_PosixError(interp)));
} else {
- Tcl_AppendResult(interp, "error deleting \"",
- TclGetString(errfile), "\": ", Tcl_PosixError(interp),
- NULL);
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "error deleting \"%s\": %s",
+ TclGetString(errfile), Tcl_PosixError(interp)));
}
}
@@ -540,17 +542,17 @@ CopyRenameOneFile(
if (S_ISDIR(sourceStatBuf.st_mode)
&& !S_ISDIR(targetStatBuf.st_mode)) {
errno = EISDIR;
- Tcl_AppendResult(interp, "can't overwrite file \"",
- TclGetString(target), "\" with directory \"",
- TclGetString(source), "\"", NULL);
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "can't overwrite file \"%s\" with directory \"%s\"",
+ TclGetString(target), TclGetString(source)));
goto done;
}
if (!S_ISDIR(sourceStatBuf.st_mode)
&& S_ISDIR(targetStatBuf.st_mode)) {
errno = EISDIR;
- Tcl_AppendResult(interp, "can't overwrite directory \"",
- TclGetString(target), "\" with file \"",
- TclGetString(source), "\"", NULL);
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "can't overwrite directory \"%s\" with file \"%s\"",
+ TclGetString(target), TclGetString(source)));
goto done;
}
@@ -581,10 +583,10 @@ CopyRenameOneFile(
}
if (errno == EINVAL) {
- Tcl_AppendResult(interp, "error renaming \"",
- TclGetString(source), "\" to \"", TclGetString(target),
- "\": trying to rename a volume or "
- "move a directory into itself", NULL);
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "error renaming \"%s\" to \"%s\": trying to rename a"
+ " volume or move a directory into itself",
+ TclGetString(source), TclGetString(target)));
goto done;
} else if (errno != EXDEV) {
errfile = target;
@@ -628,8 +630,9 @@ CopyRenameOneFile(
* Actual file doesn't exist.
*/
- Tcl_AppendResult(interp, "error copying \"", TclGetString(source),
- "\": the target of this link doesn't exist", NULL);
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "error copying \"%s\": the target of this link doesn't"
+ " exist", TclGetString(source)));
goto done;
} else {
int counter = 0;
@@ -764,23 +767,27 @@ CopyRenameOneFile(
}
}
if (result != TCL_OK) {
- Tcl_AppendResult(interp, "can't unlink \"", TclGetString(errfile),
- "\": ", Tcl_PosixError(interp), NULL);
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf("can't unlink \"%s\": %s",
+ TclGetString(errfile), Tcl_PosixError(interp)));
errfile = NULL;
}
}
done:
if (errfile != NULL) {
- Tcl_AppendResult(interp, "error ", (copyFlag ? "copying" : "renaming"),
- " \"", TclGetString(source), NULL);
+ Tcl_Obj *errorMsg = Tcl_ObjPrintf("error %s \"%s\"",
+ (copyFlag ? "copying" : "renaming"), TclGetString(source));
+
if (errfile != source) {
- Tcl_AppendResult(interp, "\" to \"", TclGetString(target), NULL);
+ Tcl_AppendPrintfToObj(errorMsg, " to \"%s\"",
+ TclGetString(target));
if (errfile != target) {
- Tcl_AppendResult(interp, "\": \"", TclGetString(errfile),NULL);
+ Tcl_AppendPrintfToObj(errorMsg, ": \"%s\"",
+ TclGetString(errfile));
}
}
- Tcl_AppendResult(interp, "\": ", Tcl_PosixError(interp), NULL);
+ Tcl_AppendPrintfToObj(errorMsg, ": %s", Tcl_PosixError(interp));
+ Tcl_SetObjResult(interp, errorMsg);
}
if (errorBuffer != NULL) {
Tcl_DecrRefCount(errorBuffer);
@@ -983,9 +990,10 @@ TclFileAttrsCmd(
* There was an error, probably that the filePtr is not
* accepted by any filesystem
*/
- Tcl_AppendResult(interp, "could not read \"",
- TclGetString(filePtr), "\": ", Tcl_PosixError(interp),
- NULL);
+
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "could not read \"%s\": %s",
+ TclGetString(filePtr), Tcl_PosixError(interp)));
}
return TCL_ERROR;
}
@@ -1071,9 +1079,9 @@ TclFileAttrsCmd(
Tcl_Obj *objPtr = NULL;
if (numObjStrings == 0) {
- Tcl_AppendResult(interp, "bad option \"", TclGetString(objv[0]),
- "\", there are no file attributes in this filesystem.",
- NULL);
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "bad option \"%s\", there are no file attributes in this"
+ " filesystem", TclGetString(objv[0])));
Tcl_SetErrorCode(interp, "TCL","OPERATION","FATTR","NONE", NULL);
goto end;
}
@@ -1098,9 +1106,9 @@ TclFileAttrsCmd(
int i, index;
if (numObjStrings == 0) {
- Tcl_AppendResult(interp, "bad option \"", TclGetString(objv[0]),
- "\", there are no file attributes in this filesystem.",
- NULL);
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "bad option \"%s\", there are no file attributes in this"
+ " filesystem", TclGetString(objv[0])));
Tcl_SetErrorCode(interp, "TCL","OPERATION","FATTR","NONE", NULL);
goto end;
}
@@ -1114,8 +1122,8 @@ TclFileAttrsCmd(
TclFreeIntRep(objv[i]);
}
if (i + 1 == objc) {
- Tcl_AppendResult(interp, "value for \"",
- TclGetString(objv[i]), "\" missing", NULL);
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "value for \"%s\" missing", TclGetString(objv[i])));
Tcl_SetErrorCode(interp, "TCL", "OPERATION", "FATTR",
"NOVALUE", NULL);
goto end;
@@ -1224,9 +1232,9 @@ TclFileLinkCmd(
*/
if (errno == EEXIST) {
- Tcl_AppendResult(interp, "could not create new link \"",
- TclGetString(objv[index]),
- "\": that path already exists", NULL);
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "could not create new link \"%s\": that path already"
+ " exists", TclGetString(objv[index])));
Tcl_PosixError(interp);
} else if (errno == ENOENT) {
/*
@@ -1244,23 +1252,23 @@ TclFileLinkCmd(
access = Tcl_FSAccess(dirPtr, F_OK);
Tcl_DecrRefCount(dirPtr);
if (access != 0) {
- Tcl_AppendResult(interp, "could not create new link \"",
- TclGetString(objv[index]),
- "\": no such file or directory", NULL);
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "could not create new link \"%s\": no such file"
+ " or directory", TclGetString(objv[index])));
Tcl_PosixError(interp);
} else {
- Tcl_AppendResult(interp, "could not create new link \"",
- TclGetString(objv[index]), "\": target \"",
- TclGetString(objv[index+1]), "\" doesn't exist",
- NULL);
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "could not create new link \"%s\": target \"%s\" "
+ "doesn't exist", TclGetString(objv[index]),
+ TclGetString(objv[index+1])));
errno = ENOENT;
Tcl_PosixError(interp);
}
} else {
- Tcl_AppendResult(interp, "could not create new link \"",
- TclGetString(objv[index]), "\" pointing to \"",
- TclGetString(objv[index+1]), "\": ",
- Tcl_PosixError(interp), NULL);
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "could not create new link \"%s\" pointing to \"%s\": %s",
+ TclGetString(objv[index]),
+ TclGetString(objv[index+1]), Tcl_PosixError(interp)));
}
return TCL_ERROR;
}
@@ -1275,9 +1283,9 @@ TclFileLinkCmd(
contents = Tcl_FSLink(objv[index], NULL, 0);
if (contents == NULL) {
- Tcl_AppendResult(interp, "could not read link \"",
- TclGetString(objv[index]), "\": ", Tcl_PosixError(interp),
- NULL);
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "could not read link \"%s\": %s",
+ TclGetString(objv[index]), Tcl_PosixError(interp)));
return TCL_ERROR;
}
}
@@ -1332,8 +1340,9 @@ TclFileReadLinkCmd(
contents = Tcl_FSLink(objv[1], NULL, 0);
if (contents == NULL) {
- Tcl_AppendResult(interp, "could not readlink \"",
- TclGetString(objv[1]), "\": ", Tcl_PosixError(interp), NULL);
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "could not read link \"%s\": %s",
+ TclGetString(objv[1]), Tcl_PosixError(interp)));
return TCL_ERROR;
}
Tcl_SetObjResult(interp, contents);
@@ -1487,8 +1496,8 @@ TclFileTemporaryCmd(
if (nameVarObj) {
TclDecrRefCount(nameObj);
}
- Tcl_AppendResult(interp, "can't create temporary file: ",
- Tcl_PosixError(interp), NULL);
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "can't create temporary file: %s", Tcl_PosixError(interp)));
return TCL_ERROR;
}
Tcl_RegisterChannel(interp, chan);
@@ -1499,7 +1508,7 @@ TclFileTemporaryCmd(
return TCL_ERROR;
}
}
- Tcl_AppendResult(interp, Tcl_GetChannelName(chan), NULL);
+ Tcl_SetObjResult(interp, Tcl_NewStringObj(Tcl_GetChannelName(chan), -1));
return TCL_OK;
}
diff --git a/generic/tclFileName.c b/generic/tclFileName.c
index b6b89dd..5d90351 100644
--- a/generic/tclFileName.c
+++ b/generic/tclFileName.c
@@ -72,9 +72,9 @@ SetResultLength(
{
Tcl_DStringSetLength(resultPtr, offset);
if (extended == 2) {
- Tcl_DStringAppend(resultPtr, "//?/UNC/", 8);
+ TclDStringAppendLiteral(resultPtr, "//?/UNC/");
} else if (extended == 1) {
- Tcl_DStringAppend(resultPtr, "//?/", 4);
+ TclDStringAppendLiteral(resultPtr, "//?/");
}
}
@@ -131,7 +131,7 @@ ExtractWinRoot(
if (path[1] != '/' && path[1] != '\\') {
SetResultLength(resultPtr, offset, extended);
*typePtr = TCL_PATH_VOLUME_RELATIVE;
- Tcl_DStringAppend(resultPtr, "/", 1);
+ TclDStringAppendLiteral(resultPtr, "/");
return &path[1];
}
host = &path[2];
@@ -161,7 +161,7 @@ ExtractWinRoot(
*/
*typePtr = TCL_PATH_VOLUME_RELATIVE;
- Tcl_DStringAppend(resultPtr, "/", 1);
+ TclDStringAppendLiteral(resultPtr, "/");
return &path[2];
}
SetResultLength(resultPtr, offset, extended);
@@ -180,9 +180,9 @@ ExtractWinRoot(
break;
}
}
- Tcl_DStringAppend(resultPtr, "//", 2);
+ TclDStringAppendLiteral(resultPtr, "//");
Tcl_DStringAppend(resultPtr, host, hlen);
- Tcl_DStringAppend(resultPtr, "/", 1);
+ TclDStringAppendLiteral(resultPtr, "/");
Tcl_DStringAppend(resultPtr, share, slen);
tail = &share[slen];
@@ -221,7 +221,7 @@ ExtractWinRoot(
*typePtr = TCL_PATH_ABSOLUTE;
Tcl_DStringAppend(resultPtr, path, 2);
- Tcl_DStringAppend(resultPtr, "/", 1);
+ TclDStringAppendLiteral(resultPtr, "/");
return tail;
}
@@ -424,9 +424,17 @@ TclpGetNativePathType(
}
#endif
if (path[0] == '/') {
+#ifdef __CYGWIN__
+ /*
+ * Check for Cygwin // network path prefix
+ */
+ if (path[1] == '/') {
+ path++;
+ }
+#endif
if (driveNameLengthPtr != NULL) {
/*
- * We need this addition in case the QNX code was used.
+ * We need this addition in case the QNX or Cygwin code was used.
*/
*driveNameLengthPtr = (1 + path - origPath);
@@ -445,8 +453,7 @@ TclpGetNativePathType(
if ((rootEnd != path) && (driveNameLengthPtr != NULL)) {
*driveNameLengthPtr = rootEnd - path;
if (driveNameRef != NULL) {
- *driveNameRef = Tcl_NewStringObj(Tcl_DStringValue(&ds),
- Tcl_DStringLength(&ds));
+ *driveNameRef = TclDStringToObj(&ds);
Tcl_IncrRefCount(*driveNameRef);
}
}
@@ -654,11 +661,20 @@ SplitUnixPath(
}
#endif
- if (path[0] == '/') {
- Tcl_ListObjAppendElement(NULL, result, Tcl_NewStringObj("/",1));
- p = path+1;
- } else {
- p = path;
+ p = path;
+ if (*p == '/') {
+ Tcl_Obj *rootElt = Tcl_NewStringObj("/", 1);
+ p++;
+#ifdef __CYGWIN__
+ /*
+ * Check for Cygwin // network path prefix
+ */
+ if (*p == '/') {
+ Tcl_AppendToObj(rootElt, "/", 1);
+ p++;
+ }
+#endif
+ Tcl_ListObjAppendElement(NULL, result, rootElt);
}
/*
@@ -724,8 +740,7 @@ SplitWinPath(
*/
if (p != path) {
- Tcl_ListObjAppendElement(NULL, result, Tcl_NewStringObj(
- Tcl_DStringValue(&buf), Tcl_DStringLength(&buf)));
+ Tcl_ListObjAppendElement(NULL, result, TclDStringToObj(&buf));
}
Tcl_DStringFree(&buf);
@@ -865,7 +880,7 @@ TclpNativeJoinPath(
if (length > 0 && (start[length-1] != '/')) {
Tcl_AppendToObj(prefix, "/", 1);
- length++;
+ Tcl_GetStringFromObj(prefix, &length);
}
needsSep = 0;
@@ -901,7 +916,7 @@ TclpNativeJoinPath(
if ((length > 0) &&
(start[length-1] != '/') && (start[length-1] != ':')) {
Tcl_AppendToObj(prefix, "/", 1);
- length++;
+ Tcl_GetStringFromObj(prefix, &length);
}
needsSep = 0;
@@ -1042,7 +1057,7 @@ Tcl_TranslateFileName(
}
Tcl_DStringInit(bufferPtr);
- Tcl_DStringAppend(bufferPtr, Tcl_GetString(transPtr), -1);
+ TclDStringAppendObj(bufferPtr, transPtr);
Tcl_DecrRefCount(path);
Tcl_DecrRefCount(transPtr);
@@ -1159,9 +1174,10 @@ DoTildeSubst(
dir = TclGetEnv("HOME", &dirString);
if (dir == NULL) {
if (interp) {
- Tcl_ResetResult(interp);
- Tcl_AppendResult(interp, "couldn't find HOME environment "
- "variable to expand path", NULL);
+ Tcl_SetObjResult(interp, Tcl_NewStringObj(
+ "couldn't find HOME environment "
+ "variable to expand path", -1));
+ Tcl_SetErrorCode(interp, "TCL", "FILENAME", "NO_HOME", NULL);
}
return NULL;
}
@@ -1170,8 +1186,9 @@ DoTildeSubst(
} else if (TclpGetUserHome(user, resultPtr) == NULL) {
if (interp) {
Tcl_ResetResult(interp);
- Tcl_AppendResult(interp, "user \"", user, "\" doesn't exist",
- NULL);
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "user \"%s\" doesn't exist", user));
+ Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "USER", user, NULL);
}
return NULL;
}
@@ -1314,9 +1331,9 @@ Tcl_GlobObjCmd(
endOfForLoop:
if ((globFlags & TCL_GLOBMODE_TAILS) && (pathOrDir == NULL)) {
- Tcl_AppendResult(interp,
+ Tcl_SetObjResult(interp, Tcl_NewStringObj(
"\"-tails\" must be used with either "
- "\"-directory\" or \"-path\"", NULL);
+ "\"-directory\" or \"-path\"", -1));
Tcl_SetErrorCode(interp, "TCL", "OPERATION", "GLOB",
"BADOPTIONCOMBINATION", NULL);
return TCL_ERROR;
@@ -1398,7 +1415,7 @@ Tcl_GlobObjCmd(
search = Tcl_DStringValue(&pref);
while ((find = (strpbrk(search, "\\[]*?{}"))) != NULL) {
Tcl_DStringAppend(&prefix, search, find-search);
- Tcl_DStringAppend(&prefix, "\\", 1);
+ TclDStringAppendLiteral(&prefix, "\\");
Tcl_DStringAppend(&prefix, find, 1);
search = find+1;
if (*search == '\0') {
@@ -1560,8 +1577,7 @@ Tcl_GlobObjCmd(
Tcl_DStringInit(&prefix);
}
for (i = 0; i < objc; i++) {
- string = Tcl_GetStringFromObj(objv[i], &length);
- Tcl_DStringAppend(&prefix, string, length);
+ TclDStringAppendObj(&prefix, objv[i]);
if (i != objc -1) {
Tcl_DStringAppend(&prefix, separators, 1);
}
@@ -1577,11 +1593,9 @@ Tcl_GlobObjCmd(
for (i = 0; i < objc; i++) {
Tcl_DStringInit(&str);
if (dir == PATH_GENERAL) {
- Tcl_DStringAppend(&str, Tcl_DStringValue(&prefix),
- Tcl_DStringLength(&prefix));
+ TclDStringAppendDString(&str, &prefix);
}
- string = Tcl_GetStringFromObj(objv[i], &length);
- Tcl_DStringAppend(&str, string, length);
+ TclDStringAppendObj(&str, objv[i]);
if (TclGlob(interp, Tcl_DStringValue(&str), pathOrDir, globFlags,
globTypes) != TCL_OK) {
result = TCL_ERROR;
@@ -1613,20 +1627,23 @@ Tcl_GlobObjCmd(
}
if (length == 0) {
- Tcl_AppendResult(interp, "no files matched glob pattern",
- (join || (objc == 1)) ? " \"" : "s \"", NULL);
+ Tcl_Obj *errorMsg =
+ Tcl_ObjPrintf("no files matched glob pattern%s \"",
+ (join || (objc == 1)) ? "" : "s");
+
if (join) {
- Tcl_AppendResult(interp, Tcl_DStringValue(&prefix), NULL);
+ Tcl_AppendToObj(errorMsg, Tcl_DStringValue(&prefix), -1);
} else {
const char *sep = "";
for (i = 0; i < objc; i++) {
- string = Tcl_GetString(objv[i]);
- Tcl_AppendResult(interp, sep, string, NULL);
+ Tcl_AppendPrintfToObj(errorMsg, "%s%s",
+ sep, Tcl_GetString(objv[i]));
sep = " ";
}
}
- Tcl_AppendResult(interp, "\"", NULL);
+ Tcl_AppendToObj(errorMsg, "\"", -1);
+ Tcl_SetObjResult(interp, errorMsg);
Tcl_SetErrorCode(interp, "TCL", "OPERATION", "GLOB", "NOMATCH",
NULL);
result = TCL_ERROR;
@@ -1751,14 +1768,12 @@ TclGlob(
if (head != Tcl_DStringValue(&buffer)) {
Tcl_DStringAppend(&buffer, head, -1);
}
- pathPrefix = Tcl_NewStringObj(Tcl_DStringValue(&buffer),
- Tcl_DStringLength(&buffer));
+ pathPrefix = TclDStringToObj(&buffer);
Tcl_IncrRefCount(pathPrefix);
globFlags |= TCL_GLOBMODE_DIR;
if (c != '\0') {
tail++;
}
- Tcl_DStringFree(&buffer);
} else {
tail = pattern;
}
@@ -2196,15 +2211,15 @@ DoGlob(
closeBrace = p;
break;
}
- Tcl_SetResult(interp, "unmatched open-brace in file name",
- TCL_STATIC);
+ Tcl_SetObjResult(interp, Tcl_NewStringObj(
+ "unmatched open-brace in file name", -1));
Tcl_SetErrorCode(interp, "TCL", "OPERATION", "GLOB", "BALANCE",
NULL);
return TCL_ERROR;
} else if (*p == '}') {
- Tcl_SetResult(interp, "unmatched close-brace in file name",
- TCL_STATIC);
+ Tcl_SetObjResult(interp, Tcl_NewStringObj(
+ "unmatched close-brace in file name", -1));
Tcl_SetErrorCode(interp, "TCL", "OPERATION", "GLOB", "BALANCE",
NULL);
return TCL_ERROR;
@@ -2388,9 +2403,9 @@ DoGlob(
if (length == 0 && (Tcl_DStringLength(&append) == 0)) {
if (((*name == '\\') && (name[1] == '/' ||
name[1] == '\\')) || (*name == '/')) {
- Tcl_DStringAppend(&append, "/", 1);
+ TclDStringAppendLiteral(&append, "/");
} else {
- Tcl_DStringAppend(&append, ".", 1);
+ TclDStringAppendLiteral(&append, ".");
}
}
@@ -2399,22 +2414,11 @@ DoGlob(
case TCL_PLATFORM_UNIX:
if (length == 0 && (Tcl_DStringLength(&append) == 0)) {
if ((*name == '\\' && name[1] == '/') || (*name == '/')) {
- Tcl_DStringAppend(&append, "/", 1);
+ TclDStringAppendLiteral(&append, "/");
} else {
- Tcl_DStringAppend(&append, ".", 1);
+ TclDStringAppendLiteral(&append, ".");
}
}
-#if defined(__CYGWIN__) && !defined(__WIN32__)
- {
- DLLIMPORT extern int cygwin_conv_to_posix_path(const char *,
- char *);
- char winbuf[MAXPATHLEN+1];
-
- cygwin_conv_to_posix_path(Tcl_DStringValue(&append), winbuf);
- Tcl_DStringFree(&append);
- Tcl_DStringAppend(&append, winbuf, -1);
- }
-#endif /* __CYGWIN__ && __WIN32__ */
break;
}
@@ -2423,8 +2427,7 @@ DoGlob(
*/
if (pathPtr == NULL) {
- joinedPtr = Tcl_NewStringObj(Tcl_DStringValue(&append),
- Tcl_DStringLength(&append));
+ joinedPtr = TclDStringToObj(&append);
} else if (flags) {
joinedPtr = TclNewFSPathObj(pathPtr, Tcl_DStringValue(&append),
Tcl_DStringLength(&append));
diff --git a/generic/tclFileSystem.h b/generic/tclFileSystem.h
index 5e48dec..6be3e03 100644
--- a/generic/tclFileSystem.h
+++ b/generic/tclFileSystem.h
@@ -16,45 +16,6 @@
#include "tcl.h"
/*
- * struct FilesystemRecord --
- *
- * A filesystem record is used to keep track of each filesystem currently
- * registered with the core, in a linked list. Pointers to these structures
- * are also kept by each "path" Tcl_Obj, and we must retain a refCount on the
- * number of such references.
- */
-
-typedef struct FilesystemRecord {
- ClientData clientData; /* Client specific data for the new filesystem
- * (can be NULL) */
- const Tcl_Filesystem *fsPtr; /* Pointer to filesystem dispatch table. */
- int fileRefCount; /* How many Tcl_Obj's use this filesystem. */
- struct FilesystemRecord *nextPtr;
- /* The next filesystem registered to Tcl, or
- * NULL if no more. */
- struct FilesystemRecord *prevPtr;
- /* The previous filesystem registered to Tcl,
- * or NULL if no more. */
-} FilesystemRecord;
-
-/*
- * This structure holds per-thread private copy of the current directory
- * maintained by the global cwdPathPtr. This structure holds per-thread
- * private copies of some global data. This way we avoid most of the
- * synchronization calls which boosts performance, at cost of having to update
- * this information each time the corresponding epoch counter changes.
- */
-
-typedef struct ThreadSpecificData {
- int initialized;
- int cwdPathEpoch;
- int filesystemEpoch;
- Tcl_Obj *cwdPathPtr;
- ClientData cwdClientData;
- FilesystemRecord *filesystemList;
-} ThreadSpecificData;
-
-/*
* The internal TclFS API provides routines for handling and manipulating
* paths efficiently, taking direct advantage of the "path" Tcl_Obj type.
*
@@ -62,31 +23,23 @@ typedef struct ThreadSpecificData {
*/
MODULE_SCOPE int TclFSCwdPointerEquals(Tcl_Obj **pathPtrPtr);
-MODULE_SCOPE int TclFSMakePathFromNormalized(Tcl_Interp *interp,
- Tcl_Obj *pathPtr, ClientData clientData);
MODULE_SCOPE int TclFSNormalizeToUniquePath(Tcl_Interp *interp,
- Tcl_Obj *pathPtr, int startAt,
- ClientData *clientDataPtr);
+ Tcl_Obj *pathPtr, int startAt);
MODULE_SCOPE Tcl_Obj * TclFSMakePathRelative(Tcl_Interp *interp,
Tcl_Obj *pathPtr, Tcl_Obj *cwdPtr);
-MODULE_SCOPE Tcl_Obj * TclFSInternalToNormalized(
- const Tcl_Filesystem *fromFilesystem,
- ClientData clientData,
- FilesystemRecord **fsRecPtrPtr);
MODULE_SCOPE int TclFSEnsureEpochOk(Tcl_Obj *pathPtr,
const Tcl_Filesystem **fsPtrPtr);
MODULE_SCOPE void TclFSSetPathDetails(Tcl_Obj *pathPtr,
- FilesystemRecord *fsRecPtr,
- ClientData clientData);
+ const Tcl_Filesystem *fsPtr, ClientData clientData);
MODULE_SCOPE Tcl_Obj * TclFSNormalizeAbsolutePath(Tcl_Interp *interp,
- Tcl_Obj *pathPtr, ClientData *clientDataPtr);
+ Tcl_Obj *pathPtr);
+MODULE_SCOPE int TclFSEpoch(void);
/*
* Private shared variables for use by tclIOUtil.c and tclPathObj.c
*/
MODULE_SCOPE const Tcl_Filesystem tclNativeFilesystem;
-MODULE_SCOPE Tcl_ThreadDataKey tclFsDataKey;
/*
* Private shared functions for use by tclIOUtil.c, tclPathObj.c and
diff --git a/generic/tclIO.c b/generic/tclIO.c
index 082cf70..2de8b53 100644
--- a/generic/tclIO.c
+++ b/generic/tclIO.c
@@ -396,6 +396,19 @@ TclFinalizeIOSubsystem(void)
Channel *chanPtr = NULL; /* Iterates over open channels. */
ChannelState *statePtr; /* State of channel stack */
int active = 1; /* Flag == 1 while there's still work to do */
+ int doflushnb;
+
+ /* Fetch the pre-TIP#398 compatibility flag */
+ {
+ const char *s;
+ Tcl_DString ds;
+
+ s = TclGetEnv("TCL_FLUSH_NONBLOCKING_ON_EXIT", &ds);
+ doflushnb = ((s != NULL) && strcmp(s, "0"));
+ if (s != NULL) {
+ Tcl_DStringFree(&ds);
+ }
+ }
/*
* Walk all channel state structures known to this thread and close
@@ -414,25 +427,37 @@ TclFinalizeIOSubsystem(void)
statePtr != NULL;
statePtr = statePtr->nextCSPtr) {
chanPtr = statePtr->topChanPtr;
- if (!GotFlag(statePtr, CHANNEL_INCLOSE | CHANNEL_CLOSED | CHANNEL_DEAD)
+ if (GotFlag(statePtr, CHANNEL_DEAD)) {
+ continue;
+ }
+ if (!GotFlag(statePtr, CHANNEL_INCLOSE | CHANNEL_CLOSED )
|| GotFlag(statePtr, BG_FLUSH_SCHEDULED)) {
+ ResetFlag(statePtr, BG_FLUSH_SCHEDULED);
active = 1;
break;
}
}
/*
- * We've found a live channel. Close it.
+ * We've found a live (or bg-closing) channel. Close it.
*/
if (active) {
+
/*
- * Set the channel back into blocking mode to ensure that we wait
- * for all data to flush out.
+ * TIP #398: by default, we no longer set the channel back into
+ * blocking mode. To restore the old blocking behavior, the
+ * environment variable TCL_FLUSH_NONBLOCKING_ON_EXIT must be set
+ * and not be "0".
*/
-
- (void) Tcl_SetChannelOption(NULL, (Tcl_Channel) chanPtr,
- "-blocking", "on");
+ if (doflushnb) {
+ /* Set the channel back into blocking mode to ensure that we wait
+ * for all data to flush out.
+ */
+
+ (void) Tcl_SetChannelOption(NULL, (Tcl_Channel) chanPtr,
+ "-blocking", "on");
+ }
if ((chanPtr == (Channel *) tsdPtr->stdinChannel) ||
(chanPtr == (Channel *) tsdPtr->stdoutChannel) ||
@@ -458,7 +483,6 @@ TclFinalizeIOSubsystem(void)
* The refcount is greater than zero, so flush the channel.
*/
- ResetFlag(statePtr, BG_FLUSH_SCHEDULED);
Tcl_Flush((Tcl_Channel) chanPtr);
/*
@@ -4410,14 +4434,12 @@ Tcl_Gets(
* for managing the storage. */
{
Tcl_Obj *objPtr;
- int charsStored, length;
- const char *string;
+ int charsStored;
TclNewObj(objPtr);
charsStored = Tcl_GetsObj(chan, objPtr);
if (charsStored > 0) {
- string = TclGetStringFromObj(objPtr, &length);
- Tcl_DStringAppend(lineRead, string, length);
+ TclDStringAppendObj(lineRead, objPtr);
}
TclDecrRefCount(objPtr);
return charsStored;
@@ -7529,7 +7551,7 @@ Tcl_BadChannelOption(
Tcl_DStringInit(&ds);
Tcl_DStringAppend(&ds, genericopt, -1);
if (optionList && (*optionList)) {
- Tcl_DStringAppend(&ds, " ", 1);
+ TclDStringAppendLiteral(&ds, " ");
Tcl_DStringAppend(&ds, optionList, -1);
}
if (Tcl_SplitList(interp, Tcl_DStringValue(&ds),
@@ -8398,8 +8420,8 @@ UpdateInterest(
mask &= ~TCL_EXCEPTION;
if (!statePtr->timer) {
- statePtr->timer = Tcl_CreateTimerHandler(0, ChannelTimerProc,
- chanPtr);
+ statePtr->timer = Tcl_CreateTimerHandler(SYNTHETIC_EVENT_TIME,
+ ChannelTimerProc, chanPtr);
}
}
}
@@ -8440,7 +8462,8 @@ ChannelTimerProc(
* before UpdateInterest gets called by Tcl_NotifyChannel.
*/
- statePtr->timer = Tcl_CreateTimerHandler(0, ChannelTimerProc,chanPtr);
+ statePtr->timer = Tcl_CreateTimerHandler(SYNTHETIC_EVENT_TIME,
+ ChannelTimerProc,chanPtr);
#ifdef TCL_IO_TRACK_OS_FOR_DRIVER_WITH_BAD_BLOCKING
/*
@@ -8739,7 +8762,7 @@ CreateScriptRecord(
/*
* Initialize the structure before calling Tcl_CreateChannelHandler,
- * because a reflected channel caling 'chan postevent' aka
+ * because a reflected channel calling 'chan postevent' aka
* 'Tcl_NotifyChannel' in its 'watch'Proc will invoke
* 'TclChannelEventScriptInvoker' immediately, and we do not wish it to
* see uninitialized memory and crash. See [Bug 2918110].
@@ -8802,6 +8825,7 @@ TclChannelEventScriptInvoker(
*/
Tcl_Preserve(interp);
+ Tcl_Preserve(chanPtr);
result = Tcl_EvalObjEx(interp, esPtr->scriptPtr, TCL_EVAL_GLOBAL);
/*
@@ -8818,6 +8842,7 @@ TclChannelEventScriptInvoker(
}
Tcl_BackgroundException(interp, result);
}
+ Tcl_Release(chanPtr);
Tcl_Release(interp);
}
@@ -8856,7 +8881,7 @@ Tcl_FileEventObjCmd(
int modeIndex; /* Index of mode argument. */
int mask;
static const char *const modeOptions[] = {"readable", "writable", NULL};
- static int maskArray[] = {TCL_READABLE, TCL_WRITABLE};
+ static const int maskArray[] = {TCL_READABLE, TCL_WRITABLE};
if ((objc != 3) && (objc != 4)) {
Tcl_WrongNumArgs(interp, 1, objv, "channelId event ?script?");
diff --git a/generic/tclIO.h b/generic/tclIO.h
index 3283c3e..1e89878 100644
--- a/generic/tclIO.h
+++ b/generic/tclIO.h
@@ -423,6 +423,13 @@ typedef struct GetsState {
* appended to objPtr so far, just before the
* last call to FilterInputBytes(). */
} GetsState;
+
+/*
+ * The length of time to wait between synthetic timer events. Must be zero or
+ * bad things tend to happen.
+ */
+
+#define SYNTHETIC_EVENT_TIME 0
/*
* Local Variables:
diff --git a/generic/tclIOCmd.c b/generic/tclIOCmd.c
index 349814a..59856d0 100644
--- a/generic/tclIOCmd.c
+++ b/generic/tclIOCmd.c
@@ -521,7 +521,7 @@ Tcl_SeekObjCmd(
static const char *const originOptions[] = {
"start", "current", "end", NULL
};
- static int modeArray[] = {SEEK_SET, SEEK_CUR, SEEK_END};
+ static const int modeArray[] = {SEEK_SET, SEEK_CUR, SEEK_END};
if ((objc != 3) && (objc != 4)) {
Tcl_WrongNumArgs(interp, 1, objv, "channelId offset ?origin?");
@@ -648,7 +648,7 @@ Tcl_CloseObjCmd(
static const char *const dirOptions[] = {
"read", "write", NULL
};
- static int dirArray[] = {TCL_CLOSE_READ, TCL_CLOSE_WRITE};
+ static const int dirArray[] = {TCL_CLOSE_READ, TCL_CLOSE_WRITE};
if ((objc != 2) && (objc != 3)) {
Tcl_WrongNumArgs(interp, 1, objv, "channelId ?direction?");
diff --git a/generic/tclIORChan.c b/generic/tclIORChan.c
index 49e2930..eeb11f9 100644
--- a/generic/tclIORChan.c
+++ b/generic/tclIORChan.c
@@ -39,6 +39,9 @@ static int ReflectOutput(ClientData clientData, const char *buf,
int toWrite, int *errorCodePtr);
static void ReflectWatch(ClientData clientData, int mask);
static int ReflectBlock(ClientData clientData, int mode);
+#ifdef TCL_THREADS
+static void ReflectThread(ClientData clientData, int action);
+#endif
static Tcl_WideInt ReflectSeekWide(ClientData clientData,
Tcl_WideInt offset, int mode, int *errorCodePtr);
static int ReflectSeek(ClientData clientData, long offset,
@@ -71,7 +74,11 @@ static const Tcl_ChannelType tclRChannelType = {
NULL, /* Flush channel. Not used by core. NULL'able */
NULL, /* Handle events. NULL'able */
ReflectSeekWide, /* Move access point (64 bit). NULL'able */
+#ifdef TCL_THREADS
+ ReflectThread, /* thread action, tracking owner */
+#else
NULL, /* thread action */
+#endif
NULL /* truncate */
};
@@ -89,7 +96,8 @@ typedef struct {
* command is gone.
*/
#ifdef TCL_THREADS
- Tcl_ThreadId thread; /* Thread the 'interp' belongs to. */
+ Tcl_ThreadId thread; /* Thread the 'interp' belongs to. == Handler thread */
+ Tcl_ThreadId owner; /* Thread owning the structure. == Channel thread */
#endif
/* See [==] as well.
@@ -390,7 +398,7 @@ TCL_DECLARE_MUTEX(rcForwardMutex)
* leak resources when threads go away.
*/
-static void ForwardOpToOwnerThread(ReflectedChannel *rcPtr,
+static void ForwardOpToHandlerThread(ReflectedChannel *rcPtr,
ForwardedOperation op, const void *param);
static int ForwardProc(Tcl_Event *evPtr, int mask);
static void SrcExitProc(ClientData clientData);
@@ -731,7 +739,8 @@ TclChanCreateObjCmd(
* Return handle as result of command.
*/
- Tcl_SetResult(interp, (char *)chanPtr->state->channelName, TCL_VOLATILE);
+ Tcl_SetObjResult(interp,
+ Tcl_NewStringObj(chanPtr->state->channelName, -1));
return TCL_OK;
error:
@@ -765,6 +774,48 @@ TclChanCreateObjCmd(
*----------------------------------------------------------------------
*/
+typedef struct ReflectEvent {
+ Tcl_Event header;
+ ReflectedChannel* rcPtr;
+ int events;
+} ReflectEvent;
+
+static int
+ReflectEventRun (Tcl_Event* ev, int flags)
+{
+ /* OWNER thread
+ *
+ * Note: When the channel is closed any pending events of this type are
+ * deleted. See ReflectClose() for the Tcl_DeleteEvents() calls
+ * accomplishing that.
+ */
+
+ ReflectEvent* e = (ReflectEvent*) ev;
+
+ Tcl_NotifyChannel (e->rcPtr->chan, e->events);
+ return 1;
+}
+
+static int
+ReflectEventDelete (Tcl_Event* ev, ClientData cd)
+{
+ /* OWNER thread
+ *
+ * Invoked by DeleteThreadReflectedChannelMap() and ReflectClose(). The
+ * latter ensures that no pending events of this type are run on an
+ * invalid channel.
+ */
+
+ ReflectEvent* e = (ReflectEvent*) ev;
+
+ if ((ev->proc != ReflectEventRun) ||
+ ((cd != NULL) &&
+ (cd != e->rcPtr))) {
+ return 0;
+ }
+ return 1;
+}
+
int
TclChanPostEventObjCmd(
ClientData clientData,
@@ -773,6 +824,8 @@ TclChanPostEventObjCmd(
Tcl_Obj *const *objv)
{
/*
+ * Ensure -> HANDLER thread
+ *
* Syntax: chan postevent CHANNEL EVENTSPEC
* [0] [1] [2] [3]
*
@@ -882,7 +935,41 @@ TclChanPostEventObjCmd(
* We have the channel and the events to post.
*/
- Tcl_NotifyChannel(chan, events);
+#ifdef TCL_THREADS
+ if (rcPtr->owner == rcPtr->thread) {
+#endif
+ Tcl_NotifyChannel (chan, events);
+#ifdef TCL_THREADS
+ } else {
+ ReflectEvent* ev = ckalloc (sizeof (ReflectEvent));
+ ev->header.proc = ReflectEventRun;
+ ev->events = events;
+ ev->rcPtr = rcPtr;
+
+ /*
+ * We are not preserving the structure here. When the channel is
+ * closed any pending events are deleted, see ReflectClose(), and
+ * ReflectEventDelete(). Trying to preserve and later release when the
+ * event is run may generate a situation where the channel structure
+ * is deleted but not our structure, crashing in
+ * FreeReflectedChannel().
+ *
+ * Force creation of the RCM, for proper cleanup on thread teardown.
+ * The teardown of unprocessed events is currently coupled to the
+ * thread reflected channel map
+ */
+ (void) GetThreadReflectedChannelMap ();
+
+ /* XXX Race condition !!
+ * XXX The destination thread may not exist anymore already.
+ * XXX (Delayed postevent executed after channel got removed).
+ * XXX Can we detect this ? (check the validity of the owner threadid ?)
+ * XXX Actually, in that case the channel should be dead also !
+ */
+ Tcl_ThreadQueueEvent (rcPtr->owner, (Tcl_Event*) ev, TCL_QUEUE_TAIL);
+ Tcl_ThreadAlert (rcPtr->owner);
+ }
+#endif
/*
* Squash interp results left by the event script.
@@ -1067,9 +1154,12 @@ ReflectClose(
if (rcPtr->thread != Tcl_GetCurrentThread()) {
ForwardParam p;
- ForwardOpToOwnerThread(rcPtr, ForwardedClose, &p);
+ ForwardOpToHandlerThread(rcPtr, ForwardedClose, &p);
result = p.base.code;
+ /* Now squash the pending reflection events for this channel. */
+ Tcl_DeleteEvents (ReflectEventDelete, rcPtr);
+
if (result != TCL_OK) {
FreeReceivedError(&p);
}
@@ -1100,9 +1190,12 @@ ReflectClose(
if (rcPtr->thread != Tcl_GetCurrentThread()) {
ForwardParam p;
- ForwardOpToOwnerThread(rcPtr, ForwardedClose, &p);
+ ForwardOpToHandlerThread(rcPtr, ForwardedClose, &p);
result = p.base.code;
+ /* Now squash the pending reflection events for this channel. */
+ Tcl_DeleteEvents (ReflectEventDelete, rcPtr);
+
Tcl_EventuallyFree (rcPtr, (Tcl_FreeProc *) FreeReflectedChannel);
if (result != TCL_OK) {
@@ -1207,7 +1300,7 @@ ReflectInput(
p.input.buf = buf;
p.input.toRead = toRead;
- ForwardOpToOwnerThread(rcPtr, ForwardedInput, &p);
+ ForwardOpToHandlerThread(rcPtr, ForwardedInput, &p);
if (p.base.code != TCL_OK) {
if (p.base.code < 0) {
@@ -1322,7 +1415,7 @@ ReflectOutput(
p.output.buf = buf;
p.output.toWrite = toWrite;
- ForwardOpToOwnerThread(rcPtr, ForwardedOutput, &p);
+ ForwardOpToHandlerThread(rcPtr, ForwardedOutput, &p);
if (p.base.code != TCL_OK) {
if (p.base.code < 0) {
@@ -1438,7 +1531,7 @@ ReflectSeekWide(
p.seek.seekMode = seekMode;
p.seek.offset = offset;
- ForwardOpToOwnerThread(rcPtr, ForwardedSeek, &p);
+ ForwardOpToHandlerThread(rcPtr, ForwardedSeek, &p);
if (p.base.code != TCL_OK) {
PassReceivedError(rcPtr->chan, &p);
@@ -1562,7 +1655,7 @@ ReflectWatch(
ForwardParam p;
p.watch.mask = mask;
- ForwardOpToOwnerThread(rcPtr, ForwardedWatch, &p);
+ ForwardOpToHandlerThread(rcPtr, ForwardedWatch, &p);
/*
* Any failure from the forward is ignored. We have no place to put
@@ -1620,7 +1713,7 @@ ReflectBlock(
p.block.nonblocking = nonblocking;
- ForwardOpToOwnerThread(rcPtr, ForwardedBlock, &p);
+ ForwardOpToHandlerThread(rcPtr, ForwardedBlock, &p);
if (p.base.code != TCL_OK) {
PassReceivedError(rcPtr->chan, &p);
@@ -1650,6 +1743,42 @@ ReflectBlock(
return errorNum;
}
+#ifdef TCL_THREADS
+/*
+ *----------------------------------------------------------------------
+ *
+ * ReflectThread --
+ *
+ * This function is invoked to tell the channel about thread movements.
+ *
+ * Results:
+ * None.
+ *
+ * Side effects:
+ * Allocates memory. Arbitrary, as it calls upon a script.
+ *
+ *----------------------------------------------------------------------
+ */
+
+static void
+ReflectThread(ClientData clientData, int action)
+{
+ ReflectedChannel *rcPtr = clientData;
+
+ switch (action) {
+ case TCL_CHANNEL_THREAD_INSERT:
+ rcPtr->owner = Tcl_GetCurrentThread();
+ break;
+ case TCL_CHANNEL_THREAD_REMOVE:
+ rcPtr->owner = NULL;
+ break;
+ default:
+ Tcl_Panic ("Unknown thread action code.");
+ break;
+ }
+}
+
+#endif
/*
*----------------------------------------------------------------------
*
@@ -1689,7 +1818,7 @@ ReflectSetOption(
p.setOpt.name = optionName;
p.setOpt.value = newValue;
- ForwardOpToOwnerThread(rcPtr, ForwardedSetOpt, &p);
+ ForwardOpToHandlerThread(rcPtr, ForwardedSetOpt, &p);
if (p.base.code != TCL_OK) {
Tcl_Obj *err = Tcl_NewStringObj(p.base.msgStr, -1);
@@ -1775,7 +1904,7 @@ ReflectGetOption(
opcode = ForwardedGetOpt;
}
- ForwardOpToOwnerThread(rcPtr, opcode, &p);
+ ForwardOpToHandlerThread(rcPtr, opcode, &p);
if (p.base.code != TCL_OK) {
Tcl_Obj *err = Tcl_NewStringObj(p.base.msgStr, -1);
@@ -1819,7 +1948,7 @@ ReflectGetOption(
*/
if (optionObj != NULL) {
- Tcl_DStringAppend(dsPtr, TclGetString(resObj), -1);
+ TclDStringAppendObj(dsPtr, resObj);
goto ok;
}
@@ -1854,7 +1983,7 @@ ReflectGetOption(
const char *str = Tcl_GetStringFromObj(resObj, &len);
if (len) {
- Tcl_DStringAppend(dsPtr, " ", 1);
+ TclDStringAppendLiteral(dsPtr, " ");
Tcl_DStringAppend(dsPtr, str, len);
}
goto ok;
@@ -2673,6 +2802,15 @@ DeleteThreadReflectedChannelMap(
Tcl_MutexUnlock(&rcForwardMutex);
/*
+ * Run over the event queue of this thread and remove all ReflectEvent's
+ * still pending. These are inbound events for reflected channels this
+ * thread owns but doesn't handle. The inverse of the channel map
+ * actually.
+ */
+
+ Tcl_DeleteEvents (ReflectEventDelete, NULL);
+
+ /*
* Get the map of all channels handled by the current thread. This is a
* ReflectedChannelMap, but on a per-thread basis, not per-interp. Go
* through the channels, remove all, mark them as dead.
@@ -2693,11 +2831,16 @@ DeleteThreadReflectedChannelMap(
}
static void
-ForwardOpToOwnerThread(
+ForwardOpToHandlerThread(
ReflectedChannel *rcPtr, /* Channel instance */
ForwardedOperation op, /* Forwarded driver operation */
const void *param) /* Arguments */
{
+ /*
+ * Core of the communication from OWNER to HANDLER thread.
+ * The receiver is ForwardProc() below.
+ */
+
Tcl_ThreadId dst = rcPtr->thread;
ForwardingEvent *evPtr;
ForwardingResult *resultPtr;
@@ -2750,7 +2893,7 @@ ForwardOpToOwnerThread(
/*
* Ensure cleanup of the event if the origin thread exits while this event
* is pending or in progress. Exit of the destination thread is handled by
- * DeleteThreadReflectionChannelMap(), this is set up by
+ * DeleteThreadReflectedChannelMap(), this is set up by
* GetThreadReflectedChannelMap(). This is what we use the 'forwardList'
* (see above) for.
*/
@@ -2765,7 +2908,7 @@ ForwardOpToOwnerThread(
Tcl_ThreadAlert(dst);
/*
- * (*) Block until the other thread has either processed the transfer or
+ * (*) Block until the handler thread has either processed the transfer or
* rejected it.
*/
@@ -2813,6 +2956,11 @@ ForwardProc(
int mask)
{
/*
+ * HANDLER thread.
+
+ * The receiver part for the operations coming from the OWNER thread.
+ * See ForwardOpToHandlerThread() for the transmitter.
+ *
* Notes regarding access to the referenced data.
*
* In principle the data belongs to the originating thread (see
@@ -3060,8 +3208,7 @@ ForwardProc(
if (InvokeTclMethod(rcPtr, "cget", optionObj, NULL, &resObj)!=TCL_OK){
ForwardSetObjError(paramPtr, resObj);
} else {
- Tcl_DStringAppend(paramPtr->getOpt.value,
- TclGetString(resObj), -1);
+ TclDStringAppendObj(paramPtr->getOpt.value, resObj);
}
Tcl_Release(rcPtr);
Tcl_DecrRefCount(optionObj);
@@ -3086,7 +3233,7 @@ ForwardProc(
Tcl_Obj **listv;
if (Tcl_ListObjGetElements(interp, resObj, &listc,
- &listv) != TCL_OK) {
+ &listv) != TCL_OK) {
Tcl_DecrRefCount(resObj);
resObj = MarshallError(interp);
ForwardSetObjError(paramPtr, resObj);
@@ -3106,7 +3253,7 @@ ForwardProc(
const char *str = Tcl_GetStringFromObj(resObj, &len);
if (len) {
- Tcl_DStringAppend(paramPtr->getOpt.value, " ", 1);
+ TclDStringAppendLiteral(paramPtr->getOpt.value, " ");
Tcl_DStringAppend(paramPtr->getOpt.value, str, len);
}
}
diff --git a/generic/tclIORTrans.c b/generic/tclIORTrans.c
index 6c9a41b..8f111b0 100644
--- a/generic/tclIORTrans.c
+++ b/generic/tclIORTrans.c
@@ -439,13 +439,6 @@ static const char *msg_dstlost =
*/
/*
- * Number of milliseconds to wait before firing an event to try to flush out
- * information waiting in buffers (fileevent support).
- */
-
-#define FLUSH_DELAY (5)
-
-/*
* Helper functions encapsulating some of the thread forwarding to make the
* control flow in callers easier.
*/
@@ -1230,7 +1223,7 @@ ReflectInput(
*
* ReflectOutput --
*
- * This function is invoked when data is writen to the channel.
+ * This function is invoked when data is written to the channel.
*
* Results:
* The number of bytes actually written.
@@ -2861,7 +2854,8 @@ TimerSetup(
return;
}
- rtPtr->timer = Tcl_CreateTimerHandler(FLUSH_DELAY, TimerRun, rtPtr);
+ rtPtr->timer = Tcl_CreateTimerHandler(SYNTHETIC_EVENT_TIME,
+ TimerRun, rtPtr);
}
/*
diff --git a/generic/tclIOSock.c b/generic/tclIOSock.c
index 7b7b647..018f9f5 100644
--- a/generic/tclIOSock.c
+++ b/generic/tclIOSock.c
@@ -87,8 +87,8 @@ TclSockGetPort(
*----------------------------------------------------------------------
*/
-#ifndef _WIN32
-# define SOCKET size_t
+#if !defined(_WIN32) && !defined(__CYGWIN__)
+# define SOCKET int
#endif
int
@@ -100,16 +100,16 @@ TclSockMinimumBuffers(
socklen_t len;
len = sizeof(int);
- getsockopt((SOCKET)sock, SOL_SOCKET, SO_SNDBUF, (char *)&current, &len);
+ getsockopt((SOCKET)(size_t)sock, SOL_SOCKET, SO_SNDBUF, (char *)&current, &len);
if (current < size) {
len = sizeof(int);
- setsockopt((SOCKET)sock, SOL_SOCKET, SO_SNDBUF, (char *)&size, len);
+ setsockopt((SOCKET)(size_t)sock, SOL_SOCKET, SO_SNDBUF, (char *)&size, len);
}
len = sizeof(int);
- getsockopt((SOCKET)sock, SOL_SOCKET, SO_RCVBUF, (char *)&current, &len);
+ getsockopt((SOCKET)(size_t)sock, SOL_SOCKET, SO_RCVBUF, (char *)&current, &len);
if (current < size) {
len = sizeof(int);
- setsockopt((SOCKET)sock, SOL_SOCKET, SO_RCVBUF, (char *)&size, len);
+ setsockopt((SOCKET)(size_t)sock, SOL_SOCKET, SO_RCVBUF, (char *)&size, len);
}
return TCL_OK;
}
@@ -206,7 +206,13 @@ TclCreateSocketAddress(
}
if (result != 0) {
- goto error;
+#ifdef EAI_SYSTEM /* Doesn't exist on Windows */
+ if (result == EAI_SYSTEM)
+ *errorMsgPtr = Tcl_PosixError(interp);
+ else
+#endif
+ *errorMsgPtr = gai_strerror(result);
+ return 0;
}
/*
@@ -249,33 +255,6 @@ TclCreateSocketAddress(
}
return 1;
-
- /*
- * Ought to use gai_strerror() here...
- */
-
-error:
- switch (result) {
- case EAI_NONAME:
- case EAI_SERVICE:
-#if defined(EAI_ADDRFAMILY) && EAI_ADDRFAMILY != EAI_NONAME
- case EAI_ADDRFAMILY:
-#endif
-#if defined(EAI_NODATA) && EAI_NODATA != EAI_NONAME
- case EAI_NODATA:
-#endif
- *errorMsgPtr = gai_strerror(result);
- errno = EHOSTUNREACH;
- return 0;
-#ifdef EAI_SYSTEM
- case EAI_SYSTEM:
- return 0;
-#endif
- default:
- *errorMsgPtr = gai_strerror(result);
- errno = ENXIO;
- return 0;
- }
}
/*
diff --git a/generic/tclIOUtil.c b/generic/tclIOUtil.c
index c4e7db0..ebf34dc 100644
--- a/generic/tclIOUtil.c
+++ b/generic/tclIOUtil.c
@@ -28,6 +28,43 @@
#include "tclFileSystem.h"
/*
+ * struct FilesystemRecord --
+ *
+ * A filesystem record is used to keep track of each filesystem currently
+ * registered with the core, in a linked list.
+ */
+
+typedef struct FilesystemRecord {
+ ClientData clientData; /* Client specific data for the new filesystem
+ * (can be NULL) */
+ const Tcl_Filesystem *fsPtr;/* Pointer to filesystem dispatch table. */
+ struct FilesystemRecord *nextPtr;
+ /* The next filesystem registered to Tcl, or
+ * NULL if no more. */
+ struct FilesystemRecord *prevPtr;
+ /* The previous filesystem registered to Tcl,
+ * or NULL if no more. */
+} FilesystemRecord;
+
+/*
+ * This structure holds per-thread private copy of the current directory
+ * maintained by the global cwdPathPtr. This structure holds per-thread
+ * private copies of some global data. This way we avoid most of the
+ * synchronization calls which boosts performance, at cost of having to update
+ * this information each time the corresponding epoch counter changes.
+ */
+
+typedef struct ThreadSpecificData {
+ int initialized;
+ int cwdPathEpoch;
+ int filesystemEpoch;
+ Tcl_Obj *cwdPathPtr;
+ ClientData cwdClientData;
+ FilesystemRecord *filesystemList;
+ int claims;
+} ThreadSpecificData;
+
+/*
* Prototypes for functions defined later in this file.
*/
@@ -40,9 +77,10 @@ static void FsAddMountsToGlobResult(Tcl_Obj *resultPtr,
Tcl_Obj *pathPtr, const char *pattern,
Tcl_GlobTypeData *types);
static void FsUpdateCwd(Tcl_Obj *cwdObj, ClientData clientData);
-#ifdef TCL_THREADS
static void FsRecacheFilesystemList(void);
-#endif
+static void Claim(void);
+static void Disclaim(void);
+
static void * DivertFindSymbol(Tcl_Interp *interp,
Tcl_LoadHandle loadHandle, const char *symbol);
static void DivertUnloadFile(Tcl_LoadHandle loadHandle);
@@ -163,7 +201,6 @@ const Tcl_Filesystem tclNativeFilesystem = {
static FilesystemRecord nativeFilesystemRecord = {
NULL,
&tclNativeFilesystem,
- 1,
NULL,
NULL
};
@@ -175,7 +212,7 @@ static FilesystemRecord nativeFilesystemRecord = {
* trigger cache cleanup in all threads.
*/
-static int theFilesystemEpoch = 0;
+static int theFilesystemEpoch = 1;
/*
* Stores the linked list of filesystems. A 1:1 copy of this list is also
@@ -195,7 +232,7 @@ static int cwdPathEpoch = 0;
static ClientData cwdClientData = NULL;
TCL_DECLARE_MUTEX(cwdMutex)
-Tcl_ThreadDataKey tclFsDataKey;
+static Tcl_ThreadDataKey fsDataKey;
/*
* One of these structures is used each time we successfully load a file from
@@ -368,7 +405,7 @@ Tcl_GetCwd(
return NULL;
}
Tcl_DStringInit(cwdPtr);
- Tcl_DStringAppend(cwdPtr, Tcl_GetString(cwd), -1);
+ TclDStringAppendObj(cwdPtr, cwd);
Tcl_DecrRefCount(cwd);
return Tcl_DStringValue(cwdPtr);
}
@@ -419,9 +456,8 @@ FsThrExitProc(
fsRecPtr = tsdPtr->filesystemList;
while (fsRecPtr != NULL) {
tmpFsRecPtr = fsRecPtr->nextPtr;
- if (--fsRecPtr->fileRefCount <= 0) {
- ckfree(fsRecPtr);
- }
+ fsRecPtr->fsPtr = NULL;
+ ckfree(fsRecPtr);
fsRecPtr = tmpFsRecPtr;
}
tsdPtr->initialized = 0;
@@ -430,7 +466,7 @@ FsThrExitProc(
int
TclFSCwdIsNative(void)
{
- ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&tclFsDataKey);
+ ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&fsDataKey);
if (tsdPtr->cwdClientData != NULL) {
return 1;
@@ -464,7 +500,7 @@ int
TclFSCwdPointerEquals(
Tcl_Obj **pathPtrPtr)
{
- ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&tclFsDataKey);
+ ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&fsDataKey);
Tcl_MutexLock(&cwdMutex);
if (tsdPtr->cwdPathPtr == NULL
@@ -523,12 +559,11 @@ TclFSCwdPointerEquals(
}
}
-#ifdef TCL_THREADS
static void
FsRecacheFilesystemList(void)
{
- ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&tclFsDataKey);
- FilesystemRecord *fsRecPtr, *tmpFsRecPtr = NULL;
+ ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&fsDataKey);
+ FilesystemRecord *fsRecPtr, *tmpFsRecPtr = NULL, *toFree = NULL, *list;
/*
* Trash the current cache.
@@ -537,20 +572,16 @@ FsRecacheFilesystemList(void)
fsRecPtr = tsdPtr->filesystemList;
while (fsRecPtr != NULL) {
tmpFsRecPtr = fsRecPtr->nextPtr;
- if (--fsRecPtr->fileRefCount <= 0) {
- ckfree(fsRecPtr);
- }
+ fsRecPtr->nextPtr = toFree;
+ toFree = fsRecPtr;
fsRecPtr = tmpFsRecPtr;
}
- tsdPtr->filesystemList = NULL;
/*
- * Code below operates on shared data. We are already called under mutex
- * lock so we can safely proceed.
- *
* Locate tail of the global filesystem list.
*/
+ Tcl_MutexLock(&filesystemMutex);
fsRecPtr = filesystemList;
while (fsRecPtr != NULL) {
tmpFsRecPtr = fsRecPtr;
@@ -561,18 +592,26 @@ FsRecacheFilesystemList(void)
* Refill the cache honouring the order.
*/
+ list = NULL;
fsRecPtr = tmpFsRecPtr;
while (fsRecPtr != NULL) {
tmpFsRecPtr = ckalloc(sizeof(FilesystemRecord));
*tmpFsRecPtr = *fsRecPtr;
- tmpFsRecPtr->nextPtr = tsdPtr->filesystemList;
+ tmpFsRecPtr->nextPtr = list;
tmpFsRecPtr->prevPtr = NULL;
- if (tsdPtr->filesystemList) {
- tsdPtr->filesystemList->prevPtr = tmpFsRecPtr;
- }
- tsdPtr->filesystemList = tmpFsRecPtr;
+ list = tmpFsRecPtr;
fsRecPtr = fsRecPtr->prevPtr;
}
+ tsdPtr->filesystemList = list;
+ tsdPtr->filesystemEpoch = theFilesystemEpoch;
+ Tcl_MutexUnlock(&filesystemMutex);
+
+ while (toFree) {
+ FilesystemRecord *next = toFree->nextPtr;
+ toFree->fsPtr = NULL;
+ ckfree(toFree);
+ toFree = next;
+ }
/*
* Make sure the above gets released on thread exit.
@@ -583,28 +622,16 @@ FsRecacheFilesystemList(void)
tsdPtr->initialized = 1;
}
}
-#endif /* TCL_THREADS */
static FilesystemRecord *
FsGetFirstFilesystem(void)
{
- ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&tclFsDataKey);
- FilesystemRecord *fsRecPtr;
-
-#ifndef TCL_THREADS
- tsdPtr->filesystemEpoch = theFilesystemEpoch;
- fsRecPtr = filesystemList;
-#else
- Tcl_MutexLock(&filesystemMutex);
- if (tsdPtr->filesystemList == NULL
- || (tsdPtr->filesystemEpoch != theFilesystemEpoch)) {
+ ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&fsDataKey);
+ if (tsdPtr->filesystemList == NULL || ((tsdPtr->claims == 0)
+ && (tsdPtr->filesystemEpoch != theFilesystemEpoch))) {
FsRecacheFilesystemList();
- tsdPtr->filesystemEpoch = theFilesystemEpoch;
}
- Tcl_MutexUnlock(&filesystemMutex);
- fsRecPtr = tsdPtr->filesystemList;
-#endif
- return fsRecPtr;
+ return tsdPtr->filesystemList;
}
/*
@@ -616,11 +643,30 @@ int
TclFSEpochOk(
int filesystemEpoch)
{
- ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&tclFsDataKey);
+ return (filesystemEpoch == 0 || filesystemEpoch == theFilesystemEpoch);
+}
+
+static void
+Claim()
+{
+ ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&fsDataKey);
+ tsdPtr->claims++;
+}
+
+static void
+Disclaim()
+{
+ ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&fsDataKey);
+ tsdPtr->claims--;
+}
- (void) FsGetFirstFilesystem();
- return (filesystemEpoch == tsdPtr->filesystemEpoch);
+int
+TclFSEpoch()
+{
+ ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&fsDataKey);
+ return tsdPtr->filesystemEpoch;
}
+
/*
* If non-NULL, clientData is owned by us and must be freed later.
@@ -633,7 +679,7 @@ FsUpdateCwd(
{
int len;
const char *str = NULL;
- ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&tclFsDataKey);
+ ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&fsDataKey);
if (cwdObj != NULL) {
str = Tcl_GetStringFromObj(cwdObj, &len);
@@ -730,17 +776,14 @@ TclFinalizeFilesystem(void)
while (fsRecPtr != NULL) {
FilesystemRecord *tmpFsRecPtr = fsRecPtr->nextPtr;
- if (fsRecPtr->fileRefCount <= 0) {
- /*
- * The native filesystem is static, so we don't free it.
- */
+ /* The native filesystem is static, so we don't free it. */
- if (fsRecPtr->fsPtr != &tclNativeFilesystem) {
- ckfree(fsRecPtr);
- }
+ if (fsRecPtr != &nativeFilesystemRecord) {
+ ckfree(fsRecPtr);
}
fsRecPtr = tmpFsRecPtr;
}
+ theFilesystemEpoch++;
filesystemList = NULL;
/*
@@ -773,11 +816,7 @@ void
TclResetFilesystem(void)
{
filesystemList = &nativeFilesystemRecord;
-
- /*
- * Note, at this point, I believe nativeFilesystemRecord -> fileRefCount
- * should equal 1 and if not, we should try to track down the cause.
- */
+ theFilesystemEpoch++;
#ifdef __WIN32__
/*
@@ -836,13 +875,6 @@ Tcl_FSRegister(
newFilesystemPtr->fsPtr = fsPtr;
/*
- * We start with a refCount of 1. If this drops to zero, then anyone is
- * welcome to ckfree us.
- */
-
- newFilesystemPtr->fileRefCount = 1;
-
- /*
* Is this lock and wait strictly speaking necessary? Since any iterators
* out there will have grabbed a copy of the head of the list and be
* iterating away from that, if we add a new element to the head of the
@@ -915,7 +947,7 @@ Tcl_FSUnregister(
*/
fsRecPtr = filesystemList;
- while ((retVal == TCL_ERROR) && (fsRecPtr->fsPtr != &tclNativeFilesystem)) {
+ while ((retVal == TCL_ERROR) && (fsRecPtr != &nativeFilesystemRecord)) {
if (fsRecPtr->fsPtr == fsPtr) {
if (fsRecPtr->prevPtr) {
fsRecPtr->prevPtr->nextPtr = fsRecPtr->nextPtr;
@@ -936,10 +968,7 @@ Tcl_FSUnregister(
theFilesystemEpoch++;
- fsRecPtr->fileRefCount--;
- if (fsRecPtr->fileRefCount <= 0) {
- ckfree(fsRecPtr);
- }
+ ckfree(fsRecPtr);
retVal = TCL_OK;
} else {
@@ -1065,8 +1094,9 @@ Tcl_FSMatchInDirectory(
cwd = Tcl_FSGetCwd(NULL);
if (cwd == NULL) {
if (interp != NULL) {
- Tcl_SetResult(interp, "glob couldn't determine "
- "the current working directory", TCL_STATIC);
+ Tcl_SetObjResult(interp, Tcl_NewStringObj(
+ "glob couldn't determine the current working directory",
+ -1));
}
return TCL_ERROR;
}
@@ -1347,14 +1377,9 @@ int
TclFSNormalizeToUniquePath(
Tcl_Interp *interp, /* Used for error messages. */
Tcl_Obj *pathPtr, /* The path to normalize in place. */
- int startAt, /* Start at this char-offset. */
- ClientData *clientDataPtr) /* If we generated a complete normalized path
- * for a given filesystem, we can optionally
- * return an fs-specific clientdata here. */
+ int startAt) /* Start at this char-offset. */
{
FilesystemRecord *fsRecPtr, *firstFsRecPtr;
- /* Ignore this variable */
- (void) clientDataPtr;
/*
* Call each of the "normalise path" functions in succession. This is a
@@ -1365,6 +1390,7 @@ TclFSNormalizeToUniquePath(
firstFsRecPtr = FsGetFirstFilesystem();
+ Claim();
for (fsRecPtr=firstFsRecPtr; fsRecPtr!=NULL; fsRecPtr=fsRecPtr->nextPtr) {
if (fsRecPtr->fsPtr != &tclNativeFilesystem) {
continue;
@@ -1402,6 +1428,7 @@ TclFSNormalizeToUniquePath(
* but there's not much benefit.
*/
}
+ Disclaim();
return startAt;
}
@@ -2596,7 +2623,7 @@ Tcl_Obj *
Tcl_FSGetCwd(
Tcl_Interp *interp)
{
- ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&tclFsDataKey);
+ ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&fsDataKey);
if (TclFSCwdPointerEquals(NULL)) {
FilesystemRecord *fsRecPtr;
@@ -2608,8 +2635,9 @@ Tcl_FSGetCwd(
* indicates the particular function has succeeded.
*/
- for (fsRecPtr = FsGetFirstFilesystem();
- (retVal == NULL) && (fsRecPtr != NULL);
+ fsRecPtr = FsGetFirstFilesystem();
+ Claim();
+ for (; (retVal == NULL) && (fsRecPtr != NULL);
fsRecPtr = fsRecPtr->nextPtr) {
ClientData retCd;
TclFSGetCwdProc2 *proc2;
@@ -2633,7 +2661,7 @@ Tcl_FSGetCwd(
retVal = fsRecPtr->fsPtr->internalToNormalizedProc(retCd);
Tcl_IncrRefCount(retVal);
- norm = TclFSNormalizeAbsolutePath(interp,retVal,NULL);
+ norm = TclFSNormalizeAbsolutePath(interp,retVal);
if (norm != NULL) {
/*
* We found a cwd, which is now in our global storage. We
@@ -2654,6 +2682,7 @@ Tcl_FSGetCwd(
}
Tcl_DecrRefCount(retVal);
retVal = NULL;
+ Disclaim();
goto cdDidNotChange;
} else if (interp != NULL) {
Tcl_AppendResult(interp,
@@ -2661,6 +2690,7 @@ Tcl_FSGetCwd(
Tcl_PosixError(interp), NULL);
}
}
+ Disclaim();
/*
* Now the 'cwd' may NOT be normalized, at least on some platforms.
@@ -2672,7 +2702,7 @@ Tcl_FSGetCwd(
*/
if (retVal != NULL) {
- Tcl_Obj *norm = TclFSNormalizeAbsolutePath(interp, retVal, NULL);
+ Tcl_Obj *norm = TclFSNormalizeAbsolutePath(interp, retVal);
if (norm != NULL) {
/*
@@ -2762,7 +2792,7 @@ Tcl_FSGetCwd(
* Normalize the path.
*/
- norm = TclFSNormalizeAbsolutePath(interp, retVal, NULL);
+ norm = TclFSNormalizeAbsolutePath(interp, retVal);
/*
* Check whether cwd has changed from the value previously stored in
@@ -2944,7 +2974,7 @@ Tcl_FSChdir(
* instead. This should be examined by someone on Unix.
*/
- ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&tclFsDataKey);
+ ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&fsDataKey);
ClientData cd;
ClientData oldcd = tsdPtr->cwdClientData;
@@ -3781,6 +3811,7 @@ Tcl_FSListVolumes(void)
*/
fsRecPtr = FsGetFirstFilesystem();
+ Claim();
while (fsRecPtr != NULL) {
if (fsRecPtr->fsPtr->listVolumesProc != NULL) {
Tcl_Obj *thisFsVolumes = fsRecPtr->fsPtr->listVolumesProc();
@@ -3792,6 +3823,7 @@ Tcl_FSListVolumes(void)
}
fsRecPtr = fsRecPtr->nextPtr;
}
+ Disclaim();
return resultPtr;
}
@@ -3831,6 +3863,7 @@ FsListMounts(
*/
fsRecPtr = FsGetFirstFilesystem();
+ Claim();
while (fsRecPtr != NULL) {
if (fsRecPtr->fsPtr != &tclNativeFilesystem &&
fsRecPtr->fsPtr->matchInDirectoryProc != NULL) {
@@ -3842,6 +3875,7 @@ FsListMounts(
}
fsRecPtr = fsRecPtr->nextPtr;
}
+ Disclaim();
return resultPtr;
}
@@ -3953,31 +3987,6 @@ Tcl_FSSplitPath(
}
return result;
}
-
-/* Simple helper function. */
-Tcl_Obj *
-TclFSInternalToNormalized(
- const Tcl_Filesystem *fromFilesystem,
- ClientData clientData,
- FilesystemRecord **fsRecPtrPtr)
-{
- FilesystemRecord *fsRecPtr = FsGetFirstFilesystem();
-
- while (fsRecPtr != NULL) {
- if (fsRecPtr->fsPtr == fromFilesystem) {
- *fsRecPtrPtr = fsRecPtr;
- break;
- }
- fsRecPtr = fsRecPtr->nextPtr;
- }
-
- if ((fsRecPtr == NULL)
- || (fromFilesystem->internalToNormalizedProc == NULL)) {
- return NULL;
- }
- return fromFilesystem->internalToNormalizedProc(clientData);
-}
-
/*
*----------------------------------------------------------------------
*
@@ -4079,6 +4088,7 @@ TclFSNonnativePathType(
*/
fsRecPtr = FsGetFirstFilesystem();
+ Claim();
while (fsRecPtr != NULL) {
/*
* We want to skip the native filesystem in this loop because
@@ -4156,6 +4166,7 @@ TclFSNonnativePathType(
}
fsRecPtr = fsRecPtr->nextPtr;
}
+ Disclaim();
return type;
}
@@ -4543,10 +4554,14 @@ Tcl_FSGetFileSystemForPath(
*/
fsRecPtr = FsGetFirstFilesystem();
+ Claim();
+
if (TclFSEnsureEpochOk(pathPtr, &retVal) != TCL_OK) {
+ Disclaim();
return NULL;
} else if (retVal != NULL) {
/* TODO: Can this happen? */
+ Disclaim();
return retVal;
}
@@ -4568,10 +4583,12 @@ Tcl_FSGetFileSystemForPath(
* call to the pathInFilesystemProc.
*/
- TclFSSetPathDetails(pathPtr, fsRecPtr, clientData);
+ TclFSSetPathDetails(pathPtr, fsRecPtr->fsPtr, clientData);
+ Disclaim();
return fsRecPtr->fsPtr;
}
}
+ Disclaim();
return NULL;
}
diff --git a/generic/tclIndexObj.c b/generic/tclIndexObj.c
index 8651542..731d759 100644
--- a/generic/tclIndexObj.c
+++ b/generic/tclIndexObj.c
@@ -302,6 +302,10 @@ Tcl_GetIndexFromObjStruct(
entryPtr = NEXT_ENTRY(entryPtr, offset), idx++) {
for (p1 = key, p2 = *entryPtr; *p1 == *p2; p1++, p2++) {
if (*p1 == '\0') {
+ if (p1 == key) {
+ /* empty keys never match */
+ continue;
+ }
index = idx;
goto done;
}
@@ -356,26 +360,31 @@ Tcl_GetIndexFromObjStruct(
* Produce a fancy error message.
*/
- int count;
+ int count = 0;
TclNewObj(resultPtr);
+ entryPtr = tablePtr;
+ while ((*entryPtr != NULL) && !**entryPtr) {
+ entryPtr = NEXT_ENTRY(entryPtr, offset);
+ }
Tcl_AppendStringsToObj(resultPtr,
(numAbbrev>1 && !(flags & TCL_EXACT) ? "ambiguous " : "bad "),
msg, " \"", key, NULL);
- if (STRING_AT(tablePtr, offset, 0) == NULL) {
+ if (*entryPtr == NULL) {
Tcl_AppendStringsToObj(resultPtr, "\": no valid options", NULL);
} else {
Tcl_AppendStringsToObj(resultPtr, "\": must be ",
- STRING_AT(tablePtr, offset, 0), NULL);
- for (entryPtr = NEXT_ENTRY(tablePtr, offset), count = 0;
- *entryPtr != NULL;
- entryPtr = NEXT_ENTRY(entryPtr, offset), count++) {
+ *entryPtr, NULL);
+ entryPtr = NEXT_ENTRY(entryPtr, offset);
+ while (*entryPtr != NULL) {
if (*NEXT_ENTRY(entryPtr, offset) == NULL) {
Tcl_AppendStringsToObj(resultPtr, (count > 0 ? "," : ""),
" or ", *entryPtr, NULL);
- } else {
+ } else if (**entryPtr) {
Tcl_AppendStringsToObj(resultPtr, ", ", *entryPtr, NULL);
+ count++;
}
+ entryPtr = NEXT_ENTRY(entryPtr, offset);
}
}
Tcl_SetObjResult(interp, resultPtr);
@@ -591,8 +600,9 @@ PrefixMatchObjCmd(
flags |= TCL_EXACT;
break;
case PRFMATCH_MESSAGE:
- if (i > (objc - 4)) {
- Tcl_AppendResult(interp, "missing message", NULL);
+ if (i > objc-4) {
+ Tcl_SetObjResult(interp, Tcl_NewStringObj(
+ "missing value for -message", -1));
Tcl_SetErrorCode(interp, "TCL", "OPERATION", "NOARG", NULL);
return TCL_ERROR;
}
@@ -601,7 +611,8 @@ PrefixMatchObjCmd(
break;
case PRFMATCH_ERROR:
if (i > objc-4) {
- Tcl_AppendResult(interp, "missing error options", NULL);
+ Tcl_SetObjResult(interp, Tcl_NewStringObj(
+ "missing value for -error", -1));
Tcl_SetErrorCode(interp, "TCL", "OPERATION", "NOARG", NULL);
return TCL_ERROR;
}
@@ -611,8 +622,9 @@ PrefixMatchObjCmd(
return TCL_ERROR;
}
if ((errorLength % 2) != 0) {
- Tcl_AppendResult(interp, "error options must have an even"
- " number of elements", NULL);
+ Tcl_SetObjResult(interp, Tcl_NewStringObj(
+ "error options must have an even number of elements",
+ -1));
Tcl_SetErrorCode(interp, "TCL", "VALUE", "DICTIONARY", NULL);
return TCL_ERROR;
}
@@ -1165,8 +1177,8 @@ Tcl_ParseArgsObjv(
goto gotMatch;
}
if (matchPtr != NULL) {
- Tcl_AppendResult(interp, "ambiguous option \"", str, "\"",
- NULL);
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "ambiguous option \"%s\"", str));
goto error;
}
matchPtr = infoPtr;
@@ -1178,8 +1190,8 @@ Tcl_ParseArgsObjv(
*/
if (remObjv == NULL) {
- Tcl_AppendResult(interp, "unrecognized argument \"", str,
- "\"", NULL);
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "unrecognized argument \"%s\"", str));
goto error;
}
@@ -1204,9 +1216,9 @@ Tcl_ParseArgsObjv(
}
if (Tcl_GetIntFromObj(interp, objv[srcIndex],
(int *) infoPtr->dstPtr) == TCL_ERROR) {
- Tcl_AppendResult(interp, "expected integer argument for \"",
- infoPtr->keyStr, "\" but got \"",
- Tcl_GetString(objv[srcIndex]), "\"", NULL);
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "expected integer argument for \"%s\" but got \"%s\"",
+ infoPtr->keyStr, Tcl_GetString(objv[srcIndex])));
goto error;
}
srcIndex++;
@@ -1237,9 +1249,9 @@ Tcl_ParseArgsObjv(
}
if (Tcl_GetDoubleFromObj(interp, objv[srcIndex],
(double *) infoPtr->dstPtr) == TCL_ERROR) {
- Tcl_AppendResult(interp, "expected floating-point argument ",
- "for \"", infoPtr->keyStr, "\" but got \"",
- Tcl_GetString(objv[srcIndex]), "\"", NULL);
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "expected floating-point argument for \"%s\" but got \"%s\"",
+ infoPtr->keyStr, Tcl_GetString(objv[srcIndex])));
goto error;
}
srcIndex++;
@@ -1313,8 +1325,8 @@ Tcl_ParseArgsObjv(
*/
missingArg:
- Tcl_AppendResult(interp, "\"", str,
- "\" option requires an additional argument", NULL);
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "\"%s\" option requires an additional argument", str));
error:
if (leftovers != NULL) {
ckfree(leftovers);
@@ -1350,8 +1362,9 @@ PrintUsage(
register const Tcl_ArgvInfo *infoPtr;
int width, numSpaces;
#define NUM_SPACES 20
- static char spaces[] = " ";
+ static const char spaces[] = " ";
char tmp[TCL_DOUBLE_SPACE];
+ Tcl_Obj *msg;
/*
* First, compute the width of the widest option key, so that we can make
@@ -1375,39 +1388,39 @@ PrintUsage(
* Now add the option information, with pretty-printing.
*/
- Tcl_AppendResult(interp, "Command-specific options:", NULL);
+ msg = Tcl_NewStringObj("Command-specific options:", -1);
for (infoPtr = argTable; infoPtr->type != TCL_ARGV_END; infoPtr++) {
if ((infoPtr->type == TCL_ARGV_HELP) && (infoPtr->keyStr == NULL)) {
- Tcl_AppendResult(interp, "\n", infoPtr->helpStr, NULL);
+ Tcl_AppendPrintfToObj(msg, "\n%s", infoPtr->helpStr);
continue;
}
- Tcl_AppendResult(interp, "\n ", infoPtr->keyStr, ":", NULL);
+ Tcl_AppendPrintfToObj(msg, "\n %s:", infoPtr->keyStr);
numSpaces = width + 1 - strlen(infoPtr->keyStr);
while (numSpaces > 0) {
if (numSpaces >= NUM_SPACES) {
- Tcl_AppendResult(interp, spaces, NULL);
+ Tcl_AppendToObj(msg, spaces, NUM_SPACES);
} else {
- Tcl_AppendResult(interp, spaces+NUM_SPACES-numSpaces, NULL);
+ Tcl_AppendToObj(msg, spaces, numSpaces);
}
numSpaces -= NUM_SPACES;
}
- Tcl_AppendResult(interp, infoPtr->helpStr, NULL);
+ Tcl_AppendToObj(msg, infoPtr->helpStr, -1);
switch (infoPtr->type) {
case TCL_ARGV_INT:
- sprintf(tmp, "%d", *((int *) infoPtr->dstPtr));
- Tcl_AppendResult(interp, "\n\t\tDefault value: ", tmp, NULL);
+ Tcl_AppendPrintfToObj(msg, "\n\t\tDefault value: %d",
+ *((int *) infoPtr->dstPtr));
break;
case TCL_ARGV_FLOAT:
+ Tcl_AppendPrintfToObj(msg, "\n\t\tDefault value: %g",
+ *((double *) infoPtr->dstPtr));
sprintf(tmp, "%g", *((double *) infoPtr->dstPtr));
- Tcl_AppendResult(interp, "\n\t\tDefault value: ", tmp, NULL);
break;
case TCL_ARGV_STRING: {
- char *string;
+ char *string = *((char **) infoPtr->dstPtr);
- string = *((char **) infoPtr->dstPtr);
if (string != NULL) {
- Tcl_AppendResult(interp, "\n\t\tDefault value: \"", string,
- "\"", NULL);
+ Tcl_AppendPrintfToObj(msg, "\n\t\tDefault value: \"%s\"",
+ string);
}
break;
}
@@ -1415,6 +1428,7 @@ PrintUsage(
break;
}
}
+ Tcl_SetObjResult(interp, msg);
}
/*
@@ -1426,8 +1440,8 @@ PrintUsage(
*
* Results:
* Returns TCL_ERROR if the value is an invalid completion code.
- * Otherwise, returns TCL_OK, and writes the completion code to
- * the pointer provided.
+ * Otherwise, returns TCL_OK, and writes the completion code to the
+ * pointer provided.
*
* Side effects:
* None.
@@ -1439,30 +1453,30 @@ int
TclGetCompletionCodeFromObj(
Tcl_Interp *interp, /* Current interpreter. */
Tcl_Obj *value,
- int *code) /* Argument objects. */
+ int *codePtr) /* Argument objects. */
{
static const char *const returnCodes[] = {
"ok", "error", "return", "break", "continue", NULL
};
if ((value->typePtr != &indexType)
- && (TCL_OK == TclGetIntFromObj(NULL, value, code))) {
+ && TclGetIntFromObj(NULL, value, codePtr) == TCL_OK) {
return TCL_OK;
}
- if (TCL_OK == Tcl_GetIndexFromObj(NULL, value, returnCodes, NULL,
- TCL_EXACT, code)) {
+ if (Tcl_GetIndexFromObj(NULL, value, returnCodes, NULL, TCL_EXACT,
+ codePtr) == TCL_OK) {
return TCL_OK;
}
+
/*
* Value is not a legal completion code.
*/
if (interp != NULL) {
- Tcl_ResetResult(interp);
- Tcl_AppendResult(interp, "bad completion code \"",
- TclGetString(value),
- "\": must be ok, error, return, break, "
- "continue, or an integer", NULL);
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "bad completion code \"%s\": must be"
+ " ok, error, return, break, continue, or an integer",
+ TclGetString(value)));
Tcl_SetErrorCode(interp, "TCL", "RESULT", "ILLEGAL_CODE", NULL);
}
return TCL_ERROR;
diff --git a/generic/tclInt.decls b/generic/tclInt.decls
index ddda097..9f73a31 100644
--- a/generic/tclInt.decls
+++ b/generic/tclInt.decls
@@ -126,8 +126,8 @@ declare 25 {
# }
# Removed in 8.5
#declare 27 {
-# int TclGetDate(char *p, Tcl_WideInt now, long zone,
-# Tcl_WideInt *timePtr)
+# int TclGetDate(char *p, unsigned long now, long zone,
+# unsigned long *timePtr)
#}
declare 28 {
Tcl_Channel TclpGetDefaultStdChannel(int type)
@@ -188,7 +188,7 @@ declare 42 {
}
# Removed in Tcl 8.5a2
#declare 43 {
-# int TclGlobalInvoke(Tcl_Interp *interp, int argc, const char **argv,
+# int TclGlobalInvoke(Tcl_Interp *interp, int argc, CONST84 char **argv,
# int flags)
#}
declare 44 {
@@ -223,7 +223,7 @@ declare 51 {
}
# Removed in Tcl 8.5a2
#declare 52 {
-# int TclInvoke(Tcl_Interp *interp, int argc, const char **argv,
+# int TclInvoke(Tcl_Interp *interp, int argc, CONST84 char **argv,
# int flags)
#}
declare 53 {
@@ -423,9 +423,6 @@ declare 103 {
declare 104 {
int TclSockMinimumBuffersOld(int sock, int size)
}
-declare 110 {
- int TclSockMinimumBuffers(void *sock, int size)
-}
# Replaced by Tcl_FSStat in 8.4:
#declare 105 {
# int TclStat(const char *path, Tcl_StatBuf *buf)
@@ -442,6 +439,9 @@ declare 108 {
declare 109 {
int TclUpdateReturnInfo(Interp *iPtr)
}
+declare 110 {
+ int TclSockMinimumBuffers(void *sock, int size)
+}
# Removed in 8.1:
# declare 110 {
# char *TclWordEnd(char *start, char *lastChar, int nested, int *semiPtr)
@@ -739,6 +739,16 @@ declare 177 {
# Tcl_Obj *Tcl_GetStartupScript(const char **encodingNamePtr)
#}
+# REMOVED
+# Allocate lists without copying arrays
+# declare 180 {
+# Tcl_Obj *TclNewListObjDirect(int objc, Tcl_Obj **objv)
+# }
+#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 {
@@ -1024,23 +1034,31 @@ declare 3 win {
declare 4 win {
HINSTANCE TclWinGetTclInstance(void)
}
+# new for 8.4.20+/8.5.12+ Cygwin only
+declare 5 win {
+ int TclUnixWaitForFile(int fd, int mask, int timeout)
+}
# Removed in 8.1:
# declare 5 win {
# HINSTANCE TclWinLoadLibrary(char *name)
# }
declare 6 win {
- u_short TclWinNToHS(u_short ns)
+ unsigned short TclWinNToHS(unsigned short ns)
}
declare 7 win {
int TclWinSetSockOpt(SOCKET s, int level, int optname,
const char *optval, int optlen)
}
declare 8 win {
- unsigned long TclpGetPid(Tcl_Pid pid)
+ int TclpGetPid(Tcl_Pid pid)
}
declare 9 win {
int TclWinGetPlatformId(void)
}
+# 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)
#declare 10 win {
# int TclWinSynchSpawn(void *args, int type, void **trans, Tcl_Pid *pidPtr)
@@ -1062,9 +1080,13 @@ declare 14 win {
int TclpCreatePipe(TclFile *readPipe, TclFile *writePipe)
}
declare 15 win {
- int TclpCreateProcess(Tcl_Interp *interp, int argc, const char **argv,
- TclFile inputFile, TclFile outputFile, TclFile errorFile,
- Tcl_Pid *pidPtr)
+ int TclpCreateProcess(Tcl_Interp *interp, int argc,
+ const char **argv, TclFile inputFile, TclFile outputFile,
+ TclFile errorFile, Tcl_Pid *pidPtr)
+}
+# new for 8.4.20+/8.5.12+ Cygwin only
+declare 16 win {
+ int TclpIsAtty(int fd)
}
# Signature changed in 8.1:
# declare 16 win {
@@ -1073,6 +1095,11 @@ declare 15 win {
# declare 17 win {
# char *TclpGetTZName(void)
# }
+# new for 8.5.12+ Cygwin only
+declare 17 win {
+ int TclUnixCopyFile(const char *src, const char *dst,
+ const Tcl_StatBuf *statBufPtr, int dontCopyAtts)
+}
declare 18 win {
TclFile TclpMakeFile(Tcl_Channel channel, int direction)
}
@@ -1082,7 +1109,10 @@ declare 19 win {
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 {
# void TclpAsyncMark(Tcl_AsyncHandler async)
@@ -1127,13 +1157,11 @@ declare 29 win {
# Pipe channel functions
-# On non-cygwin, this is actually a reference to TclGetAndDetachPids
declare 0 unix {
- void TclWinConvertError(unsigned int errCode)
+ void TclGetAndDetachPids(Tcl_Interp *interp, Tcl_Channel chan)
}
-# On non-cygwin, this is actually a reference to TclpCloseFile
declare 1 unix {
- void TclWinConvertWSAError(unsigned int errCode)
+ int TclpCloseFile(TclFile file)
}
declare 2 unix {
Tcl_Channel TclpCreateCommandChannel(TclFile readFile,
@@ -1142,23 +1170,20 @@ declare 2 unix {
declare 3 unix {
int TclpCreatePipe(TclFile *readPipe, TclFile *writePipe)
}
-# On non-cygwin, this is actually a reference to TclpCreateProcess
declare 4 unix {
- void *TclWinGetTclInstance(void)
+ int TclpCreateProcess(Tcl_Interp *interp, int argc,
+ const char **argv, TclFile inputFile, TclFile outputFile,
+ TclFile errorFile, Tcl_Pid *pidPtr)
}
# Signature changed in 8.1:
# declare 5 unix {
# TclFile TclpCreateTempFile(char *contents, Tcl_DString *namePtr)
# }
-
-# On non-cygwin, this is actually a reference to TclpMakeFile
declare 6 unix {
- unsigned short TclWinNToHS(unsigned short ns)
+ TclFile TclpMakeFile(Tcl_Channel channel, int direction)
}
-# On non-cygwin, this is actually a reference to TclpOpenFile
declare 7 unix {
- int TclWinSetSockOpt(void *s, int level, int optname,
- const char *optval, int optlen)
+ TclFile TclpOpenFile(const char *fname, int mode)
}
declare 8 unix {
int TclUnixWaitForFile(int fd, int mask, int timeout)
@@ -1166,9 +1191,8 @@ declare 8 unix {
# Added in 8.1:
-# On non-cygwin, this is actually a reference to TclpCreateTempFile
declare 9 unix {
- int TclWinGetPlatformId(void)
+ TclFile TclpCreateTempFile(const char *contents)
}
# Added in 8.4:
@@ -1178,11 +1202,9 @@ declare 10 unix {
}
# Slots 11 and 12 are forwarders for functions that were promoted to
# generic Stubs
-# On cygwin, this is actually a reference to TclGetAndDetachPids
declare 11 unix {
struct tm *TclpLocaltime_unix(const time_t *clock)
}
-# On cygwin, this is actually a reference to TclpCloseFile
declare 12 unix {
struct tm *TclpGmtime_unix(const time_t *clock)
}
@@ -1200,8 +1222,7 @@ declare 14 unix {
################################
# Mac OS X specific functions
-#On cygwin, TclpCreateProcess is here
-declare 15 {unix macosx} {
+declare 15 macosx {
int TclMacOSXGetFileAttribute(Tcl_Interp *interp, int objIndex,
Tcl_Obj *fileName, Tcl_Obj **attributePtrPtr)
}
@@ -1213,44 +1234,17 @@ declare 17 macosx {
int TclMacOSXCopyFileAttributes(const char *src, const char *dst,
const Tcl_StatBuf *statBufPtr)
}
-#On cygwin, TclpMakeFile is here
-declare 18 {unix macosx} {
+declare 18 macosx {
int TclMacOSXMatchType(Tcl_Interp *interp, const char *pathName,
const char *fileName, Tcl_StatBuf *statBufPtr,
Tcl_GlobTypeData *types)
}
-#On cygwin, TclpOpenFile is here
-declare 19 {unix macosx} {
+declare 19 macosx {
void TclMacOSXNotifierAddRunLoopMode(const void *runLoopMode)
}
-declare 20 unix {
- void TclWinAddProcess(void *hProcess, unsigned int id)
-}
-declare 22 unix {
- TclFile TclpCreateTempFile(const char *contents)
-}
-declare 24 unix {
- char *TclWinNoBackslash(char *path)
-}
-declare 26 unix {
- void TclWinSetInterfaces(int wide)
-}
-declare 27 unix {
- void TclWinFlushDirtyChannels(void)
-}
-declare 28 unix {
- void TclWinResetInterfaces(void)
-}
declare 29 unix {
int TclWinCPUID(unsigned int index, unsigned int *regs)
}
-declare 30 unix {
- void TclGetAndDetachPids(Tcl_Interp *interp, Tcl_Channel chan)
-}
-declare 31 unix {
- int TclpCloseFile(TclFile file)
-}
-
# Local Variables:
# mode: tcl
diff --git a/generic/tclInt.h b/generic/tclInt.h
index bc7cd9f..92aed38 100644
--- a/generic/tclInt.h
+++ b/generic/tclInt.h
@@ -2920,6 +2920,11 @@ MODULE_SCOPE void TclCreateLateExitHandler(Tcl_ExitProc *proc,
ClientData clientData);
MODULE_SCOPE void TclDeleteLateExitHandler(Tcl_ExitProc *proc,
ClientData clientData);
+MODULE_SCOPE char * TclDStringAppendObj(Tcl_DString *dsPtr,
+ Tcl_Obj *objPtr);
+MODULE_SCOPE char * TclDStringAppendDString(Tcl_DString *dsPtr,
+ Tcl_DString *toAppendPtr);
+MODULE_SCOPE Tcl_Obj * TclDStringToObj(Tcl_DString *dsPtr);
MODULE_SCOPE void TclFinalizeAllocSubsystem(void);
MODULE_SCOPE void TclFinalizeAsync(void);
MODULE_SCOPE void TclFinalizeDoubleConversion(void);
@@ -4460,6 +4465,21 @@ MODULE_SCOPE Tcl_PackageInitProc Procbodytest_SafeInit;
/*
*----------------------------------------------------------------
+ * Convenience macros for DStrings.
+ * The ANSI C "prototypes" for these macros are:
+ *
+ * MODULE_SCOPE char * TclDStringAppendLiteral(Tcl_DString *dsPtr,
+ * const char *sLiteral);
+ * MODULE_SCOPE void TclDStringClear(Tcl_DString *dsPtr);
+ */
+
+#define TclDStringAppendLiteral(dsPtr, sLiteral) \
+ Tcl_DStringAppend((dsPtr), (sLiteral), (int) (sizeof(sLiteral "") - 1))
+#define TclDStringClear(dsPtr) \
+ Tcl_DStringSetLength((dsPtr), 0)
+
+/*
+ *----------------------------------------------------------------
* Macros used by the Tcl core to test for some special double values.
* The ANSI C "prototypes" for these macros are:
*
diff --git a/generic/tclIntPlatDecls.h b/generic/tclIntPlatDecls.h
index bea9037..7322a37 100644
--- a/generic/tclIntPlatDecls.h
+++ b/generic/tclIntPlatDecls.h
@@ -13,6 +13,11 @@
#ifndef _TCLINTPLATDECLS
#define _TCLINTPLATDECLS
+#ifdef __WIN32__
+# define Tcl_DirEntry void
+# define DIR void
+#endif
+
#undef TCL_STORAGE_CLASS
#ifdef BUILD_tcl
# define TCL_STORAGE_CLASS DLLEXPORT
@@ -24,16 +29,6 @@
# endif
#endif
-#if !defined(__WIN32__) /* UNIX */
-EXTERN int TclpCreateProcess(Tcl_Interp *interp,
- int argc, CONST char **argv, TclFile inputFile,
- TclFile outputFile, TclFile errorFile, Tcl_Pid *pidPtr);
-EXTERN TclFile TclpMakeFile(Tcl_Channel channel,
- int direction);
-EXTERN TclFile TclpOpenFile(CONST char *fname,
- int mode);
-#endif
-
/*
* WARNING: This file is automatically generated by the tools/genStubs.tcl
* script. Any modifications to the function declarations below should be made
@@ -46,11 +41,12 @@ EXTERN TclFile TclpOpenFile(CONST char *fname,
* Exported function declarations:
*/
-#if !defined(__WIN32__) && !defined(MAC_OSX_TCL) /* UNIX */
+#if !defined(__WIN32__) && !defined(__CYGWIN__) && !defined(MAC_OSX_TCL) /* UNIX */
/* 0 */
-EXTERN void TclWinConvertError(unsigned int errCode);
+EXTERN void TclGetAndDetachPids(Tcl_Interp *interp,
+ Tcl_Channel chan);
/* 1 */
-EXTERN void TclWinConvertWSAError(unsigned int errCode);
+EXTERN int TclpCloseFile(TclFile file);
/* 2 */
EXTERN Tcl_Channel TclpCreateCommandChannel(TclFile readFile,
TclFile writeFile, TclFile errorFile,
@@ -58,17 +54,19 @@ EXTERN Tcl_Channel TclpCreateCommandChannel(TclFile readFile,
/* 3 */
EXTERN int TclpCreatePipe(TclFile *readPipe, TclFile *writePipe);
/* 4 */
-EXTERN void * TclWinGetTclInstance(void);
+EXTERN int TclpCreateProcess(Tcl_Interp *interp, int argc,
+ const char **argv, TclFile inputFile,
+ TclFile outputFile, TclFile errorFile,
+ Tcl_Pid *pidPtr);
/* Slot 5 is reserved */
/* 6 */
-EXTERN unsigned short TclWinNToHS(unsigned short ns);
+EXTERN TclFile TclpMakeFile(Tcl_Channel channel, int direction);
/* 7 */
-EXTERN int TclWinSetSockOpt(void *s, int level, int optname,
- const char *optval, int optlen);
+EXTERN TclFile TclpOpenFile(const char *fname, int mode);
/* 8 */
EXTERN int TclUnixWaitForFile(int fd, int mask, int timeout);
/* 9 */
-EXTERN int TclWinGetPlatformId(void);
+EXTERN TclFile TclpCreateTempFile(const char *contents);
/* 10 */
EXTERN Tcl_DirEntry * TclpReaddir(DIR *dir);
/* 11 */
@@ -81,44 +79,24 @@ EXTERN char * TclpInetNtoa(struct in_addr addr);
EXTERN int TclUnixCopyFile(const char *src, const char *dst,
const Tcl_StatBuf *statBufPtr,
int dontCopyAtts);
-/* 15 */
-EXTERN int TclMacOSXGetFileAttribute(Tcl_Interp *interp,
- int objIndex, Tcl_Obj *fileName,
- Tcl_Obj **attributePtrPtr);
+/* Slot 15 is reserved */
/* Slot 16 is reserved */
/* Slot 17 is reserved */
-/* 18 */
-EXTERN int TclMacOSXMatchType(Tcl_Interp *interp,
- const char *pathName, const char *fileName,
- Tcl_StatBuf *statBufPtr,
- Tcl_GlobTypeData *types);
-/* 19 */
-EXTERN void TclMacOSXNotifierAddRunLoopMode(
- const void *runLoopMode);
-/* 20 */
-EXTERN void TclWinAddProcess(void *hProcess, unsigned int id);
+/* Slot 18 is reserved */
+/* Slot 19 is reserved */
+/* Slot 20 is reserved */
/* Slot 21 is reserved */
-/* 22 */
-EXTERN TclFile TclpCreateTempFile(const char *contents);
+/* Slot 22 is reserved */
/* Slot 23 is reserved */
-/* 24 */
-EXTERN char * TclWinNoBackslash(char *path);
+/* Slot 24 is reserved */
/* Slot 25 is reserved */
-/* 26 */
-EXTERN void TclWinSetInterfaces(int wide);
-/* 27 */
-EXTERN void TclWinFlushDirtyChannels(void);
-/* 28 */
-EXTERN void TclWinResetInterfaces(void);
+/* Slot 26 is reserved */
+/* Slot 27 is reserved */
+/* Slot 28 is reserved */
/* 29 */
EXTERN int TclWinCPUID(unsigned int index, unsigned int *regs);
-/* 30 */
-EXTERN void TclGetAndDetachPids(Tcl_Interp *interp,
- Tcl_Channel chan);
-/* 31 */
-EXTERN int TclpCloseFile(TclFile file);
#endif /* UNIX */
-#ifdef __WIN32__ /* WIN */
+#if defined(__WIN32__) || defined(__CYGWIN__) /* WIN */
/* 0 */
EXTERN void TclWinConvertError(DWORD errCode);
/* 1 */
@@ -131,17 +109,19 @@ EXTERN int TclWinGetSockOpt(SOCKET s, int level, int optname,
char *optval, int *optlen);
/* 4 */
EXTERN HINSTANCE TclWinGetTclInstance(void);
-/* Slot 5 is reserved */
+/* 5 */
+EXTERN int TclUnixWaitForFile(int fd, int mask, int timeout);
/* 6 */
-EXTERN u_short TclWinNToHS(u_short ns);
+EXTERN unsigned short TclWinNToHS(unsigned short ns);
/* 7 */
EXTERN int TclWinSetSockOpt(SOCKET s, int level, int optname,
const char *optval, int optlen);
/* 8 */
-EXTERN unsigned long TclpGetPid(Tcl_Pid pid);
+EXTERN int TclpGetPid(Tcl_Pid pid);
/* 9 */
EXTERN int TclWinGetPlatformId(void);
-/* Slot 10 is reserved */
+/* 10 */
+EXTERN Tcl_DirEntry * TclpReaddir(DIR *dir);
/* 11 */
EXTERN void TclGetAndDetachPids(Tcl_Interp *interp,
Tcl_Channel chan);
@@ -158,15 +138,20 @@ EXTERN int TclpCreateProcess(Tcl_Interp *interp, int argc,
const char **argv, TclFile inputFile,
TclFile outputFile, TclFile errorFile,
Tcl_Pid *pidPtr);
-/* Slot 16 is reserved */
-/* Slot 17 is reserved */
+/* 16 */
+EXTERN int TclpIsAtty(int fd);
+/* 17 */
+EXTERN int TclUnixCopyFile(const char *src, const char *dst,
+ const Tcl_StatBuf *statBufPtr,
+ int dontCopyAtts);
/* 18 */
EXTERN TclFile TclpMakeFile(Tcl_Channel channel, int direction);
/* 19 */
EXTERN TclFile TclpOpenFile(const char *fname, int mode);
/* 20 */
EXTERN void TclWinAddProcess(HANDLE hProcess, DWORD id);
-/* Slot 21 is reserved */
+/* 21 */
+EXTERN char * TclpInetNtoa(struct in_addr addr);
/* 22 */
EXTERN TclFile TclpCreateTempFile(const char *contents);
/* Slot 23 is reserved */
@@ -184,9 +169,10 @@ EXTERN int TclWinCPUID(unsigned int index, unsigned int *regs);
#endif /* WIN */
#ifdef MAC_OSX_TCL /* MACOSX */
/* 0 */
-EXTERN void TclWinConvertError(unsigned int errCode);
+EXTERN void TclGetAndDetachPids(Tcl_Interp *interp,
+ Tcl_Channel chan);
/* 1 */
-EXTERN void TclWinConvertWSAError(unsigned int errCode);
+EXTERN int TclpCloseFile(TclFile file);
/* 2 */
EXTERN Tcl_Channel TclpCreateCommandChannel(TclFile readFile,
TclFile writeFile, TclFile errorFile,
@@ -194,17 +180,19 @@ EXTERN Tcl_Channel TclpCreateCommandChannel(TclFile readFile,
/* 3 */
EXTERN int TclpCreatePipe(TclFile *readPipe, TclFile *writePipe);
/* 4 */
-EXTERN void * TclWinGetTclInstance(void);
+EXTERN int TclpCreateProcess(Tcl_Interp *interp, int argc,
+ const char **argv, TclFile inputFile,
+ TclFile outputFile, TclFile errorFile,
+ Tcl_Pid *pidPtr);
/* Slot 5 is reserved */
/* 6 */
-EXTERN unsigned short TclWinNToHS(unsigned short ns);
+EXTERN TclFile TclpMakeFile(Tcl_Channel channel, int direction);
/* 7 */
-EXTERN int TclWinSetSockOpt(void *s, int level, int optname,
- const char *optval, int optlen);
+EXTERN TclFile TclpOpenFile(const char *fname, int mode);
/* 8 */
EXTERN int TclUnixWaitForFile(int fd, int mask, int timeout);
/* 9 */
-EXTERN int TclWinGetPlatformId(void);
+EXTERN TclFile TclpCreateTempFile(const char *contents);
/* 10 */
EXTERN Tcl_DirEntry * TclpReaddir(DIR *dir);
/* 11 */
@@ -237,91 +225,78 @@ EXTERN int TclMacOSXMatchType(Tcl_Interp *interp,
/* 19 */
EXTERN void TclMacOSXNotifierAddRunLoopMode(
const void *runLoopMode);
-/* 20 */
-EXTERN void TclWinAddProcess(void *hProcess, unsigned int id);
+/* Slot 20 is reserved */
/* Slot 21 is reserved */
-/* 22 */
-EXTERN TclFile TclpCreateTempFile(const char *contents);
+/* Slot 22 is reserved */
/* Slot 23 is reserved */
-/* 24 */
-EXTERN char * TclWinNoBackslash(char *path);
+/* Slot 24 is reserved */
/* Slot 25 is reserved */
-/* 26 */
-EXTERN void TclWinSetInterfaces(int wide);
-/* 27 */
-EXTERN void TclWinFlushDirtyChannels(void);
-/* 28 */
-EXTERN void TclWinResetInterfaces(void);
+/* Slot 26 is reserved */
+/* Slot 27 is reserved */
+/* Slot 28 is reserved */
/* 29 */
EXTERN int TclWinCPUID(unsigned int index, unsigned int *regs);
-/* 30 */
-EXTERN void TclGetAndDetachPids(Tcl_Interp *interp,
- Tcl_Channel chan);
-/* 31 */
-EXTERN int TclpCloseFile(TclFile file);
#endif /* MACOSX */
typedef struct TclIntPlatStubs {
int magic;
const struct TclIntPlatStubHooks *hooks;
-#if !defined(__WIN32__) && !defined(MAC_OSX_TCL) /* UNIX */
- void (*tclWinConvertError) (unsigned int errCode); /* 0 */
- void (*tclWinConvertWSAError) (unsigned int errCode); /* 1 */
+#if !defined(__WIN32__) && !defined(__CYGWIN__) && !defined(MAC_OSX_TCL) /* UNIX */
+ void (*tclGetAndDetachPids) (Tcl_Interp *interp, Tcl_Channel chan); /* 0 */
+ int (*tclpCloseFile) (TclFile file); /* 1 */
Tcl_Channel (*tclpCreateCommandChannel) (TclFile readFile, TclFile writeFile, TclFile errorFile, int numPids, Tcl_Pid *pidPtr); /* 2 */
int (*tclpCreatePipe) (TclFile *readPipe, TclFile *writePipe); /* 3 */
- void * (*tclWinGetTclInstance) (void); /* 4 */
+ int (*tclpCreateProcess) (Tcl_Interp *interp, int argc, const char **argv, TclFile inputFile, TclFile outputFile, TclFile errorFile, Tcl_Pid *pidPtr); /* 4 */
void (*reserved5)(void);
- unsigned short (*tclWinNToHS) (unsigned short ns); /* 6 */
- int (*tclWinSetSockOpt) (void *s, int level, int optname, const char *optval, int optlen); /* 7 */
+ TclFile (*tclpMakeFile) (Tcl_Channel channel, int direction); /* 6 */
+ TclFile (*tclpOpenFile) (const char *fname, int mode); /* 7 */
int (*tclUnixWaitForFile) (int fd, int mask, int timeout); /* 8 */
- int (*tclWinGetPlatformId) (void); /* 9 */
+ TclFile (*tclpCreateTempFile) (const char *contents); /* 9 */
Tcl_DirEntry * (*tclpReaddir) (DIR *dir); /* 10 */
struct tm * (*tclpLocaltime_unix) (const time_t *clock); /* 11 */
struct tm * (*tclpGmtime_unix) (const time_t *clock); /* 12 */
char * (*tclpInetNtoa) (struct in_addr addr); /* 13 */
int (*tclUnixCopyFile) (const char *src, const char *dst, const Tcl_StatBuf *statBufPtr, int dontCopyAtts); /* 14 */
- int (*tclMacOSXGetFileAttribute) (Tcl_Interp *interp, int objIndex, Tcl_Obj *fileName, Tcl_Obj **attributePtrPtr); /* 15 */
+ void (*reserved15)(void);
void (*reserved16)(void);
void (*reserved17)(void);
- int (*tclMacOSXMatchType) (Tcl_Interp *interp, const char *pathName, const char *fileName, Tcl_StatBuf *statBufPtr, Tcl_GlobTypeData *types); /* 18 */
- void (*tclMacOSXNotifierAddRunLoopMode) (const void *runLoopMode); /* 19 */
- void (*tclWinAddProcess) (void *hProcess, unsigned int id); /* 20 */
+ void (*reserved18)(void);
+ void (*reserved19)(void);
+ void (*reserved20)(void);
void (*reserved21)(void);
- TclFile (*tclpCreateTempFile) (const char *contents); /* 22 */
+ void (*reserved22)(void);
void (*reserved23)(void);
- char * (*tclWinNoBackslash) (char *path); /* 24 */
+ void (*reserved24)(void);
void (*reserved25)(void);
- void (*tclWinSetInterfaces) (int wide); /* 26 */
- void (*tclWinFlushDirtyChannels) (void); /* 27 */
- void (*tclWinResetInterfaces) (void); /* 28 */
+ void (*reserved26)(void);
+ void (*reserved27)(void);
+ void (*reserved28)(void);
int (*tclWinCPUID) (unsigned int index, unsigned int *regs); /* 29 */
- void (*tclGetAndDetachPids) (Tcl_Interp *interp, Tcl_Channel chan); /* 30 */
- int (*tclpCloseFile) (TclFile file); /* 31 */
#endif /* UNIX */
-#ifdef __WIN32__ /* WIN */
+#if defined(__WIN32__) || defined(__CYGWIN__) /* WIN */
void (*tclWinConvertError) (DWORD errCode); /* 0 */
void (*tclWinConvertWSAError) (DWORD errCode); /* 1 */
struct servent * (*tclWinGetServByName) (const char *nm, const char *proto); /* 2 */
int (*tclWinGetSockOpt) (SOCKET s, int level, int optname, char *optval, int *optlen); /* 3 */
HINSTANCE (*tclWinGetTclInstance) (void); /* 4 */
- void (*reserved5)(void);
- u_short (*tclWinNToHS) (u_short ns); /* 6 */
+ int (*tclUnixWaitForFile) (int fd, int mask, int timeout); /* 5 */
+ unsigned short (*tclWinNToHS) (unsigned short ns); /* 6 */
int (*tclWinSetSockOpt) (SOCKET s, int level, int optname, const char *optval, int optlen); /* 7 */
- unsigned long (*tclpGetPid) (Tcl_Pid pid); /* 8 */
+ int (*tclpGetPid) (Tcl_Pid pid); /* 8 */
int (*tclWinGetPlatformId) (void); /* 9 */
- void (*reserved10)(void);
+ Tcl_DirEntry * (*tclpReaddir) (DIR *dir); /* 10 */
void (*tclGetAndDetachPids) (Tcl_Interp *interp, Tcl_Channel chan); /* 11 */
int (*tclpCloseFile) (TclFile file); /* 12 */
Tcl_Channel (*tclpCreateCommandChannel) (TclFile readFile, TclFile writeFile, TclFile errorFile, int numPids, Tcl_Pid *pidPtr); /* 13 */
int (*tclpCreatePipe) (TclFile *readPipe, TclFile *writePipe); /* 14 */
int (*tclpCreateProcess) (Tcl_Interp *interp, int argc, const char **argv, TclFile inputFile, TclFile outputFile, TclFile errorFile, Tcl_Pid *pidPtr); /* 15 */
- void (*reserved16)(void);
- void (*reserved17)(void);
+ int (*tclpIsAtty) (int fd); /* 16 */
+ int (*tclUnixCopyFile) (const char *src, const char *dst, const Tcl_StatBuf *statBufPtr, int dontCopyAtts); /* 17 */
TclFile (*tclpMakeFile) (Tcl_Channel channel, int direction); /* 18 */
TclFile (*tclpOpenFile) (const char *fname, int mode); /* 19 */
void (*tclWinAddProcess) (HANDLE hProcess, DWORD id); /* 20 */
- void (*reserved21)(void);
+ char * (*tclpInetNtoa) (struct in_addr addr); /* 21 */
TclFile (*tclpCreateTempFile) (const char *contents); /* 22 */
void (*reserved23)(void);
char * (*tclWinNoBackslash) (char *path); /* 24 */
@@ -332,16 +307,16 @@ typedef struct TclIntPlatStubs {
int (*tclWinCPUID) (unsigned int index, unsigned int *regs); /* 29 */
#endif /* WIN */
#ifdef MAC_OSX_TCL /* MACOSX */
- void (*tclWinConvertError) (unsigned int errCode); /* 0 */
- void (*tclWinConvertWSAError) (unsigned int errCode); /* 1 */
+ void (*tclGetAndDetachPids) (Tcl_Interp *interp, Tcl_Channel chan); /* 0 */
+ int (*tclpCloseFile) (TclFile file); /* 1 */
Tcl_Channel (*tclpCreateCommandChannel) (TclFile readFile, TclFile writeFile, TclFile errorFile, int numPids, Tcl_Pid *pidPtr); /* 2 */
int (*tclpCreatePipe) (TclFile *readPipe, TclFile *writePipe); /* 3 */
- void * (*tclWinGetTclInstance) (void); /* 4 */
+ int (*tclpCreateProcess) (Tcl_Interp *interp, int argc, const char **argv, TclFile inputFile, TclFile outputFile, TclFile errorFile, Tcl_Pid *pidPtr); /* 4 */
void (*reserved5)(void);
- unsigned short (*tclWinNToHS) (unsigned short ns); /* 6 */
- int (*tclWinSetSockOpt) (void *s, int level, int optname, const char *optval, int optlen); /* 7 */
+ TclFile (*tclpMakeFile) (Tcl_Channel channel, int direction); /* 6 */
+ TclFile (*tclpOpenFile) (const char *fname, int mode); /* 7 */
int (*tclUnixWaitForFile) (int fd, int mask, int timeout); /* 8 */
- int (*tclWinGetPlatformId) (void); /* 9 */
+ TclFile (*tclpCreateTempFile) (const char *contents); /* 9 */
Tcl_DirEntry * (*tclpReaddir) (DIR *dir); /* 10 */
struct tm * (*tclpLocaltime_unix) (const time_t *clock); /* 11 */
struct tm * (*tclpGmtime_unix) (const time_t *clock); /* 12 */
@@ -352,18 +327,16 @@ typedef struct TclIntPlatStubs {
int (*tclMacOSXCopyFileAttributes) (const char *src, const char *dst, const Tcl_StatBuf *statBufPtr); /* 17 */
int (*tclMacOSXMatchType) (Tcl_Interp *interp, const char *pathName, const char *fileName, Tcl_StatBuf *statBufPtr, Tcl_GlobTypeData *types); /* 18 */
void (*tclMacOSXNotifierAddRunLoopMode) (const void *runLoopMode); /* 19 */
- void (*tclWinAddProcess) (void *hProcess, unsigned int id); /* 20 */
+ void (*reserved20)(void);
void (*reserved21)(void);
- TclFile (*tclpCreateTempFile) (const char *contents); /* 22 */
+ void (*reserved22)(void);
void (*reserved23)(void);
- char * (*tclWinNoBackslash) (char *path); /* 24 */
+ void (*reserved24)(void);
void (*reserved25)(void);
- void (*tclWinSetInterfaces) (int wide); /* 26 */
- void (*tclWinFlushDirtyChannels) (void); /* 27 */
- void (*tclWinResetInterfaces) (void); /* 28 */
+ void (*reserved26)(void);
+ void (*reserved27)(void);
+ void (*reserved28)(void);
int (*tclWinCPUID) (unsigned int index, unsigned int *regs); /* 29 */
- void (*tclGetAndDetachPids) (Tcl_Interp *interp, Tcl_Channel chan); /* 30 */
- int (*tclpCloseFile) (TclFile file); /* 31 */
#endif /* MACOSX */
} TclIntPlatStubs;
@@ -381,26 +354,26 @@ extern const TclIntPlatStubs *tclIntPlatStubsPtr;
* Inline function declarations:
*/
-#if !defined(__WIN32__) && !defined(MAC_OSX_TCL) /* UNIX */
-#define TclWinConvertError \
- (tclIntPlatStubsPtr->tclWinConvertError) /* 0 */
-#define TclWinConvertWSAError \
- (tclIntPlatStubsPtr->tclWinConvertWSAError) /* 1 */
+#if !defined(__WIN32__) && !defined(__CYGWIN__) && !defined(MAC_OSX_TCL) /* UNIX */
+#define TclGetAndDetachPids \
+ (tclIntPlatStubsPtr->tclGetAndDetachPids) /* 0 */
+#define TclpCloseFile \
+ (tclIntPlatStubsPtr->tclpCloseFile) /* 1 */
#define TclpCreateCommandChannel \
(tclIntPlatStubsPtr->tclpCreateCommandChannel) /* 2 */
#define TclpCreatePipe \
(tclIntPlatStubsPtr->tclpCreatePipe) /* 3 */
-#define TclWinGetTclInstance \
- (tclIntPlatStubsPtr->tclWinGetTclInstance) /* 4 */
+#define TclpCreateProcess \
+ (tclIntPlatStubsPtr->tclpCreateProcess) /* 4 */
/* Slot 5 is reserved */
-#define TclWinNToHS \
- (tclIntPlatStubsPtr->tclWinNToHS) /* 6 */
-#define TclWinSetSockOpt \
- (tclIntPlatStubsPtr->tclWinSetSockOpt) /* 7 */
+#define TclpMakeFile \
+ (tclIntPlatStubsPtr->tclpMakeFile) /* 6 */
+#define TclpOpenFile \
+ (tclIntPlatStubsPtr->tclpOpenFile) /* 7 */
#define TclUnixWaitForFile \
(tclIntPlatStubsPtr->tclUnixWaitForFile) /* 8 */
-#define TclWinGetPlatformId \
- (tclIntPlatStubsPtr->tclWinGetPlatformId) /* 9 */
+#define TclpCreateTempFile \
+ (tclIntPlatStubsPtr->tclpCreateTempFile) /* 9 */
#define TclpReaddir \
(tclIntPlatStubsPtr->tclpReaddir) /* 10 */
#define TclpLocaltime_unix \
@@ -411,37 +384,24 @@ extern const TclIntPlatStubs *tclIntPlatStubsPtr;
(tclIntPlatStubsPtr->tclpInetNtoa) /* 13 */
#define TclUnixCopyFile \
(tclIntPlatStubsPtr->tclUnixCopyFile) /* 14 */
-#define TclMacOSXGetFileAttribute \
- (tclIntPlatStubsPtr->tclMacOSXGetFileAttribute) /* 15 */
+/* Slot 15 is reserved */
/* Slot 16 is reserved */
/* Slot 17 is reserved */
-#define TclMacOSXMatchType \
- (tclIntPlatStubsPtr->tclMacOSXMatchType) /* 18 */
-#define TclMacOSXNotifierAddRunLoopMode \
- (tclIntPlatStubsPtr->tclMacOSXNotifierAddRunLoopMode) /* 19 */
-#define TclWinAddProcess \
- (tclIntPlatStubsPtr->tclWinAddProcess) /* 20 */
+/* Slot 18 is reserved */
+/* Slot 19 is reserved */
+/* Slot 20 is reserved */
/* Slot 21 is reserved */
-#define TclpCreateTempFile \
- (tclIntPlatStubsPtr->tclpCreateTempFile) /* 22 */
+/* Slot 22 is reserved */
/* Slot 23 is reserved */
-#define TclWinNoBackslash \
- (tclIntPlatStubsPtr->tclWinNoBackslash) /* 24 */
+/* Slot 24 is reserved */
/* Slot 25 is reserved */
-#define TclWinSetInterfaces \
- (tclIntPlatStubsPtr->tclWinSetInterfaces) /* 26 */
-#define TclWinFlushDirtyChannels \
- (tclIntPlatStubsPtr->tclWinFlushDirtyChannels) /* 27 */
-#define TclWinResetInterfaces \
- (tclIntPlatStubsPtr->tclWinResetInterfaces) /* 28 */
+/* Slot 26 is reserved */
+/* Slot 27 is reserved */
+/* Slot 28 is reserved */
#define TclWinCPUID \
(tclIntPlatStubsPtr->tclWinCPUID) /* 29 */
-#define TclGetAndDetachPids \
- (tclIntPlatStubsPtr->tclGetAndDetachPids) /* 30 */
-#define TclpCloseFile \
- (tclIntPlatStubsPtr->tclpCloseFile) /* 31 */
#endif /* UNIX */
-#ifdef __WIN32__ /* WIN */
+#if defined(__WIN32__) || defined(__CYGWIN__) /* WIN */
#define TclWinConvertError \
(tclIntPlatStubsPtr->tclWinConvertError) /* 0 */
#define TclWinConvertWSAError \
@@ -452,7 +412,8 @@ extern const TclIntPlatStubs *tclIntPlatStubsPtr;
(tclIntPlatStubsPtr->tclWinGetSockOpt) /* 3 */
#define TclWinGetTclInstance \
(tclIntPlatStubsPtr->tclWinGetTclInstance) /* 4 */
-/* Slot 5 is reserved */
+#define TclUnixWaitForFile \
+ (tclIntPlatStubsPtr->tclUnixWaitForFile) /* 5 */
#define TclWinNToHS \
(tclIntPlatStubsPtr->tclWinNToHS) /* 6 */
#define TclWinSetSockOpt \
@@ -461,7 +422,8 @@ extern const TclIntPlatStubs *tclIntPlatStubsPtr;
(tclIntPlatStubsPtr->tclpGetPid) /* 8 */
#define TclWinGetPlatformId \
(tclIntPlatStubsPtr->tclWinGetPlatformId) /* 9 */
-/* Slot 10 is reserved */
+#define TclpReaddir \
+ (tclIntPlatStubsPtr->tclpReaddir) /* 10 */
#define TclGetAndDetachPids \
(tclIntPlatStubsPtr->tclGetAndDetachPids) /* 11 */
#define TclpCloseFile \
@@ -472,15 +434,18 @@ extern const TclIntPlatStubs *tclIntPlatStubsPtr;
(tclIntPlatStubsPtr->tclpCreatePipe) /* 14 */
#define TclpCreateProcess \
(tclIntPlatStubsPtr->tclpCreateProcess) /* 15 */
-/* Slot 16 is reserved */
-/* Slot 17 is reserved */
+#define TclpIsAtty \
+ (tclIntPlatStubsPtr->tclpIsAtty) /* 16 */
+#define TclUnixCopyFile \
+ (tclIntPlatStubsPtr->tclUnixCopyFile) /* 17 */
#define TclpMakeFile \
(tclIntPlatStubsPtr->tclpMakeFile) /* 18 */
#define TclpOpenFile \
(tclIntPlatStubsPtr->tclpOpenFile) /* 19 */
#define TclWinAddProcess \
(tclIntPlatStubsPtr->tclWinAddProcess) /* 20 */
-/* Slot 21 is reserved */
+#define TclpInetNtoa \
+ (tclIntPlatStubsPtr->tclpInetNtoa) /* 21 */
#define TclpCreateTempFile \
(tclIntPlatStubsPtr->tclpCreateTempFile) /* 22 */
/* Slot 23 is reserved */
@@ -497,25 +462,25 @@ extern const TclIntPlatStubs *tclIntPlatStubsPtr;
(tclIntPlatStubsPtr->tclWinCPUID) /* 29 */
#endif /* WIN */
#ifdef MAC_OSX_TCL /* MACOSX */
-#define TclWinConvertError \
- (tclIntPlatStubsPtr->tclWinConvertError) /* 0 */
-#define TclWinConvertWSAError \
- (tclIntPlatStubsPtr->tclWinConvertWSAError) /* 1 */
+#define TclGetAndDetachPids \
+ (tclIntPlatStubsPtr->tclGetAndDetachPids) /* 0 */
+#define TclpCloseFile \
+ (tclIntPlatStubsPtr->tclpCloseFile) /* 1 */
#define TclpCreateCommandChannel \
(tclIntPlatStubsPtr->tclpCreateCommandChannel) /* 2 */
#define TclpCreatePipe \
(tclIntPlatStubsPtr->tclpCreatePipe) /* 3 */
-#define TclWinGetTclInstance \
- (tclIntPlatStubsPtr->tclWinGetTclInstance) /* 4 */
+#define TclpCreateProcess \
+ (tclIntPlatStubsPtr->tclpCreateProcess) /* 4 */
/* Slot 5 is reserved */
-#define TclWinNToHS \
- (tclIntPlatStubsPtr->tclWinNToHS) /* 6 */
-#define TclWinSetSockOpt \
- (tclIntPlatStubsPtr->tclWinSetSockOpt) /* 7 */
+#define TclpMakeFile \
+ (tclIntPlatStubsPtr->tclpMakeFile) /* 6 */
+#define TclpOpenFile \
+ (tclIntPlatStubsPtr->tclpOpenFile) /* 7 */
#define TclUnixWaitForFile \
(tclIntPlatStubsPtr->tclUnixWaitForFile) /* 8 */
-#define TclWinGetPlatformId \
- (tclIntPlatStubsPtr->tclWinGetPlatformId) /* 9 */
+#define TclpCreateTempFile \
+ (tclIntPlatStubsPtr->tclpCreateTempFile) /* 9 */
#define TclpReaddir \
(tclIntPlatStubsPtr->tclpReaddir) /* 10 */
#define TclpLocaltime_unix \
@@ -536,27 +501,17 @@ extern const TclIntPlatStubs *tclIntPlatStubsPtr;
(tclIntPlatStubsPtr->tclMacOSXMatchType) /* 18 */
#define TclMacOSXNotifierAddRunLoopMode \
(tclIntPlatStubsPtr->tclMacOSXNotifierAddRunLoopMode) /* 19 */
-#define TclWinAddProcess \
- (tclIntPlatStubsPtr->tclWinAddProcess) /* 20 */
+/* Slot 20 is reserved */
/* Slot 21 is reserved */
-#define TclpCreateTempFile \
- (tclIntPlatStubsPtr->tclpCreateTempFile) /* 22 */
+/* Slot 22 is reserved */
/* Slot 23 is reserved */
-#define TclWinNoBackslash \
- (tclIntPlatStubsPtr->tclWinNoBackslash) /* 24 */
+/* Slot 24 is reserved */
/* Slot 25 is reserved */
-#define TclWinSetInterfaces \
- (tclIntPlatStubsPtr->tclWinSetInterfaces) /* 26 */
-#define TclWinFlushDirtyChannels \
- (tclIntPlatStubsPtr->tclWinFlushDirtyChannels) /* 27 */
-#define TclWinResetInterfaces \
- (tclIntPlatStubsPtr->tclWinResetInterfaces) /* 28 */
+/* Slot 26 is reserved */
+/* Slot 27 is reserved */
+/* Slot 28 is reserved */
#define TclWinCPUID \
(tclIntPlatStubsPtr->tclWinCPUID) /* 29 */
-#define TclGetAndDetachPids \
- (tclIntPlatStubsPtr->tclGetAndDetachPids) /* 30 */
-#define TclpCloseFile \
- (tclIntPlatStubsPtr->tclpCloseFile) /* 31 */
#endif /* MACOSX */
#endif /* defined(USE_TCL_STUBS) */
@@ -570,25 +525,9 @@ extern const TclIntPlatStubs *tclIntPlatStubsPtr;
#undef TclWinConvertWSAError
#define TclWinConvertWSAError TclWinConvertError
-
-#if !defined(__WIN32__) && defined(USE_TCL_STUBS)
-# ifdef __CYGWIN__
-# define TclpCreateProcess ((int (*) _ANSI_ARGS_((Tcl_Interp *, int, \
- CONST char **, TclFile, TclFile, TclFile, Tcl_Pid *))) \
- tclIntPlatStubsPtr->tclMacOSXGetFileAttribute)
-# define TclpMakeFile ((TclFile (*) _ANSI_ARGS_((Tcl_Channel channel, \
- int direction))) tclIntPlatStubsPtr->tclMacOSXMatchType)
-# define TclpOpenFile ((TclFile (*) _ANSI_ARGS_((CONST char *, int))) \
- tclIntPlatStubsPtr->tclMacOSXNotifierAddRunLoopMode)
-# else
-# define TclpCreateProcess ((int (*) _ANSI_ARGS_((Tcl_Interp *, int, \
- CONST char **, TclFile, TclFile, TclFile, Tcl_Pid *))) \
- tclIntPlatStubsPtr->tclWinGetTclInstance)
-# define TclpMakeFile ((TclFile (*) _ANSI_ARGS_((Tcl_Channel channel, \
- int direction))) tclIntPlatStubsPtr->tclWinNToHS)
-# define TclpOpenFile ((TclFile (*) _ANSI_ARGS_((CONST char *, int))) \
- tclIntPlatStubsPtr->tclWinNToHS)
-# endif
+#if !defined(__WIN32__) && !defined(__CYGWIN__)
+# undef TclpGetPid
+# define TclpGetPid(pid) ((unsigned long) (pid))
#endif
#endif /* _TCLINTPLATDECLS */
diff --git a/generic/tclInterp.c b/generic/tclInterp.c
index 5b6d14f..0b0f652 100644
--- a/generic/tclInterp.c
+++ b/generic/tclInterp.c
@@ -1043,18 +1043,18 @@ Tcl_InterpObjCmd(
iiPtr = (InterpInfo *) ((Interp *) slaveInterp)->interpInfo;
hPtr = Tcl_FindHashEntry(&iiPtr->slave.aliasTable, aliasName);
if (hPtr == NULL) {
- Tcl_AppendResult(interp, "alias \"", aliasName, "\" in path \"",
- Tcl_GetString(objv[2]), "\" not found", NULL);
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "alias \"%s\" in path \"%s\" not found",
+ aliasName, Tcl_GetString(objv[2])));
Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "ALIAS", aliasName,
NULL);
return TCL_ERROR;
}
aliasPtr = Tcl_GetHashValue(hPtr);
if (Tcl_GetInterpPath(interp, aliasPtr->targetInterp) != TCL_OK) {
- Tcl_ResetResult(interp);
- Tcl_AppendResult(interp, "target interpreter for alias \"",
- aliasName, "\" in path \"", Tcl_GetString(objv[2]),
- "\" is not my descendant", NULL);
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "target interpreter for alias \"%s\" in path \"%s\" is "
+ "not my descendant", aliasName, Tcl_GetString(objv[2])));
Tcl_SetErrorCode(interp, "TCL", "OPERATION", "INTERP",
"TARGETSHROUDED", NULL);
return TCL_ERROR;
@@ -1234,7 +1234,8 @@ Tcl_GetAlias(
hPtr = Tcl_FindHashEntry(&iiPtr->slave.aliasTable, aliasName);
if (hPtr == NULL) {
- Tcl_AppendResult(interp, "alias \"", aliasName, "\" not found", NULL);
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "alias \"%s\" not found", aliasName));
Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "ALIAS", aliasName, NULL);
return TCL_ERROR;
}
@@ -1295,7 +1296,8 @@ Tcl_GetAliasObj(
hPtr = Tcl_FindHashEntry(&iiPtr->slave.aliasTable, aliasName);
if (hPtr == NULL) {
- Tcl_AppendResult(interp, "alias \"", aliasName, "\" not found", NULL);
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "alias \"%s\" not found", aliasName));
Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "ALIAS", aliasName, NULL);
return TCL_ERROR;
}
@@ -1383,9 +1385,9 @@ TclPreventAliasLoop(
* [Bug #641195]
*/
- Tcl_AppendResult(interp, "cannot define or rename alias \"",
- Tcl_GetCommandName(cmdInterp, cmd),
- "\": interpreter deleted", NULL);
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "cannot define or rename alias \"%s\": interpreter deleted",
+ Tcl_GetCommandName(cmdInterp, cmd)));
return TCL_ERROR;
}
cmdNamePtr = nextAliasPtr->objPtr;
@@ -1398,9 +1400,9 @@ TclPreventAliasLoop(
}
aliasCmdPtr = (Command *) aliasCmd;
if (aliasCmdPtr == cmdPtr) {
- Tcl_AppendResult(interp, "cannot define or rename alias \"",
- Tcl_GetCommandName(cmdInterp, cmd),
- "\": would create a loop", NULL);
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "cannot define or rename alias \"%s\": would create a loop",
+ Tcl_GetCommandName(cmdInterp, cmd)));
Tcl_SetErrorCode(interp, "TCL", "OPERATION", "INTERP",
"ALIASLOOP", NULL);
return TCL_ERROR;
@@ -1621,8 +1623,8 @@ AliasDelete(
slavePtr = &((InterpInfo *) ((Interp *) slaveInterp)->interpInfo)->slave;
hPtr = Tcl_FindHashEntry(&slavePtr->aliasTable, TclGetString(namePtr));
if (hPtr == NULL) {
- Tcl_AppendResult(interp, "alias \"", TclGetString(namePtr),
- "\" not found", NULL);
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "alias \"%s\" not found", TclGetString(namePtr)));
Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "ALIAS",
TclGetString(namePtr), NULL);
return TCL_ERROR;
@@ -2154,17 +2156,19 @@ Tcl_GetInterpPath(
InterpInfo *iiPtr;
if (targetInterp == askingInterp) {
+ Tcl_SetObjResult(askingInterp, Tcl_NewObj());
return TCL_OK;
}
if (targetInterp == NULL) {
return TCL_ERROR;
}
iiPtr = (InterpInfo *) ((Interp *) targetInterp)->interpInfo;
- if (Tcl_GetInterpPath(askingInterp, iiPtr->slave.masterInterp) != TCL_OK) {
+ if (Tcl_GetInterpPath(askingInterp, iiPtr->slave.masterInterp) != TCL_OK){
return TCL_ERROR;
}
- Tcl_AppendElement(askingInterp, Tcl_GetHashKey(&iiPtr->master.slaveTable,
- iiPtr->slave.slaveEntryPtr));
+ Tcl_ListObjAppendElement(NULL, Tcl_GetObjResult(askingInterp),
+ Tcl_NewStringObj(Tcl_GetHashKey(&iiPtr->master.slaveTable,
+ iiPtr->slave.slaveEntryPtr), -1));
return TCL_OK;
}
@@ -2218,8 +2222,8 @@ GetInterp(
}
}
if (searchInterp == NULL) {
- Tcl_AppendResult(interp, "could not find interpreter \"",
- TclGetString(pathPtr), "\"", NULL);
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "could not find interpreter \"%s\"", TclGetString(pathPtr)));
Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "INTERP",
TclGetString(pathPtr), NULL);
}
@@ -2256,8 +2260,8 @@ SlaveBgerror(
if (TCL_ERROR == TclListObjLength(NULL, objv[0], &length)
|| (length < 1)) {
- Tcl_AppendResult(interp, "cmdPrefix must be list of length >= 1",
- NULL);
+ Tcl_SetObjResult(interp, Tcl_NewStringObj(
+ "cmdPrefix must be list of length >= 1", -1));
Tcl_SetErrorCode(interp, "TCL", "OPERATION", "INTERP",
"BGERRORFORMAT", NULL);
return TCL_ERROR;
@@ -2326,8 +2330,9 @@ SlaveCreate(
hPtr = Tcl_CreateHashEntry(&masterInfoPtr->master.slaveTable, path,
&isNew);
if (isNew == 0) {
- Tcl_AppendResult(interp, "interpreter named \"", path,
- "\" already exists, cannot create", NULL);
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "interpreter named \"%s\" already exists, cannot create",
+ path));
return NULL;
}
@@ -2860,8 +2865,8 @@ SlaveRecursionLimit(
if (objc) {
if (Tcl_IsSafe(interp)) {
- Tcl_AppendResult(interp, "permission denied: "
- "safe interpreters cannot change recursion limit", NULL);
+ Tcl_SetObjResult(interp, Tcl_NewStringObj("permission denied: "
+ "safe interpreters cannot change recursion limit", -1));
Tcl_SetErrorCode(interp, "TCL", "OPERATION", "INTERP", "UNSAFE",
NULL);
return TCL_ERROR;
@@ -3320,8 +3325,8 @@ Tcl_LimitCheck(
if (iPtr->limit.cmdCount >= iPtr->cmdCount) {
iPtr->limit.exceeded &= ~TCL_LIMIT_COMMANDS;
} else if (iPtr->limit.exceeded & TCL_LIMIT_COMMANDS) {
- Tcl_ResetResult(interp);
- Tcl_AppendResult(interp, "command count limit exceeded", NULL);
+ Tcl_SetObjResult(interp, Tcl_NewStringObj(
+ "command count limit exceeded", -1));
Tcl_SetErrorCode(interp, "TCL", "LIMIT", "COMMANDS", NULL);
Tcl_Release(interp);
return TCL_ERROR;
@@ -3346,8 +3351,8 @@ Tcl_LimitCheck(
iPtr->limit.time.usec >= now.usec)) {
iPtr->limit.exceeded &= ~TCL_LIMIT_TIME;
} else if (iPtr->limit.exceeded & TCL_LIMIT_TIME) {
- Tcl_ResetResult(interp);
- Tcl_AppendResult(interp, "time limit exceeded", NULL);
+ Tcl_SetObjResult(interp, Tcl_NewStringObj(
+ "time limit exceeded", -1));
Tcl_SetErrorCode(interp, "TCL", "LIMIT", "TIME", NULL);
Tcl_Release(interp);
return TCL_ERROR;
@@ -4353,8 +4358,9 @@ SlaveCommandLimitCmd(
*/
if (interp == slaveInterp) {
- Tcl_AppendResult(interp,
- "limits on current interpreter inaccessible", NULL);
+ Tcl_SetObjResult(interp, Tcl_NewStringObj(
+ "limits on current interpreter inaccessible", -1));
+ Tcl_SetErrorCode(interp, "TCL", "OPERATION", "INTERP", "SELF", NULL);
return TCL_ERROR;
}
@@ -4450,8 +4456,8 @@ SlaveCommandLimitCmd(
return TCL_ERROR;
}
if (gran < 1) {
- Tcl_AppendResult(interp, "granularity must be at "
- "least 1", NULL);
+ Tcl_SetObjResult(interp, Tcl_NewStringObj(
+ "granularity must be at least 1", -1));
Tcl_SetErrorCode(interp, "TCL", "OPERATION", "INTERP",
"BADVALUE", NULL);
return TCL_ERROR;
@@ -4467,8 +4473,8 @@ SlaveCommandLimitCmd(
return TCL_ERROR;
}
if (limit < 0) {
- Tcl_AppendResult(interp, "command limit value must be at "
- "least 0", NULL);
+ Tcl_SetObjResult(interp, Tcl_NewStringObj(
+ "command limit value must be at least 0", -1));
Tcl_SetErrorCode(interp, "TCL", "OPERATION", "INTERP",
"BADVALUE", NULL);
return TCL_ERROR;
@@ -4540,8 +4546,9 @@ SlaveTimeLimitCmd(
*/
if (interp == slaveInterp) {
- Tcl_AppendResult(interp,
- "limits on current interpreter inaccessible", NULL);
+ Tcl_SetObjResult(interp, Tcl_NewStringObj(
+ "limits on current interpreter inaccessible", -1));
+ Tcl_SetErrorCode(interp, "TCL", "OPERATION", "INTERP", "SELF", NULL);
return TCL_ERROR;
}
@@ -4658,8 +4665,8 @@ SlaveTimeLimitCmd(
return TCL_ERROR;
}
if (gran < 1) {
- Tcl_AppendResult(interp, "granularity must be at "
- "least 1", NULL);
+ Tcl_SetObjResult(interp, Tcl_NewStringObj(
+ "granularity must be at least 1", -1));
Tcl_SetErrorCode(interp, "TCL", "OPERATION", "INTERP",
"BADVALUE", NULL);
return TCL_ERROR;
@@ -4675,13 +4682,13 @@ SlaveTimeLimitCmd(
return TCL_ERROR;
}
if (tmp < 0) {
- Tcl_AppendResult(interp, "milliseconds must be at least 0",
- NULL);
+ Tcl_SetObjResult(interp, Tcl_NewStringObj(
+ "milliseconds must be at least 0", -1));
Tcl_SetErrorCode(interp, "TCL", "OPERATION", "INTERP",
"BADVALUE", NULL);
return TCL_ERROR;
}
- limitMoment.usec = ((long)tmp)*1000;
+ limitMoment.usec = ((long) tmp)*1000;
break;
case OPT_SEC:
secObj = objv[i+1];
@@ -4693,8 +4700,8 @@ SlaveTimeLimitCmd(
return TCL_ERROR;
}
if (tmp < 0) {
- Tcl_AppendResult(interp, "seconds must be at least 0",
- NULL);
+ Tcl_SetObjResult(interp, Tcl_NewStringObj(
+ "seconds must be at least 0", -1));
Tcl_SetErrorCode(interp, "TCL", "OPERATION", "INTERP",
"BADVALUE", NULL);
return TCL_ERROR;
@@ -4711,15 +4718,17 @@ SlaveTimeLimitCmd(
*/
if (secObj != NULL && secLen == 0 && milliLen > 0) {
- Tcl_AppendResult(interp, "may only set -milliseconds "
- "if -seconds is not also being reset", NULL);
+ Tcl_SetObjResult(interp, Tcl_NewStringObj(
+ "may only set -milliseconds if -seconds is not "
+ "also being reset", -1));
Tcl_SetErrorCode(interp, "TCL", "OPERATION", "INTERP",
"BADUSAGE", NULL);
return TCL_ERROR;
}
if (milliLen == 0 && (secObj == NULL || secLen > 0)) {
- Tcl_AppendResult(interp, "may only reset -milliseconds "
- "if -seconds is also being reset", NULL);
+ Tcl_SetObjResult(interp, Tcl_NewStringObj(
+ "may only reset -milliseconds if -seconds is "
+ "also being reset", -1));
Tcl_SetErrorCode(interp, "TCL", "OPERATION", "INTERP",
"BADUSAGE", NULL);
return TCL_ERROR;
diff --git a/generic/tclLoad.c b/generic/tclLoad.c
index 008a99d..3fead6f 100644
--- a/generic/tclLoad.c
+++ b/generic/tclLoad.c
@@ -157,9 +157,8 @@ Tcl_LoadObjCmd(
}
}
if ((fullFileName[0] == 0) && (packageName == NULL)) {
- Tcl_SetResult(interp,
- "must specify either file name or package name",
- TCL_STATIC);
+ Tcl_SetObjResult(interp, Tcl_NewStringObj(
+ "must specify either file name or package name", -1));
Tcl_SetErrorCode(interp, "TCL", "OPERATION", "LOAD", "NOLIBRARY",
NULL);
code = TCL_ERROR;
@@ -198,9 +197,9 @@ Tcl_LoadObjCmd(
if (packageName == NULL) {
namesMatch = 0;
} else {
- Tcl_DStringSetLength(&pkgName, 0);
+ TclDStringClear(&pkgName);
Tcl_DStringAppend(&pkgName, packageName, -1);
- Tcl_DStringSetLength(&tmp, 0);
+ TclDStringClear(&tmp);
Tcl_DStringAppend(&tmp, pkgPtr->packageName, -1);
Tcl_UtfToLower(Tcl_DStringValue(&pkgName));
Tcl_UtfToLower(Tcl_DStringValue(&tmp));
@@ -211,7 +210,7 @@ Tcl_LoadObjCmd(
namesMatch = 0;
}
}
- Tcl_DStringSetLength(&pkgName, 0);
+ TclDStringClear(&pkgName);
filesMatch = (strcmp(pkgPtr->fileName, fullFileName) == 0);
if (filesMatch && (namesMatch || (packageName == NULL))) {
@@ -225,9 +224,9 @@ Tcl_LoadObjCmd(
* Can't have two different packages loaded from the same file.
*/
- Tcl_AppendResult(interp, "file \"", fullFileName,
- "\" is already loaded for package \"",
- pkgPtr->packageName, "\"", NULL);
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "file \"%s\" is already loaded for package \"%s\"",
+ fullFileName, pkgPtr->packageName));
Tcl_SetErrorCode(interp, "TCL", "OPERATION", "LOAD",
"SPLITPERSONALITY", NULL);
code = TCL_ERROR;
@@ -263,8 +262,8 @@ Tcl_LoadObjCmd(
*/
if (fullFileName[0] == 0) {
- Tcl_AppendResult(interp, "package \"", packageName,
- "\" isn't loaded statically", NULL);
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "package \"%s\" isn't loaded statically", packageName));
Tcl_SetErrorCode(interp, "TCL", "OPERATION", "LOAD", "NOTSTATIC",
NULL);
code = TCL_ERROR;
@@ -321,15 +320,15 @@ Tcl_LoadObjCmd(
}
if (p == pkgGuess) {
Tcl_DecrRefCount(splitPtr);
- Tcl_AppendResult(interp,
- "couldn't figure out package name for ",
- fullFileName, NULL);
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "couldn't figure out package name for %s",
+ fullFileName));
Tcl_SetErrorCode(interp, "TCL", "OPERATION", "LOAD",
"WHATPACKAGE", NULL);
code = TCL_ERROR;
goto done;
}
- Tcl_DStringAppend(&pkgName, pkgGuess, (p - pkgGuess));
+ Tcl_DStringAppend(&pkgName, pkgGuess, p - pkgGuess);
Tcl_DecrRefCount(splitPtr);
}
}
@@ -348,14 +347,14 @@ Tcl_LoadObjCmd(
* package name.
*/
- Tcl_DStringAppend(&initName, Tcl_DStringValue(&pkgName), -1);
- Tcl_DStringAppend(&initName, "_Init", 5);
- Tcl_DStringAppend(&safeInitName, Tcl_DStringValue(&pkgName), -1);
- Tcl_DStringAppend(&safeInitName, "_SafeInit", 9);
- Tcl_DStringAppend(&unloadName, Tcl_DStringValue(&pkgName), -1);
- Tcl_DStringAppend(&unloadName, "_Unload", 7);
- Tcl_DStringAppend(&safeUnloadName, Tcl_DStringValue(&pkgName), -1);
- Tcl_DStringAppend(&safeUnloadName, "_SafeUnload", 11);
+ TclDStringAppendDString(&initName, &pkgName);
+ TclDStringAppendLiteral(&initName, "_Init");
+ TclDStringAppendDString(&safeInitName, &pkgName);
+ TclDStringAppendLiteral(&safeInitName, "_SafeInit");
+ TclDStringAppendDString(&unloadName, &pkgName);
+ TclDStringAppendLiteral(&unloadName, "_Unload");
+ TclDStringAppendDString(&safeUnloadName, &pkgName);
+ TclDStringAppendLiteral(&safeUnloadName, "_SafeUnload");
/*
* Call platform-specific code to load the package and find the two
@@ -418,9 +417,9 @@ Tcl_LoadObjCmd(
if (Tcl_IsSafe(target)) {
if (pkgPtr->safeInitProc == NULL) {
- Tcl_AppendResult(interp,
- "can't use package in a safe interpreter: no ",
- pkgPtr->packageName, "_SafeInit procedure", NULL);
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "can't use package in a safe interpreter: no"
+ " %s_SafeInit procedure", pkgPtr->packageName));
Tcl_SetErrorCode(interp, "TCL", "OPERATION", "LOAD", "UNSAFE",
NULL);
code = TCL_ERROR;
@@ -429,9 +428,9 @@ Tcl_LoadObjCmd(
code = pkgPtr->safeInitProc(target);
} else {
if (pkgPtr->initProc == NULL) {
- Tcl_AppendResult(interp,
- "can't attach package to interpreter: no ",
- pkgPtr->packageName, "_Init procedure", NULL);
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "can't attach package to interpreter: no %s_Init procedure",
+ pkgPtr->packageName));
Tcl_SetErrorCode(interp, "TCL", "OPERATION", "LOAD", "ENTRYPOINT",
NULL);
code = TCL_ERROR;
@@ -581,9 +580,8 @@ Tcl_UnloadObjCmd(
}
}
if ((fullFileName[0] == 0) && (packageName == NULL)) {
- Tcl_SetResult(interp,
- "must specify either file name or package name",
- TCL_STATIC);
+ Tcl_SetObjResult(interp, Tcl_NewStringObj(
+ "must specify either file name or package name", -1));
Tcl_SetErrorCode(interp, "TCL", "OPERATION", "UNLOAD", "NOLIBRARY",
NULL);
code = TCL_ERROR;
@@ -623,9 +621,9 @@ Tcl_UnloadObjCmd(
if (packageName == NULL) {
namesMatch = 0;
} else {
- Tcl_DStringSetLength(&pkgName, 0);
+ TclDStringClear(&pkgName);
Tcl_DStringAppend(&pkgName, packageName, -1);
- Tcl_DStringSetLength(&tmp, 0);
+ TclDStringClear(&tmp);
Tcl_DStringAppend(&tmp, pkgPtr->packageName, -1);
Tcl_UtfToLower(Tcl_DStringValue(&pkgName));
Tcl_UtfToLower(Tcl_DStringValue(&tmp));
@@ -636,7 +634,7 @@ Tcl_UnloadObjCmd(
namesMatch = 0;
}
}
- Tcl_DStringSetLength(&pkgName, 0);
+ TclDStringClear(&pkgName);
filesMatch = (strcmp(pkgPtr->fileName, fullFileName) == 0);
if (filesMatch && (namesMatch || (packageName == NULL))) {
@@ -655,8 +653,9 @@ Tcl_UnloadObjCmd(
* It's an error to try unload a static package.
*/
- Tcl_AppendResult(interp, "package \"", packageName,
- "\" is loaded statically and cannot be unloaded", NULL);
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "package \"%s\" is loaded statically and cannot be unloaded",
+ packageName));
Tcl_SetErrorCode(interp, "TCL", "OPERATION", "UNLOAD", "STATIC",
NULL);
code = TCL_ERROR;
@@ -667,8 +666,8 @@ Tcl_UnloadObjCmd(
* The DLL pointed by the provided filename has never been loaded.
*/
- Tcl_AppendResult(interp, "file \"", fullFileName,
- "\" has never been loaded", NULL);
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "file \"%s\" has never been loaded", fullFileName));
Tcl_SetErrorCode(interp, "TCL", "OPERATION", "UNLOAD", "NEVERLOADED",
NULL);
code = TCL_ERROR;
@@ -696,8 +695,9 @@ Tcl_UnloadObjCmd(
* The package has not been loaded in this interpreter.
*/
- Tcl_AppendResult(interp, "file \"", fullFileName,
- "\" has never been loaded in this interpreter", NULL);
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "file \"%s\" has never been loaded in this interpreter",
+ fullFileName));
Tcl_SetErrorCode(interp, "TCL", "OPERATION", "UNLOAD", "NEVERLOADED",
NULL);
code = TCL_ERROR;
@@ -712,8 +712,9 @@ Tcl_UnloadObjCmd(
if (Tcl_IsSafe(target)) {
if (pkgPtr->safeUnloadProc == NULL) {
- Tcl_AppendResult(interp, "file \"", fullFileName,
- "\" cannot be unloaded under a safe interpreter", NULL);
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "file \"%s\" cannot be unloaded under a safe interpreter",
+ fullFileName));
Tcl_SetErrorCode(interp, "TCL", "OPERATION", "UNLOAD", "CANNOT",
NULL);
code = TCL_ERROR;
@@ -722,8 +723,9 @@ Tcl_UnloadObjCmd(
unloadProc = pkgPtr->safeUnloadProc;
} else {
if (pkgPtr->unloadProc == NULL) {
- Tcl_AppendResult(interp, "file \"", fullFileName,
- "\" cannot be unloaded under a trusted interpreter", NULL);
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "file \"%s\" cannot be unloaded under a trusted interpreter",
+ fullFileName));
Tcl_SetErrorCode(interp, "TCL", "OPERATION", "UNLOAD", "CANNOT",
NULL);
code = TCL_ERROR;
@@ -862,8 +864,9 @@ Tcl_UnloadObjCmd(
}
}
#else
- Tcl_AppendResult(interp, "file \"", fullFileName,
- "\" cannot be unloaded: unloading disabled", NULL);
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "file \"%s\" cannot be unloaded: unloading disabled",
+ fullFileName));
Tcl_SetErrorCode(interp, "TCL", "OPERATION", "UNLOAD", "DISABLED",
NULL);
code = TCL_ERROR;
diff --git a/generic/tclLoadNone.c b/generic/tclLoadNone.c
index ac094e6..6b48aee 100644
--- a/generic/tclLoadNone.c
+++ b/generic/tclLoadNone.c
@@ -44,9 +44,9 @@ TclpDlopen(
* function which should be used for this
* file. */
{
- Tcl_SetResult(interp,
+ Tcl_SetObjResult(interp, Tcl_NewStringObj(
"dynamic loading is not currently available on this system",
- TCL_STATIC);
+ -1));
return TCL_ERROR;
}
diff --git a/generic/tclMain.c b/generic/tclMain.c
index 373e3f6..88b4e51 100644
--- a/generic/tclMain.c
+++ b/generic/tclMain.c
@@ -53,20 +53,23 @@
#endif
/*
- * Further on, in UNICODE mode, we need to use Tcl_NewUnicodeObj,
- * while otherwise NewNativeObj is needed (which provides proper
- * conversion from native encoding to UTF-8).
+ * Further on, in UNICODE mode we just use Tcl_NewUnicodeObj, otherwise
+ * NewNativeObj is needed (which provides proper conversion from native
+ * encoding to UTF-8).
*/
+
#ifdef UNICODE
# define NewNativeObj Tcl_NewUnicodeObj
#else /* !UNICODE */
- static Tcl_Obj *NewNativeObj(char *string, int length) {
- Tcl_Obj *obj;
- Tcl_DString ds;
- Tcl_ExternalToUtfDString(NULL, string, length, &ds);
- obj = Tcl_NewStringObj(Tcl_DStringValue(&ds), Tcl_DStringLength(&ds));
- Tcl_DStringFree(&ds);
- return obj;
+static inline Tcl_Obj *
+NewNativeObj(
+ char *string,
+ int length)
+{
+ Tcl_DString ds;
+
+ Tcl_ExternalToUtfDString(NULL, string, length, &ds);
+ return TclDStringToObj(&ds);
}
#endif /* !UNICODE */
diff --git a/generic/tclNamesp.c b/generic/tclNamesp.c
index cdaba3d..d98de97 100644
--- a/generic/tclNamesp.c
+++ b/generic/tclNamesp.c
@@ -24,7 +24,7 @@
*/
#include "tclInt.h"
-#include "tclCompile.h" /* for NRCommand; and TclLogCommandInfo visibility */
+#include "tclCompile.h" /* for TclLogCommandInfo visibility */
/*
* Thread-local storage used to avoid having a global lock on data that is not
@@ -687,9 +687,8 @@ Tcl_CreateNamespace(
parentPtr = NULL;
simpleName = "";
} else if (*name == '\0') {
- Tcl_ResetResult(interp);
- Tcl_AppendResult(interp, "can't create namespace \"\": "
- "only global namespace can have empty name", NULL);
+ Tcl_SetObjResult(interp, Tcl_NewStringObj("can't create namespace"
+ " \"\": only global namespace can have empty name", -1));
Tcl_SetErrorCode(interp, "TCL", "OPERATION", "NAMESPACE",
"CREATEGLOBAL", NULL);
return NULL;
@@ -725,8 +724,8 @@ Tcl_CreateNamespace(
Tcl_FindHashEntry(parentPtr->childTablePtr, simpleName) != NULL
#endif
) {
- Tcl_AppendResult(interp, "can't create namespace \"", name,
- "\": already exists", NULL);
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "can't create namespace \"%s\": already exists", name));
Tcl_SetErrorCode(interp, "TCL", "OPERATION", "NAMESPACE",
"CREATEEXISTING", NULL);
return NULL;
@@ -803,10 +802,9 @@ Tcl_CreateNamespace(
if (ancestorPtr != globalNsPtr) {
register Tcl_DString *tempPtr = namePtr;
- Tcl_DStringAppend(buffPtr, "::", 2);
+ TclDStringAppendLiteral(buffPtr, "::");
Tcl_DStringAppend(buffPtr, ancestorPtr->name, -1);
- Tcl_DStringAppend(buffPtr, Tcl_DStringValue(namePtr),
- Tcl_DStringLength(namePtr));
+ TclDStringAppendDString(buffPtr, namePtr);
/*
* Clear the unwanted buffer or we end up appending to previous
@@ -814,7 +812,7 @@ Tcl_CreateNamespace(
* very wrong (and strange).
*/
- Tcl_DStringSetLength(namePtr, 0);
+ TclDStringClear(namePtr);
/*
* Now swap the buffer pointers so that we build in the other
@@ -916,7 +914,7 @@ Tcl_DeleteNamespace(
for (entryPtr = Tcl_FirstHashEntry(&nsPtr->cmdTable, &search);
entryPtr != NULL;) {
cmdPtr = Tcl_GetHashValue(entryPtr);
- if (cmdPtr->nreProc == NRInterpCoroutine) {
+ if (cmdPtr->nreProc == TclNRInterpCoroutine) {
Tcl_DeleteCommandFromToken((Tcl_Interp *) iPtr,
(Tcl_Command) cmdPtr);
entryPtr = Tcl_FirstHashEntry(&nsPtr->cmdTable, &search);
@@ -1337,8 +1335,8 @@ Tcl_Export(
&exportNsPtr, &dummyPtr, &dummyPtr, &simplePattern);
if ((exportNsPtr != nsPtr) || (strcmp(pattern, simplePattern) != 0)) {
- Tcl_AppendResult(interp, "invalid export pattern \"", pattern,
- "\": pattern can't specify a namespace", NULL);
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf("invalid export pattern"
+ " \"%s\": pattern can't specify a namespace", pattern));
Tcl_SetErrorCode(interp, "TCL", "EXPORT", "INVALID", NULL);
return TCL_ERROR;
}
@@ -1552,21 +1550,21 @@ Tcl_Import(
&importNsPtr, &dummyPtr, &dummyPtr, &simplePattern);
if (importNsPtr == NULL) {
- Tcl_AppendResult(interp, "unknown namespace in import pattern \"",
- pattern, "\"", NULL);
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "unknown namespace in import pattern \"%s\"", pattern));
Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "NAMESPACE", pattern, NULL);
return TCL_ERROR;
}
if (importNsPtr == nsPtr) {
if (pattern == simplePattern) {
- Tcl_AppendResult(interp,
- "no namespace specified in import pattern \"", pattern,
- "\"", NULL);
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "no namespace specified in import pattern \"%s\"",
+ pattern));
Tcl_SetErrorCode(interp, "TCL", "IMPORT", "ORIGIN", NULL);
} else {
- Tcl_AppendResult(interp, "import pattern \"", pattern,
- "\" tries to import from namespace \"",
- importNsPtr->name, "\" into itself", NULL);
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "import pattern \"%s\" tries to import from namespace"
+ " \"%s\" into itself", pattern, importNsPtr->name));
Tcl_SetErrorCode(interp, "TCL", "IMPORT", "SELF", NULL);
}
return TCL_ERROR;
@@ -1667,7 +1665,7 @@ DoImport(
Tcl_DStringInit(&ds);
Tcl_DStringAppend(&ds, nsPtr->fullName, -1);
if (nsPtr != ((Interp *) interp)->globalNsPtr) {
- Tcl_DStringAppend(&ds, "::", 2);
+ TclDStringAppendLiteral(&ds, "::");
}
Tcl_DStringAppend(&ds, cmdName, -1);
@@ -1685,9 +1683,10 @@ DoImport(
dataPtr = linkCmd->objClientData;
linkCmd = dataPtr->realCmdPtr;
if (overwrite == linkCmd) {
- Tcl_AppendResult(interp, "import pattern \"", pattern,
- "\" would create a loop containing command \"",
- Tcl_DStringValue(&ds), "\"", NULL);
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "import pattern \"%s\" would create a loop"
+ " containing command \"%s\"",
+ pattern, Tcl_DStringValue(&ds)));
Tcl_DStringFree(&ds);
Tcl_SetErrorCode(interp, "TCL", "IMPORT", "LOOP", NULL);
return TCL_ERROR;
@@ -1727,8 +1726,8 @@ DoImport(
return TCL_OK;
}
}
- Tcl_AppendResult(interp, "can't import command \"", cmdName,
- "\": already exists", NULL);
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "can't import command \"%s\": already exists", cmdName));
Tcl_SetErrorCode(interp, "TCL", "IMPORT", "OVERWRITE", NULL);
return TCL_ERROR;
}
@@ -1797,9 +1796,9 @@ Tcl_ForgetImport(
&sourceNsPtr, &dummyPtr, &dummyPtr, &simplePattern);
if (sourceNsPtr == NULL) {
- Tcl_AppendResult(interp,
- "unknown namespace in namespace forget pattern \"",
- pattern, "\"", NULL);
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "unknown namespace in namespace forget pattern \"%s\"",
+ pattern));
Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "NAMESPACE", pattern, NULL);
return TCL_ERROR;
}
@@ -2241,7 +2240,7 @@ TclGetNamespaceForQualName(
* qualName since it may be a string constant.
*/
- Tcl_DStringSetLength(&buffer, 0);
+ TclDStringClear(&buffer);
Tcl_DStringAppend(&buffer, start, len);
nsName = Tcl_DStringValue(&buffer);
}
@@ -2403,8 +2402,8 @@ Tcl_FindNamespace(
}
if (flags & TCL_LEAVE_ERR_MSG) {
- Tcl_ResetResult(interp);
- Tcl_AppendResult(interp, "unknown namespace \"", name, "\"", NULL);
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "unknown namespace \"%s\"", name));
Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "NAMESPACE", name, NULL);
}
return NULL;
@@ -2590,8 +2589,8 @@ Tcl_FindCommand(
}
if (flags & TCL_LEAVE_ERR_MSG) {
- Tcl_ResetResult(interp);
- Tcl_AppendResult(interp, "unknown command \"", name, "\"", NULL);
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "unknown command \"%s\"", name));
Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "COMMAND", name, NULL);
}
return NULL;
@@ -2916,7 +2915,7 @@ NamespaceChildrenCmd(
} else {
Tcl_DStringAppend(&buffer, nsPtr->fullName, -1);
if (nsPtr != globalNsPtr) {
- Tcl_DStringAppend(&buffer, "::", 2);
+ TclDStringAppendLiteral(&buffer, "::");
}
Tcl_DStringAppend(&buffer, name, -1);
pattern = Tcl_DStringValue(&buffer);
@@ -3171,9 +3170,9 @@ NamespaceDeleteCmd(
namespacePtr = Tcl_FindNamespace(interp, name, NULL, /*flags*/ 0);
if ((namespacePtr == NULL)
|| (((Namespace *) namespacePtr)->flags & NS_KILLED)) {
- Tcl_AppendResult(interp, "unknown namespace \"",
- TclGetString(objv[i]),
- "\" in namespace delete command", NULL);
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "unknown namespace \"%s\" in namespace delete command",
+ TclGetString(objv[i])));
Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "NAMESPACE",
TclGetString(objv[i]), NULL);
return TCL_ERROR;
@@ -3835,8 +3834,8 @@ NamespaceOriginCmd(
command = Tcl_GetCommandFromObj(interp, objv[1]);
if (command == NULL) {
- Tcl_AppendResult(interp, "invalid command name \"",
- TclGetString(objv[1]), "\"", NULL);
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "invalid command name \"%s\"", TclGetString(objv[1])));
Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "COMMAND",
TclGetString(objv[1]), NULL);
return TCL_ERROR;
diff --git a/generic/tclOO.c b/generic/tclOO.c
index d5cc6e1..d9f5d60 100644
--- a/generic/tclOO.c
+++ b/generic/tclOO.c
@@ -81,6 +81,7 @@ 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,
@@ -123,6 +124,16 @@ static const DeclaredClassMethod objMethods[] = {
};
/*
+ * And for the oo::class constructor...
+ */
+
+static const Tcl_MethodType classConstructor = {
+ TCL_OO_METHOD_VERSION_CURRENT,
+ "oo::class constructor",
+ TclOO_Class_Constructor, NULL, NULL
+};
+
+/*
* Scripted parts of TclOO. First, the master script (cannot be outside this
* file).
*/
@@ -135,18 +146,6 @@ static const char *initScript =
/* " tcloo.tcl OO_LIBRARY oo::library;"; */
/*
- * The body of the constructor for oo::class.
- */
-
-static const char *classConstructorBody =
-"set script [list ::oo::define [self] $definitionScript];"
-"lassign [::oo::UpCatch $script] msg opts;"
-"if {[dict get $opts -code] == 1} {"
-" dict set opts -errorline 0xDeadBeef"
-"};"
-"return -options $opts $msg;";
-
-/*
* The scripted part of the definitions of slots.
*/
@@ -340,12 +339,12 @@ InitFoundation(
TclNewLiteralStringObj(fPtr->constructorName, "<constructor>");
TclNewLiteralStringObj(fPtr->destructorName, "<destructor>");
TclNewLiteralStringObj(fPtr->clonedName, "<cloned>");
+ TclNewLiteralStringObj(fPtr->defineName, "::oo::define");
Tcl_IncrRefCount(fPtr->unknownMethodNameObj);
Tcl_IncrRefCount(fPtr->constructorName);
Tcl_IncrRefCount(fPtr->destructorName);
Tcl_IncrRefCount(fPtr->clonedName);
- Tcl_NRCreateCommand(interp, "::oo::UpCatch", TclOOUpcatchCmd,
- TclOONRUpcatch, NULL, NULL);
+ Tcl_IncrRefCount(fPtr->defineName);
Tcl_CreateObjCommand(interp, "::oo::UnknownDefinition",
TclOOUnknownDefinition, NULL, NULL);
TclNewLiteralStringObj(namePtr, "::oo::UnknownDefinition");
@@ -358,14 +357,14 @@ InitFoundation(
Tcl_DStringInit(&buffer);
for (i=0 ; defineCmds[i].name ; i++) {
- Tcl_DStringAppend(&buffer, "::oo::define::", 14);
+ TclDStringAppendLiteral(&buffer, "::oo::define::");
Tcl_DStringAppend(&buffer, defineCmds[i].name, -1);
Tcl_CreateObjCommand(interp, Tcl_DStringValue(&buffer),
defineCmds[i].objProc, INT2PTR(defineCmds[i].flag), NULL);
Tcl_DStringFree(&buffer);
}
for (i=0 ; objdefCmds[i].name ; i++) {
- Tcl_DStringAppend(&buffer, "::oo::objdefine::", 17);
+ TclDStringAppendLiteral(&buffer, "::oo::objdefine::");
Tcl_DStringAppend(&buffer, objdefCmds[i].name, -1);
Tcl_CreateObjCommand(interp, Tcl_DStringValue(&buffer),
objdefCmds[i].objProc, INT2PTR(objdefCmds[i].flag), NULL);
@@ -418,28 +417,19 @@ InitFoundation(
bodyPtr = Tcl_NewStringObj(clonedBody, -1);
TclOONewProcMethod(interp, fPtr->objectCls, 0, fPtr->clonedName, argsPtr,
bodyPtr, NULL);
- Tcl_DecrRefCount(argsPtr);
+ TclDecrRefCount(argsPtr);
/*
* Finish setting up the class of classes by marking the 'new' method as
* private; classes, unlike general objects, must have explicit names. We
* also need to create the constructor for classes.
- *
- * The 0xDeadBeef is a special signal to the errorInfo logger that is used
- * by constructors that stops it from generating extra error information
- * that is confusing.
*/
TclNewLiteralStringObj(namePtr, "new");
Tcl_NewInstanceMethod(interp, (Tcl_Object) fPtr->classCls->thisPtr,
namePtr /* keeps ref */, 0 /* ==private */, NULL, NULL);
-
- TclNewLiteralStringObj(argsPtr, "{definitionScript {}}");
- Tcl_IncrRefCount(argsPtr);
- bodyPtr = Tcl_NewStringObj(classConstructorBody, -1);
- fPtr->classCls->constructorPtr = TclOONewProcMethod(interp,
- fPtr->classCls, 0, NULL, argsPtr, bodyPtr, NULL);
- Tcl_DecrRefCount(argsPtr);
+ fPtr->classCls->constructorPtr = (Method *) Tcl_NewMethod(interp,
+ (Tcl_Class) fPtr->classCls, NULL, 0, &classConstructor, NULL);
/*
* Create non-object commands and plug ourselves into the Tcl [info]
@@ -529,10 +519,11 @@ KillFoundation(
DelRef(fPtr->objectCls->thisPtr);
DelRef(fPtr->objectCls);
- Tcl_DecrRefCount(fPtr->unknownMethodNameObj);
- Tcl_DecrRefCount(fPtr->constructorName);
- Tcl_DecrRefCount(fPtr->destructorName);
- Tcl_DecrRefCount(fPtr->clonedName);
+ TclDecrRefCount(fPtr->unknownMethodNameObj);
+ TclDecrRefCount(fPtr->constructorName);
+ TclDecrRefCount(fPtr->destructorName);
+ TclDecrRefCount(fPtr->clonedName);
+ TclDecrRefCount(fPtr->defineName);
ckfree(fPtr);
}
@@ -667,7 +658,7 @@ AllocObject(
Tcl_DStringInit(&buffer);
Tcl_DStringAppend(&buffer,
Tcl_GetCurrentNamespace(interp)->fullName, -1);
- Tcl_DStringAppend(&buffer, "::", 2);
+ TclDStringAppendLiteral(&buffer, "::");
Tcl_DStringAppend(&buffer, nameStr, -1);
oPtr->command = Tcl_CreateObjCommand(interp,
Tcl_DStringValue(&buffer), PublicObjectCmd, oPtr, NULL);
@@ -714,6 +705,27 @@ AllocObject(
/*
* ----------------------------------------------------------------------
*
+ * SquelchCachedName --
+ *
+ * Encapsulates how to throw away a cached object name. Called from
+ * object rename traces and at object destruction.
+ *
+ * ----------------------------------------------------------------------
+ */
+
+static inline void
+SquelchCachedName(
+ Object *oPtr)
+{
+ if (oPtr->cachedNameObj) {
+ Tcl_DecrRefCount(oPtr->cachedNameObj);
+ oPtr->cachedNameObj = NULL;
+ }
+}
+
+/*
+ * ----------------------------------------------------------------------
+ *
* MyDeleted --
*
* This callback is triggered when the object's [my] command is deleted
@@ -788,10 +800,7 @@ ObjectRenamedTrace(
*/
if (flags & TCL_TRACE_RENAME) {
- if (oPtr->cachedNameObj) {
- Tcl_DecrRefCount(oPtr->cachedNameObj);
- oPtr->cachedNameObj = NULL;
- }
+ SquelchCachedName(oPtr);
return;
}
@@ -1044,7 +1053,7 @@ ReleaseClassContents(
Tcl_Obj *filterObj;
FOREACH(filterObj, clsPtr->filters) {
- Tcl_DecrRefCount(filterObj);
+ TclDecrRefCount(filterObj);
}
ckfree(clsPtr->filters.list);
clsPtr->filters.num = 0;
@@ -1123,7 +1132,7 @@ ObjectNamespaceDeleted(
}
FOREACH(filterObj, oPtr->filters) {
- Tcl_DecrRefCount(filterObj);
+ TclDecrRefCount(filterObj);
}
if (i) {
ckfree(oPtr->filters.list);
@@ -1138,7 +1147,7 @@ ObjectNamespaceDeleted(
}
FOREACH(variableObj, oPtr->variables) {
- Tcl_DecrRefCount(variableObj);
+ TclDecrRefCount(variableObj);
}
if (i) {
ckfree(oPtr->variables.list);
@@ -1148,10 +1157,7 @@ ObjectNamespaceDeleted(
TclOODeleteChainCache(oPtr->chainCache);
}
- if (oPtr->cachedNameObj) {
- Tcl_DecrRefCount(oPtr->cachedNameObj);
- oPtr->cachedNameObj = NULL;
- }
+ SquelchCachedName(oPtr);
if (oPtr->metadataPtr != NULL) {
Tcl_ObjectMetadataType *metadataTypePtr;
@@ -1180,7 +1186,7 @@ ObjectNamespaceDeleted(
}
FOREACH(filterObj, clsPtr->filters) {
- Tcl_DecrRefCount(filterObj);
+ TclDecrRefCount(filterObj);
}
if (i) {
ckfree(clsPtr->filters.list);
@@ -1225,7 +1231,7 @@ ObjectNamespaceDeleted(
TclOODelMethodRef(clsPtr->destructorPtr);
FOREACH(variableObj, clsPtr->variables) {
- Tcl_DecrRefCount(variableObj);
+ TclDecrRefCount(variableObj);
}
if (i) {
ckfree(clsPtr->variables.list);
@@ -1576,8 +1582,9 @@ Tcl_NewObjectInstance(
if (nameStr && Tcl_FindCommand(interp, nameStr, NULL,
TCL_NAMESPACE_ONLY)) {
- Tcl_AppendResult(interp, "can't create object \"", nameStr,
- "\": command already exists with that name", NULL);
+ 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;
}
@@ -1643,8 +1650,8 @@ Tcl_NewObjectInstance(
*/
if (result != TCL_ERROR && Deleted(oPtr)) {
- Tcl_SetResult(interp, "object deleted in constructor",
- TCL_STATIC);
+ Tcl_SetObjResult(interp, Tcl_NewStringObj(
+ "object deleted in constructor", -1));
Tcl_SetErrorCode(interp, "TCL", "OO", "STILLBORN", NULL);
result = TCL_ERROR;
}
@@ -1699,8 +1706,9 @@ TclNRNewObjectInstance(
if (nameStr && Tcl_FindCommand(interp, nameStr, NULL,
TCL_NAMESPACE_ONLY)) {
- Tcl_AppendResult(interp, "can't create object \"", nameStr,
- "\": command already exists with that name", NULL);
+ 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;
}
@@ -1788,7 +1796,8 @@ FinalizeAlloc(
*/
if (result != TCL_ERROR && Deleted(oPtr)) {
- Tcl_SetResult(interp, "object deleted in constructor", TCL_STATIC);
+ Tcl_SetObjResult(interp, Tcl_NewStringObj(
+ "object deleted in constructor", -1));
Tcl_SetErrorCode(interp, "TCL", "OO", "STILLBORN", NULL);
result = TCL_ERROR;
}
@@ -1845,7 +1854,8 @@ Tcl_CopyObjectInstance(
*/
if (IsRootClass(oPtr)) {
- Tcl_AppendResult(interp, "may not clone the class of classes", NULL);
+ Tcl_SetObjResult(interp, Tcl_NewStringObj(
+ "may not clone the class of classes", -1));
Tcl_SetErrorCode(interp, "TCL", "OO", "CLONING_CLASS", NULL);
return NULL;
}
@@ -2490,7 +2500,7 @@ TclOOObjectCmdCore(
result = oPtr->mapMethodNameProc(interp, (Tcl_Object) oPtr,
(Tcl_Class *) startClsPtr, mappedMethodName);
if (result != TCL_OK) {
- Tcl_DecrRefCount(mappedMethodName);
+ TclDecrRefCount(mappedMethodName);
if (result == TCL_BREAK) {
goto noMapping;
} else if (result == TCL_ERROR) {
@@ -2506,11 +2516,11 @@ TclOOObjectCmdCore(
Tcl_IncrRefCount(mappedMethodName);
contextPtr = TclOOGetCallContext(oPtr, mappedMethodName,
flags | (oPtr->flags & FILTER_HANDLING), methodNamePtr);
- Tcl_DecrRefCount(mappedMethodName);
+ TclDecrRefCount(mappedMethodName);
if (contextPtr == NULL) {
- Tcl_AppendResult(interp, "impossible to invoke method \"",
- TclGetString(methodNamePtr),
- "\": no defined method or unknown method", NULL);
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "impossible to invoke method \"%s\": no defined method or"
+ " unknown method", TclGetString(methodNamePtr)));
Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "METHOD_MAPPED",
TclGetString(methodNamePtr), NULL);
return TCL_ERROR;
@@ -2524,9 +2534,9 @@ TclOOObjectCmdCore(
contextPtr = TclOOGetCallContext(oPtr, methodNamePtr,
flags | (oPtr->flags & FILTER_HANDLING), NULL);
if (contextPtr == NULL) {
- Tcl_AppendResult(interp, "impossible to invoke method \"",
- TclGetString(methodNamePtr),
- "\": no defined method or unknown method", NULL);
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "impossible to invoke method \"%s\": no defined method or"
+ " unknown method", TclGetString(methodNamePtr)));
Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "METHOD",
TclGetString(methodNamePtr), NULL);
return TCL_ERROR;
@@ -2552,8 +2562,8 @@ TclOOObjectCmdCore(
}
}
if (contextPtr->index >= contextPtr->callPtr->numChain) {
- Tcl_SetResult(interp, "no valid method implementation",
- TCL_STATIC);
+ Tcl_SetObjResult(interp, Tcl_NewStringObj(
+ "no valid method implementation", -1));
Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "METHOD",
TclGetString(methodNamePtr), NULL);
TclOODeleteContext(contextPtr);
@@ -2634,8 +2644,8 @@ Tcl_ObjectContextInvokeNext(
methodType = "method";
}
- Tcl_AppendResult(interp, "no next ", methodType, " implementation",
- NULL);
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "no next %s implementation", methodType));
Tcl_SetErrorCode(interp, "TCL", "OO", "NOTHING_NEXT", NULL);
return TCL_ERROR;
}
@@ -2703,8 +2713,8 @@ TclNRObjectContextInvokeNext(
methodType = "method";
}
- Tcl_AppendResult(interp, "no next ", methodType, " implementation",
- NULL);
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "no next %s implementation", methodType));
Tcl_SetErrorCode(interp, "TCL", "OO", "NOTHING_NEXT", NULL);
return TCL_ERROR;
}
@@ -2781,8 +2791,8 @@ Tcl_GetObjectFromObj(
return cmdPtr->objClientData;
notAnObject:
- Tcl_AppendResult(interp, TclGetString(objPtr),
- " does not refer to an object", NULL);
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "%s does not refer to an object", TclGetString(objPtr)));
Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "OBJECT", TclGetString(objPtr),
NULL);
return NULL;
diff --git a/generic/tclOOBasic.c b/generic/tclOOBasic.c
index 329f0a4..3637ede 100644
--- a/generic/tclOOBasic.c
+++ b/generic/tclOOBasic.c
@@ -19,6 +19,8 @@
static inline Tcl_Object *AddConstructionFinalizer(Tcl_Interp *interp);
static int AfterNRDestructor(ClientData data[],
Tcl_Interp *interp, int result);
+static int DecrRefsPostClassConstructor(ClientData data[],
+ Tcl_Interp *interp, int result);
static int FinalizeConstruction(ClientData data[],
Tcl_Interp *interp, int result);
static int FinalizeEval(ClientData data[],
@@ -70,6 +72,74 @@ FinalizeConstruction(
/*
* ----------------------------------------------------------------------
*
+ * TclOO_Class_Constructor --
+ *
+ * Implementation for oo::class constructor.
+ *
+ * ----------------------------------------------------------------------
+ */
+
+int
+TclOO_Class_Constructor(
+ ClientData clientData,
+ Tcl_Interp *interp,
+ Tcl_ObjectContext context,
+ int objc,
+ Tcl_Obj *const *objv)
+{
+ Object *oPtr = (Object *) Tcl_ObjectContextObject(context);
+ Tcl_Obj *invoke[3];
+
+ if (objc-1 > Tcl_ObjectContextSkippedArgs(context)) {
+ Tcl_WrongNumArgs(interp, Tcl_ObjectContextSkippedArgs(context), objv,
+ "?definitionScript?");
+ return TCL_ERROR;
+ } else if (objc == Tcl_ObjectContextSkippedArgs(context)) {
+ return TCL_OK;
+ }
+
+ /*
+ * Delegate to [oo::define] to do the work.
+ */
+
+ invoke[0] = oPtr->fPtr->defineName;
+ invoke[1] = TclOOObjectName(interp, oPtr);
+ invoke[2] = objv[objc-1];
+
+ /*
+ * Must add references or errors in configuration script will cause
+ * trouble.
+ */
+
+ Tcl_IncrRefCount(invoke[0]);
+ Tcl_IncrRefCount(invoke[1]);
+ Tcl_IncrRefCount(invoke[2]);
+ TclNRAddCallback(interp, DecrRefsPostClassConstructor,
+ invoke[0], invoke[1], invoke[2], NULL);
+
+ /*
+ * Tricky point: do not want the extra reported level in the Tcl stack
+ * trace, so use TCL_EVAL_NOERR.
+ */
+
+ return TclNREvalObjv(interp, 3, invoke, TCL_EVAL_NOERR, NULL);
+}
+
+static int
+DecrRefsPostClassConstructor(
+ ClientData data[],
+ Tcl_Interp *interp,
+ int result)
+{
+ TclDecrRefCount((Tcl_Obj *) data[0]);
+ TclDecrRefCount((Tcl_Obj *) data[1]);
+ TclDecrRefCount((Tcl_Obj *) data[2]);
+ return result;
+}
+
+/*
+ * ----------------------------------------------------------------------
+ *
* TclOO_Class_Create --
*
* Implementation for oo::class->create method.
@@ -98,8 +168,8 @@ TclOO_Class_Create(
if (oPtr->classPtr == NULL) {
Tcl_Obj *cmdnameObj = TclOOObjectName(interp, oPtr);
- Tcl_AppendResult(interp, "object \"", TclGetString(cmdnameObj),
- "\" is not a class", NULL);
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "object \"%s\" is not a class", TclGetString(cmdnameObj)));
Tcl_SetErrorCode(interp, "TCL", "OO", "INSTANTIATE_NONCLASS", NULL);
return TCL_ERROR;
}
@@ -116,7 +186,8 @@ TclOO_Class_Create(
objName = Tcl_GetStringFromObj(
objv[Tcl_ObjectContextSkippedArgs(context)], &len);
if (len == 0) {
- Tcl_AppendResult(interp, "object name must not be empty", NULL);
+ Tcl_SetObjResult(interp, Tcl_NewStringObj(
+ "object name must not be empty", -1));
Tcl_SetErrorCode(interp, "TCL", "OO", "EMPTY_NAME", NULL);
return TCL_ERROR;
}
@@ -162,8 +233,8 @@ TclOO_Class_CreateNs(
if (oPtr->classPtr == NULL) {
Tcl_Obj *cmdnameObj = TclOOObjectName(interp, oPtr);
- Tcl_AppendResult(interp, "object \"", TclGetString(cmdnameObj),
- "\" is not a class", NULL);
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "object \"%s\" is not a class", TclGetString(cmdnameObj)));
Tcl_SetErrorCode(interp, "TCL", "OO", "INSTANTIATE_NONCLASS", NULL);
return TCL_ERROR;
}
@@ -180,14 +251,16 @@ TclOO_Class_CreateNs(
objName = Tcl_GetStringFromObj(
objv[Tcl_ObjectContextSkippedArgs(context)], &len);
if (len == 0) {
- Tcl_AppendResult(interp, "object name must not be empty", NULL);
+ Tcl_SetObjResult(interp, Tcl_NewStringObj(
+ "object name must not be empty", -1));
Tcl_SetErrorCode(interp, "TCL", "OO", "EMPTY_NAME", NULL);
return TCL_ERROR;
}
nsName = Tcl_GetStringFromObj(
objv[Tcl_ObjectContextSkippedArgs(context)+1], &len);
if (len == 0) {
- Tcl_AppendResult(interp, "namespace name must not be empty", NULL);
+ Tcl_SetObjResult(interp, Tcl_NewStringObj(
+ "namespace name must not be empty", -1));
Tcl_SetErrorCode(interp, "TCL", "OO", "EMPTY_NAME", NULL);
return TCL_ERROR;
}
@@ -231,8 +304,8 @@ TclOO_Class_New(
if (oPtr->classPtr == NULL) {
Tcl_Obj *cmdnameObj = TclOOObjectName(interp, oPtr);
- Tcl_AppendResult(interp, "object \"", TclGetString(cmdnameObj),
- "\" is not a class", NULL);
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "object \"%s\" is not a class", TclGetString(cmdnameObj)));
Tcl_SetErrorCode(interp, "TCL", "OO", "INSTANTIATE_NONCLASS", NULL);
return TCL_ERROR;
}
@@ -434,6 +507,7 @@ TclOO_Object_Unknown(
Object *oPtr = contextPtr->oPtr;
const char **methodNames;
int numMethodNames, i, skip = Tcl_ObjectContextSkippedArgs(context);
+ Tcl_Obj *errorMsg;
/*
* If no method name, generate an error asking for a method name. (Only by
@@ -459,31 +533,34 @@ TclOO_Object_Unknown(
if (numMethodNames == 0) {
Tcl_Obj *tmpBuf = TclOOObjectName(interp, oPtr);
+ const char *piece;
- Tcl_AppendResult(interp, "object \"", TclGetString(tmpBuf), NULL);
if (contextPtr->callPtr->flags & PUBLIC_METHOD) {
- Tcl_AppendResult(interp, "\" has no visible methods", NULL);
+ piece = "visible methods";
} else {
- Tcl_AppendResult(interp, "\" has no methods", NULL);
+ piece = "methods";
}
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "object \"%s\" has no %s", TclGetString(tmpBuf), piece));
Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "METHOD",
TclGetString(objv[skip]), NULL);
return TCL_ERROR;
}
- Tcl_AppendResult(interp, "unknown method \"", TclGetString(objv[skip]),
- "\": must be ", NULL);
+ errorMsg = Tcl_ObjPrintf("unknown method \"%s\": must be ",
+ TclGetString(objv[skip]));
for (i=0 ; i<numMethodNames-1 ; i++) {
if (i) {
- Tcl_AppendResult(interp, ", ", NULL);
+ Tcl_AppendToObj(errorMsg, ", ", -1);
}
- Tcl_AppendResult(interp, methodNames[i], NULL);
+ Tcl_AppendToObj(errorMsg, methodNames[i], -1);
}
if (i) {
- Tcl_AppendResult(interp, " or ", NULL);
+ Tcl_AppendToObj(errorMsg, " or ", -1);
}
- Tcl_AppendResult(interp, methodNames[i], NULL);
+ Tcl_AppendToObj(errorMsg, methodNames[i], -1);
ckfree(methodNames);
+ Tcl_SetObjResult(interp, errorMsg);
Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "METHOD",
TclGetString(objv[skip]), NULL);
return TCL_ERROR;
@@ -539,8 +616,9 @@ TclOO_Object_LinkVar(
*/
if (strstr(varName, "::") != NULL) {
- Tcl_AppendResult(interp, "variable name \"", varName,
- "\" illegal: must not contain namespace separator", NULL);
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "variable name \"%s\" illegal: must not contain namespace"
+ " separator", varName));
Tcl_SetErrorCode(interp, "TCL", "UPVAR", "INVERTED", NULL);
return TCL_ERROR;
}
@@ -714,8 +792,9 @@ TclOONextObjCmd(
*/
if (framePtr == NULL || !(framePtr->isProcCallFrame & FRAME_IS_METHOD)) {
- Tcl_AppendResult(interp, TclGetString(objv[0]),
- " may only be called from inside a method", NULL);
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "%s may only be called from inside a method",
+ TclGetString(objv[0])));
Tcl_SetErrorCode(interp, "TCL", "OO", "CONTEXT_REQUIRED", NULL);
return TCL_ERROR;
}
@@ -752,8 +831,9 @@ TclOONextToObjCmd(
*/
if (framePtr == NULL || !(framePtr->isProcCallFrame & FRAME_IS_METHOD)) {
- Tcl_AppendResult(interp, TclGetString(objv[0]),
- " may only be called from inside a method", NULL);
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "%s may only be called from inside a method",
+ TclGetString(objv[0])));
Tcl_SetErrorCode(interp, "TCL", "OO", "CONTEXT_REQUIRED", NULL);
return TCL_ERROR;
}
@@ -773,8 +853,9 @@ TclOONextToObjCmd(
}
classPtr = ((Object *)object)->classPtr;
if (classPtr == NULL) {
- Tcl_AppendResult(interp, "\"", TclGetString(objv[1]),
- "\" is not a class", NULL);
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "\"%s\" is not a class", TclGetString(objv[1])));
+ Tcl_SetErrorCode(interp, "TCL", "OO", "CLASS_REQUIRED", NULL);
return TCL_ERROR;
}
@@ -811,14 +892,15 @@ TclOONextToObjCmd(
struct MInvoke *miPtr = contextPtr->callPtr->chain + i;
if (!miPtr->isFilter && miPtr->mPtr->declaringClassPtr == classPtr) {
- Tcl_AppendResult(interp, "method implementation by \"",
- TclGetString(objv[1]), "\" not reachable from here",
- NULL);
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "method implementation by \"%s\" not reachable from here",
+ TclGetString(objv[1])));
return TCL_ERROR;
}
}
- Tcl_AppendResult(interp, "method has no non-filter implementation by \"",
- TclGetString(objv[1]), "\"", NULL);
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "method has no non-filter implementation by \"%s\"",
+ TclGetString(objv[1])));
return TCL_ERROR;
}
@@ -878,8 +960,9 @@ TclOOSelfObjCmd(
*/
if (framePtr == NULL || !(framePtr->isProcCallFrame & FRAME_IS_METHOD)) {
- Tcl_AppendResult(interp, TclGetString(objv[0]),
- " may only be called from inside a method", NULL);
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "%s may only be called from inside a method",
+ TclGetString(objv[0])));
Tcl_SetErrorCode(interp, "TCL", "OO", "CONTEXT_REQUIRED", NULL);
return TCL_ERROR;
}
@@ -913,7 +996,8 @@ TclOOSelfObjCmd(
Class *clsPtr = CurrentlyInvoked(contextPtr).mPtr->declaringClassPtr;
if (clsPtr == NULL) {
- Tcl_AppendResult(interp, "method not defined by a class", NULL);
+ Tcl_SetObjResult(interp, Tcl_NewStringObj(
+ "method not defined by a class", -1));
Tcl_SetErrorCode(interp, "TCL", "OO", "UNMATCHED_CONTEXT", NULL);
return TCL_ERROR;
}
@@ -933,7 +1017,8 @@ TclOOSelfObjCmd(
return TCL_OK;
case SELF_FILTER:
if (!CurrentlyInvoked(contextPtr).isFilter) {
- Tcl_AppendResult(interp, "not inside a filtering context", NULL);
+ Tcl_SetObjResult(interp, Tcl_NewStringObj(
+ "not inside a filtering context", -1));
Tcl_SetErrorCode(interp, "TCL", "OO", "UNMATCHED_CONTEXT", NULL);
return TCL_ERROR;
} else {
@@ -958,7 +1043,8 @@ TclOOSelfObjCmd(
case SELF_CALLER:
if ((framePtr->callerVarPtr == NULL) ||
!(framePtr->callerVarPtr->isProcCallFrame & FRAME_IS_METHOD)){
- Tcl_AppendResult(interp, "caller is not an object", NULL);
+ Tcl_SetObjResult(interp, Tcl_NewStringObj(
+ "caller is not an object", -1));
Tcl_SetErrorCode(interp, "TCL", "OO", "CONTEXT_REQUIRED", NULL);
return TCL_ERROR;
} else {
@@ -975,7 +1061,8 @@ TclOOSelfObjCmd(
* This should be unreachable code.
*/
- Tcl_AppendResult(interp, "method without declarer!", NULL);
+ Tcl_SetObjResult(interp, Tcl_NewStringObj(
+ "method without declarer!", -1));
return TCL_ERROR;
}
@@ -1006,7 +1093,8 @@ TclOOSelfObjCmd(
* This should be unreachable code.
*/
- Tcl_AppendResult(interp, "method without declarer!", NULL);
+ Tcl_SetObjResult(interp, Tcl_NewStringObj(
+ "method without declarer!", -1));
return TCL_ERROR;
}
@@ -1023,7 +1111,8 @@ TclOOSelfObjCmd(
return TCL_OK;
case SELF_TARGET:
if (!CurrentlyInvoked(contextPtr).isFilter) {
- Tcl_AppendResult(interp, "not inside a filtering context", NULL);
+ Tcl_SetObjResult(interp, Tcl_NewStringObj(
+ "not inside a filtering context", -1));
Tcl_SetErrorCode(interp, "TCL", "OO", "UNMATCHED_CONTEXT", NULL);
return TCL_ERROR;
} else {
@@ -1049,7 +1138,8 @@ TclOOSelfObjCmd(
* This should be unreachable code.
*/
- Tcl_AppendResult(interp, "method without declarer!", NULL);
+ Tcl_SetObjResult(interp, Tcl_NewStringObj(
+ "method without declarer!", -1));
return TCL_ERROR;
}
result[0] = TclOOObjectName(interp, declarerPtr);
@@ -1120,7 +1210,7 @@ TclOOCopyObjectCmd(
Tcl_DStringAppend(&buffer,
iPtr->varFramePtr->nsPtr->fullName, -1);
}
- Tcl_DStringAppend(&buffer, "::", 2);
+ TclDStringAppendLiteral(&buffer, "::");
Tcl_DStringAppend(&buffer, name, -1);
name = Tcl_DStringValue(&buffer);
}
@@ -1141,74 +1231,6 @@ TclOOCopyObjectCmd(
}
/*
- * ----------------------------------------------------------------------
- *
- * TclOOUpcatchCmd --
- *
- * Implementation of the [oo::UpCatch] command, which is a combination of
- * [uplevel 1] and [catch] that makes it easier to write transparent
- * error handling in scripts.
- *
- * ----------------------------------------------------------------------
- */
-
-int
-TclOOUpcatchCmd(
- ClientData ignored,
- Tcl_Interp *interp,
- int objc,
- Tcl_Obj *const objv[])
-{
- return Tcl_NRCallObjProc(interp, TclOONRUpcatch, NULL, objc, objv);
-}
-
-static int
-UpcatchCallback(
- ClientData data[],
- Tcl_Interp *interp,
- int result)
-{
- Interp *iPtr = (Interp *) interp;
- CallFrame *savedFramePtr = data[0];
- Tcl_Obj *resultObj[2];
- int rewind = iPtr->execEnvPtr->rewind;
-
- iPtr->varFramePtr = savedFramePtr;
- if (rewind || Tcl_LimitExceeded(interp)) {
- Tcl_AppendObjToErrorInfo(interp, Tcl_ObjPrintf(
- "\n (\"UpCatch\" body line %d)", Tcl_GetErrorLine(interp)));
- return TCL_ERROR;
- }
- resultObj[0] = Tcl_GetObjResult(interp);
- resultObj[1] = Tcl_GetReturnOptions(interp, result);
- Tcl_SetObjResult(interp, Tcl_NewListObj(2, resultObj));
- return TCL_OK;
-}
-
-int
-TclOONRUpcatch(
- ClientData ignored,
- Tcl_Interp *interp,
- int objc,
- Tcl_Obj *const objv[])
-{
- Interp *iPtr = (Interp *) interp;
- CallFrame *savedFramePtr = iPtr->varFramePtr;
-
- if (objc != 2) {
- Tcl_WrongNumArgs(interp, 1, objv, "script");
- return TCL_ERROR;
- }
- if (iPtr->varFramePtr->callerVarPtr != NULL) {
- iPtr->varFramePtr = iPtr->varFramePtr->callerVarPtr;
- }
-
- Tcl_NRAddCallback(interp, UpcatchCallback, savedFramePtr, NULL,NULL,NULL);
- return TclNREvalObjEx(interp, objv[1], TCL_EVAL_NOERR,
- iPtr->cmdFramePtr, 1);
-}
-
-/*
* Local Variables:
* mode: c
* c-basic-offset: 4
diff --git a/generic/tclOODefineCmds.c b/generic/tclOODefineCmds.c
index 3d72690..c022e6b 100644
--- a/generic/tclOODefineCmds.c
+++ b/generic/tclOODefineCmds.c
@@ -17,6 +17,13 @@
#include "tclOOInt.h"
/*
+ * The maximum length of fully-qualified object name to use in an errorinfo
+ * message. Longer than this will be curtailed.
+ */
+
+#define OBJNAME_LENGTH_IN_ERRORINFO_LIMIT 30
+
+/*
* Some things that make it easier to declare a slot.
*/
@@ -40,6 +47,8 @@ struct DeclaredSlot {
static inline void BumpGlobalEpoch(Tcl_Interp *interp, Class *classPtr);
static Tcl_Command FindCommand(Tcl_Interp *interp, Tcl_Obj *stringObj,
Tcl_Namespace *const namespacePtr);
+static void GenerateErrorInfo(Tcl_Interp *interp, Object *oPtr,
+ Tcl_Obj *savedNameObj, const char *typeOfSubject);
static inline Class * GetClassInOuterContext(Tcl_Interp *interp,
Tcl_Obj *className, const char *errMsg);
static inline int InitDefineContext(Tcl_Interp *interp,
@@ -414,8 +423,8 @@ RenameDeleteMethod(
if (!useClass) {
if (!oPtr->methodsPtr) {
noSuchMethod:
- Tcl_AppendResult(interp, "method ", TclGetString(fromPtr),
- " does not exist", NULL);
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "method %s does not exist", TclGetString(fromPtr)));
Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "METHOD",
TclGetString(fromPtr), NULL);
return TCL_ERROR;
@@ -429,14 +438,15 @@ RenameDeleteMethod(
&isNew);
if (hPtr == newHPtr) {
renameToSelf:
- Tcl_AppendResult(interp, "cannot rename method to itself",
- NULL);
+ Tcl_SetObjResult(interp, Tcl_NewStringObj(
+ "cannot rename method to itself", -1));
Tcl_SetErrorCode(interp, "TCL", "OO", "RENAME_TO_SELF", NULL);
return TCL_ERROR;
} else if (!isNew) {
renameToExisting:
- Tcl_AppendResult(interp, "method called ",
- TclGetString(toPtr), " already exists", NULL);
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "method called %s already exists",
+ TclGetString(toPtr)));
Tcl_SetErrorCode(interp, "TCL", "OO", "RENAME_OVER", NULL);
return TCL_ERROR;
}
@@ -504,7 +514,8 @@ TclOOUnknownDefinition(
const char *soughtStr, *matchedStr = NULL;
if (objc < 2) {
- Tcl_AppendResult(interp, "bad call of unknown handler", NULL);
+ Tcl_SetObjResult(interp, Tcl_NewStringObj(
+ "bad call of unknown handler", -1));
Tcl_SetErrorCode(interp, "TCL", "OO", "BAD_UNKNOWN", NULL);
return TCL_ERROR;
}
@@ -549,7 +560,8 @@ TclOOUnknownDefinition(
}
noMatch:
- Tcl_AppendResult(interp, "invalid command name \"",soughtStr,"\"", NULL);
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "invalid command name \"%s\"", soughtStr));
Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "COMMAND", soughtStr, NULL);
return TCL_ERROR;
}
@@ -637,9 +649,9 @@ InitDefineContext(
int result;
if (namespacePtr == NULL) {
- Tcl_AppendResult(interp,
+ Tcl_SetObjResult(interp, Tcl_NewStringObj(
"cannot process definitions; support namespace deleted",
- NULL);
+ -1));
Tcl_SetErrorCode(interp, "TCL", "OO", "MONKEY_BUSINESS", NULL);
return TCL_ERROR;
}
@@ -673,16 +685,25 @@ TclOOGetDefineCmdContext(
Tcl_Interp *interp)
{
Interp *iPtr = (Interp *) interp;
+ Tcl_Object object;
if ((iPtr->varFramePtr == NULL)
|| (iPtr->varFramePtr->isProcCallFrame != FRAME_IS_OO_DEFINE)) {
- Tcl_AppendResult(interp, "this command may only be called from within"
- " the context of an ::oo::define or ::oo::objdefine command",
- NULL);
+ Tcl_SetObjResult(interp, Tcl_NewStringObj(
+ "this command may only be called from within the context of"
+ " an ::oo::define or ::oo::objdefine command", -1));
Tcl_SetErrorCode(interp, "TCL", "OO", "MONKEY_BUSINESS", NULL);
return NULL;
}
- return (Tcl_Object) iPtr->varFramePtr->clientData;
+ object = iPtr->varFramePtr->clientData;
+ if (Tcl_ObjectDeleted(object)) {
+ Tcl_SetObjResult(interp, Tcl_NewStringObj(
+ "this command cannot be called when the object has been"
+ " deleted", -1));
+ Tcl_SetErrorCode(interp, "TCL", "OO", "MONKEY_BUSINESS", NULL);
+ return NULL;
+ }
+ return object;
}
/*
@@ -719,7 +740,7 @@ GetClassInOuterContext(
return NULL;
}
if (oPtr->classPtr == NULL) {
- Tcl_AppendResult(interp, errMsg, NULL);
+ Tcl_SetObjResult(interp, Tcl_NewStringObj(errMsg, -1));
Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "CLASS",
TclGetString(className), NULL);
return NULL;
@@ -730,6 +751,44 @@ GetClassInOuterContext(
/*
* ----------------------------------------------------------------------
*
+ * GenerateErrorInfo --
+ * Factored out code to generate part of the error trace messages.
+ *
+ * ----------------------------------------------------------------------
+ */
+
+static void
+GenerateErrorInfo(
+ Tcl_Interp *interp, /* Where to store the error info trace. */
+ Object *oPtr, /* What object (or class) was being configured
+ * when the error occurred? */
+ Tcl_Obj *savedNameObj, /* Name of object saved from before script was
+ * evaluated, which is needed if the object
+ * goes away part way through execution. OTOH,
+ * if the object isn't deleted then its
+ * current name (post-execution) has to be
+ * used. This matters, because the object
+ * could have been renamed... */
+ const char *typeOfSubject) /* Part of the message, saying whether it was
+ * an object, class or class-as-object that
+ * was being configured. */
+{
+ int length;
+ Tcl_Obj *realNameObj = Tcl_ObjectDeleted((Tcl_Object) oPtr)
+ ? savedNameObj : TclOOObjectName(interp, oPtr);
+ const char *objName = Tcl_GetStringFromObj(realNameObj, &length);
+ int limit = OBJNAME_LENGTH_IN_ERRORINFO_LIMIT;
+ int overflow = (length > limit);
+
+ Tcl_AppendObjToErrorInfo(interp, Tcl_ObjPrintf(
+ "\n (in definition script for %s \"%.*s%s\" line %d)",
+ typeOfSubject, (overflow ? limit : length), objName,
+ (overflow ? "..." : ""), Tcl_GetErrorLine(interp)));
+}
+
+/*
+ * ----------------------------------------------------------------------
+ *
* TclOODefineObjCmd --
* Implementation of the "oo::define" command. Works by effectively doing
* the same as 'namespace eval', but with extra magic applied so that the
@@ -761,8 +820,8 @@ TclOODefineObjCmd(
return TCL_ERROR;
}
if (oPtr->classPtr == NULL) {
- Tcl_AppendResult(interp, TclGetString(objv[1]),
- " does not refer to a class", NULL);
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "%s does not refer to a class",TclGetString(objv[1])));
Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "CLASS",
TclGetString(objv[1]), NULL);
return TCL_ERROR;
@@ -779,20 +838,15 @@ TclOODefineObjCmd(
AddRef(oPtr);
if (objc == 3) {
+ Tcl_Obj *objNameObj = TclOOObjectName(interp, oPtr);
+
+ Tcl_IncrRefCount(objNameObj);
result = TclEvalObjEx(interp, objv[2], 0,
((Interp *)interp)->cmdFramePtr, 2);
-
if (result == TCL_ERROR) {
- int length;
- const char *objName = Tcl_GetStringFromObj(objv[1], &length);
- int limit = 60;
- int overflow = (length > limit);
-
- Tcl_AppendObjToErrorInfo(interp, Tcl_ObjPrintf(
- "\n (in definition script for object \"%.*s%s\" line %d)",
- (overflow ? limit : length), objName,
- (overflow ? "..." : ""), Tcl_GetErrorLine(interp)));
+ GenerateErrorInfo(interp, oPtr, objNameObj, "class");
}
+ TclDecrRefCount(objNameObj);
} else {
Tcl_Obj *objPtr, *obj2Ptr, **objs;
Interp *iPtr = (Interp *) interp;
@@ -898,20 +952,15 @@ TclOOObjDefObjCmd(
AddRef(oPtr);
if (objc == 3) {
+ Tcl_Obj *objNameObj = TclOOObjectName(interp, oPtr);
+
+ Tcl_IncrRefCount(objNameObj);
result = TclEvalObjEx(interp, objv[2], 0,
((Interp *)interp)->cmdFramePtr, 2);
-
if (result == TCL_ERROR) {
- int length;
- const char *objName = Tcl_GetStringFromObj(objv[1], &length);
- int limit = 60;
- int overflow = (length > limit);
-
- Tcl_AppendObjToErrorInfo(interp, Tcl_ObjPrintf(
- "\n (in definition script for object \"%.*s%s\" line %d)",
- (overflow ? limit : length), objName,
- (overflow ? "..." : ""), Tcl_GetErrorLine(interp)));
+ GenerateErrorInfo(interp, oPtr, objNameObj, "object");
}
+ TclDecrRefCount(objNameObj);
} else {
Tcl_Obj *objPtr, *obj2Ptr, **objs;
Interp *iPtr = (Interp *) interp;
@@ -1017,21 +1066,15 @@ TclOODefineSelfObjCmd(
AddRef(oPtr);
if (objc == 2) {
+ Tcl_Obj *objNameObj = TclOOObjectName(interp, oPtr);
+
+ Tcl_IncrRefCount(objNameObj);
result = TclEvalObjEx(interp, objv[1], 0,
((Interp *)interp)->cmdFramePtr, 2);
-
if (result == TCL_ERROR) {
- int length;
- const char *objName = Tcl_GetStringFromObj(
- TclOOObjectName(interp, oPtr), &length);
- int limit = 60;
- int overflow = (length > limit);
-
- Tcl_AppendObjToErrorInfo(interp, Tcl_ObjPrintf(
- "\n (in definition script for object \"%.*s%s\" line %d)",
- (overflow ? limit : length), objName,
- (overflow ? "..." : ""), Tcl_GetErrorLine(interp)));
+ GenerateErrorInfo(interp, oPtr, objNameObj, "class object");
}
+ TclDecrRefCount(objNameObj);
} else {
Tcl_Obj *objPtr, *obj2Ptr, **objs;
Interp *iPtr = (Interp *) interp;
@@ -1122,14 +1165,14 @@ TclOODefineClassObjCmd(
return TCL_ERROR;
}
if (oPtr->flags & ROOT_OBJECT) {
- Tcl_AppendResult(interp,
- "may not modify the class of the root object class", NULL);
+ Tcl_SetObjResult(interp, Tcl_NewStringObj(
+ "may not modify the class of the root object class", -1));
Tcl_SetErrorCode(interp, "TCL", "OO", "MONKEY_BUSINESS", NULL);
return TCL_ERROR;
}
if (oPtr->flags & ROOT_CLASS) {
- Tcl_AppendResult(interp,
- "may not modify the class of the class of classes", NULL);
+ Tcl_SetObjResult(interp, Tcl_NewStringObj(
+ "may not modify the class of the class of classes", -1));
Tcl_SetErrorCode(interp, "TCL", "OO", "MONKEY_BUSINESS", NULL);
return TCL_ERROR;
}
@@ -1155,9 +1198,10 @@ TclOODefineClassObjCmd(
*/
if ((oPtr->classPtr==NULL) == TclOOIsReachable(fPtr->classCls, clsPtr)) {
- Tcl_AppendResult(interp, "may not change a ",
- (oPtr->classPtr==NULL ? "non-" : ""), "class object into a ",
- (oPtr->classPtr==NULL ? "" : "non-"), "class object", NULL);
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "may not change a %sclass object into a %sclass object",
+ (oPtr->classPtr==NULL ? "non-" : ""),
+ (oPtr->classPtr==NULL ? "" : "non-")));
Tcl_SetErrorCode(interp, "TCL", "OO", "TRANSMUTATION", NULL);
return TCL_ERROR;
}
@@ -1278,7 +1322,8 @@ TclOODefineDeleteMethodObjCmd(
return TCL_ERROR;
}
if (!isInstanceDeleteMethod && !oPtr->classPtr) {
- Tcl_AppendResult(interp, "attempt to misuse API", NULL);
+ Tcl_SetObjResult(interp, Tcl_NewStringObj(
+ "attempt to misuse API", -1));
Tcl_SetErrorCode(interp, "TCL", "OO", "MONKEY_BUSINESS", NULL);
return TCL_ERROR;
}
@@ -1401,7 +1446,8 @@ TclOODefineExportObjCmd(
}
clsPtr = oPtr->classPtr;
if (!isInstanceExport && !clsPtr) {
- Tcl_AppendResult(interp, "attempt to misuse API", NULL);
+ Tcl_SetObjResult(interp, Tcl_NewStringObj(
+ "attempt to misuse API", -1));
Tcl_SetErrorCode(interp, "TCL", "OO", "MONKEY_BUSINESS", NULL);
return TCL_ERROR;
}
@@ -1492,7 +1538,8 @@ TclOODefineForwardObjCmd(
return TCL_ERROR;
}
if (!isInstanceForward && !oPtr->classPtr) {
- Tcl_AppendResult(interp, "attempt to misuse API", NULL);
+ Tcl_SetObjResult(interp, Tcl_NewStringObj(
+ "attempt to misuse API", -1));
Tcl_SetErrorCode(interp, "TCL", "OO", "MONKEY_BUSINESS", NULL);
return TCL_ERROR;
}
@@ -1549,7 +1596,8 @@ TclOODefineMethodObjCmd(
return TCL_ERROR;
}
if (!isInstanceMethod && !oPtr->classPtr) {
- Tcl_AppendResult(interp, "attempt to misuse API", NULL);
+ Tcl_SetObjResult(interp, Tcl_NewStringObj(
+ "attempt to misuse API", -1));
Tcl_SetErrorCode(interp, "TCL", "OO", "MONKEY_BUSINESS", NULL);
return TCL_ERROR;
}
@@ -1600,7 +1648,8 @@ TclOODefineMixinObjCmd(
return TCL_ERROR;
}
if (!isInstanceMixin && !oPtr->classPtr) {
- Tcl_AppendResult(interp, "attempt to misuse API", NULL);
+ Tcl_SetObjResult(interp, Tcl_NewStringObj(
+ "attempt to misuse API", -1));
Tcl_SetErrorCode(interp, "TCL", "OO", "MONKEY_BUSINESS", NULL);
return TCL_ERROR;
}
@@ -1614,7 +1663,8 @@ TclOODefineMixinObjCmd(
goto freeAndError;
}
if (!isInstanceMixin && TclOOIsReachable(oPtr->classPtr, clsPtr)) {
- Tcl_AppendResult(interp, "may not mix a class into itself", NULL);
+ Tcl_SetObjResult(interp, Tcl_NewStringObj(
+ "may not mix a class into itself", -1));
Tcl_SetErrorCode(interp, "TCL", "OO", "SELF_MIXIN", NULL);
goto freeAndError;
}
@@ -1665,7 +1715,8 @@ TclOODefineRenameMethodObjCmd(
return TCL_ERROR;
}
if (!isInstanceRenameMethod && !oPtr->classPtr) {
- Tcl_AppendResult(interp, "attempt to misuse API", NULL);
+ Tcl_SetObjResult(interp, Tcl_NewStringObj(
+ "attempt to misuse API", -1));
Tcl_SetErrorCode(interp, "TCL", "OO", "MONKEY_BUSINESS", NULL);
return TCL_ERROR;
}
@@ -1725,7 +1776,8 @@ TclOODefineUnexportObjCmd(
}
clsPtr = oPtr->classPtr;
if (!isInstanceUnexport && !clsPtr) {
- Tcl_AppendResult(interp, "attempt to misuse API", NULL);
+ Tcl_SetObjResult(interp, Tcl_NewStringObj(
+ "attempt to misuse API", -1));
Tcl_SetErrorCode(interp, "TCL", "OO", "MONKEY_BUSINESS", NULL);
return TCL_ERROR;
}
@@ -1910,7 +1962,8 @@ ClassFilterGet(
if (oPtr == NULL) {
return TCL_ERROR;
} else if (!oPtr->classPtr) {
- Tcl_AppendResult(interp, "attempt to misuse API", NULL);
+ Tcl_SetObjResult(interp, Tcl_NewStringObj(
+ "attempt to misuse API", -1));
Tcl_SetErrorCode(interp, "TCL", "OO", "MONKEY_BUSINESS", NULL);
return TCL_ERROR;
}
@@ -1945,7 +1998,8 @@ ClassFilterSet(
if (oPtr == NULL) {
return TCL_ERROR;
} else if (!oPtr->classPtr) {
- Tcl_AppendResult(interp, "attempt to misuse API", NULL);
+ Tcl_SetObjResult(interp, Tcl_NewStringObj(
+ "attempt to misuse API", -1));
Tcl_SetErrorCode(interp, "TCL", "OO", "MONKEY_BUSINESS", NULL);
return TCL_ERROR;
} else if (Tcl_ListObjGetElements(interp, objv[0], &filterc,
@@ -1988,7 +2042,8 @@ ClassMixinGet(
if (oPtr == NULL) {
return TCL_ERROR;
} else if (!oPtr->classPtr) {
- Tcl_AppendResult(interp, "attempt to misuse API", NULL);
+ Tcl_SetObjResult(interp, Tcl_NewStringObj(
+ "attempt to misuse API", -1));
Tcl_SetErrorCode(interp, "TCL", "OO", "MONKEY_BUSINESS", NULL);
return TCL_ERROR;
}
@@ -2026,7 +2081,8 @@ ClassMixinSet(
if (oPtr == NULL) {
return TCL_ERROR;
} else if (!oPtr->classPtr) {
- Tcl_AppendResult(interp, "attempt to misuse API", NULL);
+ Tcl_SetObjResult(interp, Tcl_NewStringObj(
+ "attempt to misuse API", -1));
Tcl_SetErrorCode(interp, "TCL", "OO", "MONKEY_BUSINESS", NULL);
return TCL_ERROR;
} else if (Tcl_ListObjGetElements(interp, objv[0], &mixinc,
@@ -2043,7 +2099,8 @@ ClassMixinSet(
goto freeAndError;
}
if (TclOOIsReachable(oPtr->classPtr, mixins[i])) {
- Tcl_AppendResult(interp, "may not mix a class into itself", NULL);
+ Tcl_SetObjResult(interp, Tcl_NewStringObj(
+ "may not mix a class into itself", -1));
Tcl_SetErrorCode(interp, "TCL", "OO", "SELF_MIXIN", NULL);
goto freeAndError;
}
@@ -2089,7 +2146,8 @@ ClassSuperGet(
if (oPtr == NULL) {
return TCL_ERROR;
} else if (!oPtr->classPtr) {
- Tcl_AppendResult(interp, "attempt to misuse API", NULL);
+ Tcl_SetObjResult(interp, Tcl_NewStringObj(
+ "attempt to misuse API", -1));
Tcl_SetErrorCode(interp, "TCL", "OO", "MONKEY_BUSINESS", NULL);
return TCL_ERROR;
}
@@ -2126,12 +2184,13 @@ ClassSuperSet(
if (oPtr == NULL) {
return TCL_ERROR;
} else if (!oPtr->classPtr) {
- Tcl_AppendResult(interp, "attempt to misuse API", NULL);
+ Tcl_SetObjResult(interp, Tcl_NewStringObj(
+ "attempt to misuse API", -1));
Tcl_SetErrorCode(interp, "TCL", "OO", "MONKEY_BUSINESS", NULL);
return TCL_ERROR;
} else if (oPtr == oPtr->fPtr->objectCls->thisPtr) {
- Tcl_AppendResult(interp,
- "may not modify the superclass of the root object", NULL);
+ Tcl_SetObjResult(interp, Tcl_NewStringObj(
+ "may not modify the superclass of the root object", -1));
Tcl_SetErrorCode(interp, "TCL", "OO", "MONKEY_BUSINESS", NULL);
return TCL_ERROR;
} else if (Tcl_ListObjGetElements(interp, objv[0], &superc,
@@ -2157,15 +2216,15 @@ ClassSuperSet(
}
for (j=0 ; j<i ; j++) {
if (superclasses[j] == superclasses[i]) {
- Tcl_AppendResult(interp,
- "class should only be a direct superclass once",NULL);
+ Tcl_SetObjResult(interp, Tcl_NewStringObj(
+ "class should only be a direct superclass once", -1));
Tcl_SetErrorCode(interp, "TCL", "OO", "REPETITIOUS", NULL);
goto failedAfterAlloc;
}
}
if (TclOOIsReachable(oPtr->classPtr, superclasses[i])) {
- Tcl_AppendResult(interp,
- "attempt to form circular dependency graph", NULL);
+ Tcl_SetObjResult(interp, Tcl_NewStringObj(
+ "attempt to form circular dependency graph", -1));
Tcl_SetErrorCode(interp, "TCL", "OO", "CIRCULARITY", NULL);
failedAfterAlloc:
ckfree((char *) superclasses);
@@ -2226,7 +2285,8 @@ ClassVarsGet(
if (oPtr == NULL) {
return TCL_ERROR;
} else if (!oPtr->classPtr) {
- Tcl_AppendResult(interp, "attempt to misuse API", NULL);
+ Tcl_SetObjResult(interp, Tcl_NewStringObj(
+ "attempt to misuse API", -1));
Tcl_SetErrorCode(interp, "TCL", "OO", "MONKEY_BUSINESS", NULL);
return TCL_ERROR;
}
@@ -2262,7 +2322,8 @@ ClassVarsSet(
if (oPtr == NULL) {
return TCL_ERROR;
} else if (!oPtr->classPtr) {
- Tcl_AppendResult(interp, "attempt to misuse API", NULL);
+ Tcl_SetObjResult(interp, Tcl_NewStringObj(
+ "attempt to misuse API", -1));
Tcl_SetErrorCode(interp, "TCL", "OO", "MONKEY_BUSINESS", NULL);
return TCL_ERROR;
} else if (Tcl_ListObjGetElements(interp, objv[0], &varc,
@@ -2274,15 +2335,16 @@ ClassVarsSet(
const char *varName = Tcl_GetString(varv[i]);
if (strstr(varName, "::") != NULL) {
- Tcl_AppendResult(interp, "invalid declared variable name \"",
- varName, "\": must not contain namespace separators",
- NULL);
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "invalid declared variable name \"%s\": must not %s",
+ varName, "contain namespace separators"));
Tcl_SetErrorCode(interp, "TCL", "OO", "BAD_DECLVAR", NULL);
return TCL_ERROR;
}
if (Tcl_StringMatch(varName, "*(*)")) {
- Tcl_AppendResult(interp, "invalid declared variable name \"",
- varName, "\": must not refer to an array element", NULL);
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "invalid declared variable name \"%s\": must not %s",
+ varName, "refer to an array element"));
Tcl_SetErrorCode(interp, "TCL", "OO", "BAD_DECLVAR", NULL);
return TCL_ERROR;
}
@@ -2552,15 +2614,16 @@ ObjVarsSet(
const char *varName = Tcl_GetString(varv[i]);
if (strstr(varName, "::") != NULL) {
- Tcl_AppendResult(interp, "invalid declared variable name \"",
- varName, "\": must not contain namespace separators",
- NULL);
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "invalid declared variable name \"%s\": must not %s",
+ varName, "contain namespace separators"));
Tcl_SetErrorCode(interp, "TCL", "OO", "BAD_DECLVAR", NULL);
return TCL_ERROR;
}
if (Tcl_StringMatch(varName, "*(*)")) {
- Tcl_AppendResult(interp, "invalid declared variable name \"",
- varName, "\": must not refer to an array element", NULL);
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "invalid declared variable name \"%s\": must not %s",
+ varName, "refer to an array element"));
Tcl_SetErrorCode(interp, "TCL", "OO", "BAD_DECLVAR", NULL);
return TCL_ERROR;
}
diff --git a/generic/tclOOInfo.c b/generic/tclOOInfo.c
index f298320..796442b 100644
--- a/generic/tclOOInfo.c
+++ b/generic/tclOOInfo.c
@@ -177,8 +177,8 @@ GetClassFromObj(
return NULL;
}
if (oPtr->classPtr == NULL) {
- Tcl_AppendResult(interp, "\"", TclGetString(objPtr),
- "\" is not a class", NULL);
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "\"%s\" is not a class", TclGetString(objPtr)));
Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "CLASS",
TclGetString(objPtr), NULL);
return NULL;
@@ -279,16 +279,16 @@ InfoObjectDefnCmd(
hPtr = Tcl_FindHashEntry(oPtr->methodsPtr, (char *) objv[2]);
if (hPtr == NULL) {
unknownMethod:
- Tcl_AppendResult(interp, "unknown method \"", TclGetString(objv[2]),
- "\"", NULL);
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "unknown method \"%s\"", TclGetString(objv[2])));
Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "METHOD",
TclGetString(objv[2]), NULL);
return TCL_ERROR;
}
procPtr = TclOOGetProcFromMethod(Tcl_GetHashValue(hPtr));
if (procPtr == NULL) {
- Tcl_AppendResult(interp,
- "definition not available for this kind of method", NULL);
+ Tcl_SetObjResult(interp, Tcl_NewStringObj(
+ "definition not available for this kind of method", -1));
Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "METHOD",
TclGetString(objv[2]), NULL);
return TCL_ERROR;
@@ -390,17 +390,17 @@ InfoObjectForwardCmd(
hPtr = Tcl_FindHashEntry(oPtr->methodsPtr, (char *) objv[2]);
if (hPtr == NULL) {
unknownMethod:
- Tcl_AppendResult(interp, "unknown method \"", TclGetString(objv[2]),
- "\"", NULL);
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "unknown method \"%s\"", TclGetString(objv[2])));
Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "METHOD",
TclGetString(objv[2]), NULL);
return TCL_ERROR;
}
prefixObj = TclOOGetFwdFromMethod(Tcl_GetHashValue(hPtr));
if (prefixObj == NULL) {
- Tcl_AppendResult(interp,
+ Tcl_SetObjResult(interp, Tcl_NewStringObj(
"prefix argument list not available for this kind of method",
- NULL);
+ -1));
Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "METHOD",
TclGetString(objv[2]), NULL);
return TCL_ERROR;
@@ -491,7 +491,8 @@ InfoObjectIsACmd(
return TCL_ERROR;
}
if (o2Ptr->classPtr == NULL) {
- Tcl_AppendResult(interp, "non-classes cannot be mixins", NULL);
+ Tcl_SetObjResult(interp, Tcl_NewStringObj(
+ "non-classes cannot be mixins", -1));
Tcl_SetErrorCode(interp, "TCL", "OO", "NONCLASS", NULL);
return TCL_ERROR;
} else {
@@ -516,7 +517,8 @@ InfoObjectIsACmd(
return TCL_ERROR;
}
if (o2Ptr->classPtr == NULL) {
- Tcl_AppendResult(interp, "non-classes cannot be types", NULL);
+ Tcl_SetObjResult(interp, Tcl_NewStringObj(
+ "non-classes cannot be types", -1));
Tcl_SetErrorCode(interp, "TCL", "OO", "NONCLASS", NULL);
return TCL_ERROR;
}
@@ -651,8 +653,8 @@ InfoObjectMethodTypeCmd(
hPtr = Tcl_FindHashEntry(oPtr->methodsPtr, (char *) objv[2]);
if (hPtr == NULL) {
unknownMethod:
- Tcl_AppendResult(interp, "unknown method \"", TclGetString(objv[2]),
- "\"", NULL);
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "unknown method \"%s\"", TclGetString(objv[2])));
Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "METHOD",
TclGetString(objv[2]), NULL);
return TCL_ERROR;
@@ -878,8 +880,8 @@ InfoClassConstrCmd(
}
procPtr = TclOOGetProcFromMethod(clsPtr->constructorPtr);
if (procPtr == NULL) {
- Tcl_AppendResult(interp,
- "definition not available for this kind of method", NULL);
+ Tcl_SetObjResult(interp, Tcl_NewStringObj(
+ "definition not available for this kind of method", -1));
Tcl_SetErrorCode(interp, "TCL", "OO", "METHOD_TYPE", NULL);
return TCL_ERROR;
}
@@ -937,16 +939,16 @@ InfoClassDefnCmd(
}
hPtr = Tcl_FindHashEntry(&clsPtr->classMethods, (char *) objv[2]);
if (hPtr == NULL) {
- Tcl_AppendResult(interp, "unknown method \"", TclGetString(objv[2]),
- "\"", NULL);
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "unknown method \"%s\"", TclGetString(objv[2])));
Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "METHOD",
TclGetString(objv[2]), NULL);
return TCL_ERROR;
}
procPtr = TclOOGetProcFromMethod(Tcl_GetHashValue(hPtr));
if (procPtr == NULL) {
- Tcl_AppendResult(interp,
- "definition not available for this kind of method", NULL);
+ Tcl_SetObjResult(interp, Tcl_NewStringObj(
+ "definition not available for this kind of method", -1));
Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "METHOD",
TclGetString(objv[2]), NULL);
return TCL_ERROR;
@@ -1006,8 +1008,8 @@ InfoClassDestrCmd(
}
procPtr = TclOOGetProcFromMethod(clsPtr->destructorPtr);
if (procPtr == NULL) {
- Tcl_AppendResult(interp,
- "definition not available for this kind of method", NULL);
+ Tcl_SetObjResult(interp, Tcl_NewStringObj(
+ "definition not available for this kind of method", -1));
Tcl_SetErrorCode(interp, "TCL", "OO", "METHOD_TYPE", NULL);
return TCL_ERROR;
}
@@ -1085,17 +1087,17 @@ InfoClassForwardCmd(
}
hPtr = Tcl_FindHashEntry(&clsPtr->classMethods, (char *) objv[2]);
if (hPtr == NULL) {
- Tcl_AppendResult(interp, "unknown method \"", TclGetString(objv[2]),
- "\"", NULL);
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "unknown method \"%s\"", TclGetString(objv[2])));
Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "METHOD",
TclGetString(objv[2]), NULL);
return TCL_ERROR;
}
prefixObj = TclOOGetFwdFromMethod(Tcl_GetHashValue(hPtr));
if (prefixObj == NULL) {
- Tcl_AppendResult(interp,
+ Tcl_SetObjResult(interp, Tcl_NewStringObj(
"prefix argument list not available for this kind of method",
- NULL);
+ -1));
Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "METHOD",
TclGetString(objv[2]), NULL);
return TCL_ERROR;
@@ -1269,8 +1271,8 @@ InfoClassMethodTypeCmd(
hPtr = Tcl_FindHashEntry(&clsPtr->classMethods, (char *) objv[2]);
if (hPtr == NULL) {
unknownMethod:
- Tcl_AppendResult(interp, "unknown method \"", TclGetString(objv[2]),
- "\"", NULL);
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "unknown method \"%s\"", TclGetString(objv[2])));
Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "METHOD",
TclGetString(objv[2]), NULL);
return TCL_ERROR;
@@ -1494,7 +1496,8 @@ InfoObjectCallCmd(
contextPtr = TclOOGetCallContext(oPtr, objv[2], PUBLIC_METHOD, NULL);
if (contextPtr == NULL) {
- Tcl_AppendResult(interp, "cannot construct any call chain", NULL);
+ Tcl_SetObjResult(interp, Tcl_NewStringObj(
+ "cannot construct any call chain", -1));
return TCL_ERROR;
}
Tcl_SetObjResult(interp,
@@ -1538,7 +1541,8 @@ InfoClassCallCmd(
callPtr = TclOOGetStereotypeCallChain(clsPtr, objv[2], PUBLIC_METHOD);
if (callPtr == NULL) {
- Tcl_AppendResult(interp, "cannot construct any call chain", NULL);
+ Tcl_SetObjResult(interp, Tcl_NewStringObj(
+ "cannot construct any call chain", -1));
return TCL_ERROR;
}
Tcl_SetObjResult(interp, TclOORenderCallChain(interp, callPtr));
diff --git a/generic/tclOOInt.h b/generic/tclOOInt.h
index 7988452..631961f 100644
--- a/generic/tclOOInt.h
+++ b/generic/tclOOInt.h
@@ -322,6 +322,7 @@ typedef struct Foundation {
* destructor. */
Tcl_Obj *clonedName; /* Shared object containing the name of a
* "<cloned>" pseudo-constructor. */
+ Tcl_Obj *defineName; /* Fully qualified name of oo::define. */
} Foundation;
/*
@@ -453,6 +454,9 @@ MODULE_SCOPE int TclOOSelfObjCmd(ClientData clientData,
* Method implementations (in tclOOBasic.c).
*/
+MODULE_SCOPE int TclOO_Class_Constructor(ClientData clientData,
+ Tcl_Interp *interp, Tcl_ObjectContext context,
+ int objc, Tcl_Obj *const *objv);
MODULE_SCOPE int TclOO_Class_Create(ClientData clientData,
Tcl_Interp *interp, Tcl_ObjectContext context,
int objc, Tcl_Obj *const *objv);
@@ -519,8 +523,6 @@ MODULE_SCOPE int TclNRObjectContextInvokeNext(Tcl_Interp *interp,
Tcl_Obj *const *objv, int skip);
MODULE_SCOPE void TclOONewBasicMethod(Tcl_Interp *interp, Class *clsPtr,
const DeclaredClassMethod *dcm);
-MODULE_SCOPE int TclOONRUpcatch(ClientData ignored, Tcl_Interp *interp,
- int objc, Tcl_Obj *const objv[]);
MODULE_SCOPE Tcl_Obj * TclOOObjectName(Tcl_Interp *interp, Object *oPtr);
MODULE_SCOPE void TclOORemoveFromInstances(Object *oPtr, Class *clsPtr);
MODULE_SCOPE void TclOORemoveFromMixinSubs(Class *subPtr,
@@ -532,9 +534,6 @@ MODULE_SCOPE Tcl_Obj * TclOORenderCallChain(Tcl_Interp *interp,
MODULE_SCOPE void TclOOStashContext(Tcl_Obj *objPtr,
CallContext *contextPtr);
MODULE_SCOPE void TclOOSetupVariableResolver(Tcl_Namespace *nsPtr);
-MODULE_SCOPE int TclOOUpcatchCmd(ClientData ignored,
- Tcl_Interp *interp, int objc,
- Tcl_Obj *const objv[]);
/*
* Include all the private API, generated from tclOO.decls.
diff --git a/generic/tclOOMethod.c b/generic/tclOOMethod.c
index 4e7edb8..60eaa6e 100644
--- a/generic/tclOOMethod.c
+++ b/generic/tclOOMethod.c
@@ -1204,15 +1204,6 @@ ConstructorErrorHandler(
const char *objectName, *kindName;
int objectNameLen;
- if (Tcl_GetErrorLine(interp) == (int) 0xDEADBEEF) {
- /*
- * Horrible hack to deal with certain constructors that must not add
- * information to the error trace.
- */
-
- return;
- }
-
if (mPtr->declaringObjectPtr != NULL) {
declarerPtr = mPtr->declaringObjectPtr;
kindName = "object";
@@ -1338,8 +1329,8 @@ TclOONewForwardInstanceMethod(
return NULL;
}
if (prefixLen < 1) {
- Tcl_AppendResult(interp, "method forward prefix must be non-empty",
- NULL);
+ Tcl_SetObjResult(interp, Tcl_NewStringObj(
+ "method forward prefix must be non-empty", -1));
Tcl_SetErrorCode(interp, "TCL", "OO", "BAD_FORWARD", NULL);
return NULL;
}
@@ -1380,8 +1371,8 @@ TclOONewForwardMethod(
return NULL;
}
if (prefixLen < 1) {
- Tcl_AppendResult(interp, "method forward prefix must be non-empty",
- NULL);
+ Tcl_SetObjResult(interp, Tcl_NewStringObj(
+ "method forward prefix must be non-empty", -1));
Tcl_SetErrorCode(interp, "TCL", "OO", "BAD_FORWARD", NULL);
return NULL;
}
diff --git a/generic/tclOOStubLib.c b/generic/tclOOStubLib.c
index 3b6ce37..55f2378 100644
--- a/generic/tclOOStubLib.c
+++ b/generic/tclOOStubLib.c
@@ -53,8 +53,9 @@ TclOOInitializeStubs(
if (clientData == NULL) {
Tcl_ResetResult(interp);
- Tcl_AppendResult(interp, "Error loading ", packageName, " package; ",
- "package not present or incomplete", NULL);
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "error loading %s package; package not present or incomplete",
+ packageName));
return NULL;
} else {
const TclOOStubs * const stubsPtr = clientData;
@@ -76,9 +77,9 @@ TclOOInitializeStubs(
error:
Tcl_ResetResult(interp);
- Tcl_AppendResult(interp, "Error loading ", packageName, " package",
- " (requested version '", version, "', loaded version '",
- actualVersion, "'): ", errMsg, NULL);
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf("Error loading %s package"
+ " (requested version '%s', loaded version '%s'): %s",
+ packageName, version, actualVersion, errMsg));
return NULL;
}
}
diff --git a/generic/tclObj.c b/generic/tclObj.c
index 099b67d..74cb29e 100644
--- a/generic/tclObj.c
+++ b/generic/tclObj.c
@@ -4462,11 +4462,8 @@ Tcl_RepresentationCmd(
int objc,
Tcl_Obj *const objv[])
{
- char refcountBuffer[TCL_INTEGER_SPACE+1];
- char objPtrBuffer[TCL_INTEGER_SPACE+3];
- char internalRepBuffer[2*(TCL_INTEGER_SPACE+2)+2];
-#define TCLOBJ_TRUNCATE_STRINGREP 16
- char stringRepBuffer[TCLOBJ_TRUNCATE_STRINGREP+1];
+ char ptrBuffer[2*TCL_INTEGER_SPACE+6];
+ Tcl_Obj *descObj;
if (objc != 2) {
Tcl_WrongNumArgs(interp, 1, objv, "value");
@@ -4479,27 +4476,30 @@ Tcl_RepresentationCmd(
* "1872361827361287"
*/
- sprintf(refcountBuffer, "%d", objv[1]->refCount);
- sprintf(objPtrBuffer, "%p", (void *)objv[1]);
- Tcl_AppendResult(interp, "value is a ", objv[1]->typePtr ?
- objv[1]->typePtr->name : "pure string", " with a refcount of ",
- refcountBuffer, ", object pointer at ", objPtrBuffer, NULL);
+ sprintf(ptrBuffer, "%p", (void *) objv[1]);
+ descObj = Tcl_ObjPrintf("value is a %s with a refcount of %d,"
+ " object pointer at %s",
+ objv[1]->typePtr ? objv[1]->typePtr->name : "pure string",
+ objv[1]->refCount, ptrBuffer);
+
if (objv[1]->typePtr) {
- sprintf(internalRepBuffer, "%p:%p",
- (void *)objv[1]->internalRep.twoPtrValue.ptr1,
- (void *)objv[1]->internalRep.twoPtrValue.ptr2);
- Tcl_AppendResult(interp, ", internal representation ",
- internalRepBuffer, NULL);
+ sprintf(ptrBuffer, "%p:%p",
+ (void *) objv[1]->internalRep.twoPtrValue.ptr1,
+ (void *) objv[1]->internalRep.twoPtrValue.ptr2);
+ Tcl_AppendPrintfToObj(descObj, ", internal representation %s",
+ ptrBuffer);
}
+
if (objv[1]->bytes) {
- strncpy(stringRepBuffer, objv[1]->bytes, TCLOBJ_TRUNCATE_STRINGREP);
- stringRepBuffer[TCLOBJ_TRUNCATE_STRINGREP] = 0;
- Tcl_AppendResult(interp, ", string representation \"",
- stringRepBuffer, objv[1]->length > TCLOBJ_TRUNCATE_STRINGREP ?
- "\"..." : "\".", NULL);
+ Tcl_AppendToObj(descObj, ", string representation \"", -1);
+ Tcl_AppendLimitedToObj(descObj, objv[1]->bytes, objv[1]->length,
+ 16, "...");
+ Tcl_AppendToObj(descObj, "\"", -1);
} else {
- Tcl_AppendResult(interp, ", no string representation.", NULL);
+ Tcl_AppendToObj(descObj, ", no string representation", -1);
}
+
+ Tcl_SetObjResult(interp, descObj);
return TCL_OK;
}
diff --git a/generic/tclPanic.c b/generic/tclPanic.c
index 84a9136..b87a8df 100644
--- a/generic/tclPanic.c
+++ b/generic/tclPanic.c
@@ -102,24 +102,23 @@ Tcl_PanicVA(
arg8);
fprintf(stderr, "\n");
fflush(stderr);
- }
- /* In case the users panic proc does not abort, we do it here */
#if defined(_WIN32) || defined(__CYGWIN__)
# if defined(__GNUC__)
- __builtin_trap();
+ __builtin_trap();
# elif defined(_WIN64)
- __debugbreak();
+ __debugbreak();
# elif defined(_MSC_VER)
- _asm {int 3}
+ _asm {int 3}
# else
- DebugBreak();
+ DebugBreak();
# endif
#endif
#if defined(_WIN32)
- ExitProcess(1);
+ ExitProcess(1);
#else
- abort();
+ abort();
#endif
+ }
}
/*
diff --git a/generic/tclParse.c b/generic/tclParse.c
index f0050c6..309e232 100644
--- a/generic/tclParse.c
+++ b/generic/tclParse.c
@@ -258,7 +258,8 @@ Tcl_ParseCommand(
if ((start == NULL) && (numBytes != 0)) {
if (interp != NULL) {
- Tcl_SetResult(interp, "can't parse a NULL pointer", TCL_STATIC);
+ Tcl_SetObjResult(interp, Tcl_NewStringObj(
+ "can't parse a NULL pointer", -1));
}
return TCL_ERROR;
}
@@ -568,14 +569,14 @@ Tcl_ParseCommand(
}
if (src[-1] == '"') {
if (interp != NULL) {
- Tcl_SetResult(interp, "extra characters after close-quote",
- TCL_STATIC);
+ Tcl_SetObjResult(interp, Tcl_NewStringObj(
+ "extra characters after close-quote", -1));
}
parsePtr->errorType = TCL_PARSE_QUOTE_EXTRA;
} else {
if (interp != NULL) {
- Tcl_SetResult(interp, "extra characters after close-brace",
- TCL_STATIC);
+ Tcl_SetObjResult(interp, Tcl_NewStringObj(
+ "extra characters after close-brace", -1));
}
parsePtr->errorType = TCL_PARSE_BRACE_EXTRA;
}
@@ -1175,8 +1176,8 @@ ParseTokens(
}
if (numBytes == 0) {
if (parsePtr->interp != NULL) {
- Tcl_SetResult(parsePtr->interp,
- "missing close-bracket", TCL_STATIC);
+ Tcl_SetObjResult(parsePtr->interp, Tcl_NewStringObj(
+ "missing close-bracket", -1));
}
parsePtr->errorType = TCL_PARSE_MISSING_BRACKET;
parsePtr->term = tokenPtr->start;
@@ -1411,8 +1412,8 @@ Tcl_ParseVarName(
}
if (numBytes == 0) {
if (parsePtr->interp != NULL) {
- Tcl_SetResult(parsePtr->interp,
- "missing close-brace for variable name", TCL_STATIC);
+ Tcl_SetObjResult(parsePtr->interp, Tcl_NewStringObj(
+ "missing close-brace for variable name", -1));
}
parsePtr->errorType = TCL_PARSE_MISSING_VAR_BRACE;
parsePtr->term = tokenPtr->start-1;
@@ -1479,8 +1480,8 @@ Tcl_ParseVarName(
}
if ((parsePtr->term == src+numBytes) || (*parsePtr->term != ')')){
if (parsePtr->interp != NULL) {
- Tcl_SetResult(parsePtr->interp, "missing )",
- TCL_STATIC);
+ Tcl_SetObjResult(parsePtr->interp, Tcl_NewStringObj(
+ "missing )", -1));
}
parsePtr->errorType = TCL_PARSE_MISSING_PAREN;
parsePtr->term = src;
@@ -1755,7 +1756,8 @@ Tcl_ParseBraces(
goto error;
}
- Tcl_SetResult(parsePtr->interp, "missing close-brace", TCL_STATIC);
+ Tcl_SetObjResult(parsePtr->interp, Tcl_NewStringObj(
+ "missing close-brace", -1));
/*
* Guess if the problem is due to comments by searching the source string
@@ -1777,8 +1779,8 @@ Tcl_ParseBraces(
break;
case '#' :
if (openBrace && TclIsSpaceProc(src[-1])) {
- Tcl_AppendResult(parsePtr->interp,
- ": possible unbalanced brace in comment", NULL);
+ Tcl_AppendToObj(Tcl_GetObjResult(parsePtr->interp),
+ ": possible unbalanced brace in comment", -1);
goto error;
}
break;
@@ -1857,7 +1859,8 @@ Tcl_ParseQuotedString(
}
if (*parsePtr->term != '"') {
if (parsePtr->interp != NULL) {
- Tcl_SetResult(parsePtr->interp, "missing \"", TCL_STATIC);
+ Tcl_SetObjResult(parsePtr->interp, Tcl_NewStringObj(
+ "missing \"", -1));
}
parsePtr->errorType = TCL_PARSE_MISSING_QUOTE;
parsePtr->term = start;
diff --git a/generic/tclPathObj.c b/generic/tclPathObj.c
index ba07808..db07c0e 100644
--- a/generic/tclPathObj.c
+++ b/generic/tclPathObj.c
@@ -27,6 +27,8 @@ static int SetFsPathFromAny(Tcl_Interp *interp, Tcl_Obj *pathPtr);
static int FindSplitPos(const char *path, int separator);
static int IsSeparatorOrNull(int ch);
static Tcl_Obj * GetExtension(Tcl_Obj *pathPtr);
+static int MakePathFromNormalized(Tcl_Interp *interp,
+ Tcl_Obj *pathPtr);
/*
* Define the 'path' object type, which Tcl uses to represent file paths
@@ -92,9 +94,7 @@ typedef struct FsPath {
* generated during the correct filesystem
* epoch. The epoch changes when
* filesystem-mounts are changed. */
- struct FilesystemRecord *fsRecPtr;
- /* Pointer to the filesystem record entry to
- * use for this path. */
+ const Tcl_Filesystem *fsPtr;/* The Tcl_Filesystem that claims this path */
} FsPath;
/*
@@ -152,14 +152,8 @@ typedef struct FsPath {
Tcl_Obj *
TclFSNormalizeAbsolutePath(
Tcl_Interp *interp, /* Interpreter to use */
- Tcl_Obj *pathPtr, /* Absolute path to normalize */
- ClientData *clientDataPtr) /* If non-NULL, then may be set to the
- * fs-specific clientData for this path. This
- * will happen when that extra information can
- * be calculated efficiently as a side-effect
- * of normalization. */
+ Tcl_Obj *pathPtr) /* Absolute path to normalize */
{
- ClientData clientData = NULL;
const char *dirSep, *oldDirSep;
int first = 1; /* Set to zero once we've passed the first
* directory separator - we can't use '..' to
@@ -433,17 +427,14 @@ TclFSNormalizeAbsolutePath(
* for normalizing a path.
*/
- TclFSNormalizeToUniquePath(interp, retVal, 0, &clientData);
+ TclFSNormalizeToUniquePath(interp, retVal, 0);
/*
* Since we know it is a normalized path, we can actually convert this
* object into an FsPath for greater efficiency
*/
- TclFSMakePathFromNormalized(interp, retVal, clientData);
- if (clientDataPtr != NULL) {
- *clientDataPtr = clientData;
- }
+ MakePathFromNormalized(interp, retVal);
/*
* This has a refCount of 1 for the caller, unlike many Tcl_Obj APIs.
@@ -575,8 +566,7 @@ TclPathPart(
if (pathPtr->typePtr == &tclFsPathType) {
FsPath *fsPathPtr = PATHOBJ(pathPtr);
- if (TclFSEpochOk(fsPathPtr->filesystemEpoch)
- && (PATHFLAGS(pathPtr) != 0)) {
+ if (PATHFLAGS(pathPtr) != 0) {
switch (portion) {
case TCL_PATH_DIRNAME: {
/*
@@ -1087,7 +1077,7 @@ TclJoinPath(
if (length > 0 && ptr[length -1] != '/') {
Tcl_AppendToObj(res, &separator, 1);
- length++;
+ Tcl_GetStringFromObj(res, &length);
}
Tcl_SetObjLength(res, length + (int) strlen(strElt));
@@ -1274,7 +1264,6 @@ TclNewFSPathObj(
{
FsPath *fsPathPtr;
Tcl_Obj *pathPtr;
- ThreadSpecificData *tsdPtr;
const char *p;
int state = 0, count = 0;
@@ -1302,8 +1291,6 @@ TclNewFSPathObj(
return pathPtr;
}
- tsdPtr = TCL_TSD_INIT(&tclFsDataKey);
-
pathPtr = Tcl_NewObj();
fsPathPtr = ckalloc(sizeof(FsPath));
@@ -1317,8 +1304,8 @@ TclNewFSPathObj(
fsPathPtr->cwdPtr = dirPtr;
Tcl_IncrRefCount(dirPtr);
fsPathPtr->nativePathPtr = NULL;
- fsPathPtr->fsRecPtr = NULL;
- fsPathPtr->filesystemEpoch = tsdPtr->filesystemEpoch;
+ fsPathPtr->fsPtr = NULL;
+ fsPathPtr->filesystemEpoch = 0;
SETPATHOBJ(pathPtr, fsPathPtr);
PATHFLAGS(pathPtr) = TCLPATH_APPENDED;
@@ -1428,8 +1415,7 @@ TclFSMakePathRelative(
if (pathPtr->typePtr == &tclFsPathType) {
FsPath *fsPathPtr = PATHOBJ(pathPtr);
- if (PATHFLAGS(pathPtr) != 0
- && fsPathPtr->cwdPtr == cwdPtr) {
+ if (PATHFLAGS(pathPtr) != 0 && fsPathPtr->cwdPtr == cwdPtr) {
return fsPathPtr->normPathPtr;
}
}
@@ -1473,7 +1459,7 @@ TclFSMakePathRelative(
/*
*---------------------------------------------------------------------------
*
- * TclFSMakePathFromNormalized --
+ * MakePathFromNormalized --
*
* Like SetFsPathFromAny, but assumes the given object is an absolute
* normalized path. Only for internal use.
@@ -1487,15 +1473,12 @@ TclFSMakePathRelative(
*---------------------------------------------------------------------------
*/
-int
-TclFSMakePathFromNormalized(
+static int
+MakePathFromNormalized(
Tcl_Interp *interp, /* Used for error reporting if not NULL. */
- Tcl_Obj *pathPtr, /* The object to convert. */
- ClientData nativeRep) /* The native rep for the object, if known
- * else NULL. */
+ Tcl_Obj *pathPtr) /* The object to convert. */
{
FsPath *fsPathPtr;
- ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&tclFsDataKey);
if (pathPtr->typePtr == &tclFsPathType) {
return TCL_OK;
@@ -1509,9 +1492,8 @@ TclFSMakePathFromNormalized(
if (pathPtr->bytes == NULL) {
if (pathPtr->typePtr->updateStringProc == NULL) {
if (interp != NULL) {
- Tcl_ResetResult(interp);
- Tcl_AppendResult(interp, "can't find object"
- "string representation", NULL);
+ Tcl_SetObjResult(interp, Tcl_NewStringObj(
+ "can't find object string representation", -1));
Tcl_SetErrorCode(interp, "TCL", "VALUE", "PATH", "WTF",
NULL);
}
@@ -1536,9 +1518,10 @@ TclFSMakePathFromNormalized(
fsPathPtr->normPathPtr = pathPtr;
fsPathPtr->cwdPtr = NULL;
- fsPathPtr->nativePathPtr = nativeRep;
- fsPathPtr->fsRecPtr = NULL;
- fsPathPtr->filesystemEpoch = tsdPtr->filesystemEpoch;
+ fsPathPtr->nativePathPtr = NULL;
+ fsPathPtr->fsPtr = NULL;
+ /* Remember the epoch under which we decided pathPtr was normalized */
+ fsPathPtr->filesystemEpoch = TclFSEpoch();
SETPATHOBJ(pathPtr, fsPathPtr);
PATHFLAGS(pathPtr) = 0;
@@ -1577,14 +1560,13 @@ Tcl_FSNewNativePath(
const Tcl_Filesystem *fromFilesystem,
ClientData clientData)
{
- Tcl_Obj *pathPtr;
+ Tcl_Obj *pathPtr = NULL;
FsPath *fsPathPtr;
- FilesystemRecord *fsFromPtr;
- ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&tclFsDataKey);
- pathPtr = TclFSInternalToNormalized(fromFilesystem, clientData,
- &fsFromPtr);
+ if (fromFilesystem->internalToNormalizedProc != NULL) {
+ pathPtr = (*fromFilesystem->internalToNormalizedProc)(clientData);
+ }
if (pathPtr == NULL) {
return NULL;
}
@@ -1615,9 +1597,8 @@ Tcl_FSNewNativePath(
fsPathPtr->normPathPtr = pathPtr;
fsPathPtr->cwdPtr = NULL;
fsPathPtr->nativePathPtr = clientData;
- fsPathPtr->fsRecPtr = fsFromPtr;
- fsPathPtr->fsRecPtr->fileRefCount++;
- fsPathPtr->filesystemEpoch = tsdPtr->filesystemEpoch;
+ fsPathPtr->fsPtr = fromFilesystem;
+ fsPathPtr->filesystemEpoch = TclFSEpoch();
SETPATHOBJ(pathPtr, fsPathPtr);
PATHFLAGS(pathPtr) = 0;
@@ -1675,6 +1656,12 @@ Tcl_FSGetTranslatedPath(
retObj = Tcl_FSJoinToPath(translatedCwdPtr, 1,
&srcFsPathPtr->normPathPtr);
srcFsPathPtr->translatedPathPtr = retObj;
+ if (translatedCwdPtr->typePtr == &tclFsPathType) {
+ srcFsPathPtr->filesystemEpoch
+ = PATHOBJ(translatedCwdPtr)->filesystemEpoch;
+ } else {
+ srcFsPathPtr->filesystemEpoch = 0;
+ }
Tcl_IncrRefCount(retObj);
Tcl_DecrRefCount(translatedCwdPtr);
} else {
@@ -1778,7 +1765,6 @@ Tcl_FSGetNormalizedPath(
Tcl_Obj *dir, *copy;
int cwdLen, pathType;
- ClientData clientData = NULL;
pathType = Tcl_FSGetPathType(fsPathPtr->cwdPtr);
dir = Tcl_FSGetNormalizedPath(interp, fsPathPtr->cwdPtr);
@@ -1811,7 +1797,7 @@ Tcl_FSGetNormalizedPath(
* 2385549] ...
*/
- Tcl_Obj *newCopy = TclFSNormalizeAbsolutePath(interp, copy, NULL);
+ Tcl_Obj *newCopy = TclFSNormalizeAbsolutePath(interp, copy);
Tcl_DecrRefCount(copy);
copy = newCopy;
@@ -1826,8 +1812,7 @@ Tcl_FSGetNormalizedPath(
* will actually start off directly after that separator.
*/
- TclFSNormalizeToUniquePath(interp, copy, cwdLen-1,
- (fsPathPtr->nativePathPtr == NULL ? &clientData : NULL));
+ TclFSNormalizeToUniquePath(interp, copy, cwdLen-1);
}
/* Now we need to construct the new path object. */
@@ -1870,15 +1855,6 @@ Tcl_FSGetNormalizedPath(
TclDecrRefCount(dir);
}
- if (clientData != NULL) {
- /*
- * This may be unnecessary. It appears that the
- * TclFSNormalizeToUniquePath call above should have already set
- * this up. Not changing out of fear of the unknown.
- */
-
- fsPathPtr->nativePathPtr = clientData;
- }
PATHFLAGS(pathPtr) = 0;
}
@@ -1899,7 +1875,6 @@ Tcl_FSGetNormalizedPath(
} else if (fsPathPtr->normPathPtr == NULL) {
int cwdLen;
Tcl_Obj *copy;
- ClientData clientData = NULL;
copy = AppendPath(fsPathPtr->cwdPtr, pathPtr);
@@ -1911,17 +1886,12 @@ Tcl_FSGetNormalizedPath(
* of the previously normalized 'dir'. This should be much faster!
*/
- TclFSNormalizeToUniquePath(interp, copy, cwdLen-1,
- (fsPathPtr->nativePathPtr == NULL ? &clientData : NULL));
+ TclFSNormalizeToUniquePath(interp, copy, cwdLen-1);
fsPathPtr->normPathPtr = copy;
Tcl_IncrRefCount(fsPathPtr->normPathPtr);
- if (clientData != NULL) {
- fsPathPtr->nativePathPtr = clientData;
- }
}
}
if (fsPathPtr->normPathPtr == NULL) {
- ClientData clientData = NULL;
Tcl_Obj *useThisCwd = NULL;
int pureNormalized = 1;
@@ -2003,12 +1973,7 @@ Tcl_FSGetNormalizedPath(
*/
fsPathPtr->normPathPtr = TclFSNormalizeAbsolutePath(interp,
- absolutePath,
- (fsPathPtr->nativePathPtr == NULL ? &clientData : NULL));
- if (0 && (clientData != NULL)) {
- fsPathPtr->nativePathPtr =
- fsPathPtr->fsRecPtr->fsPtr->dupInternalRepProc(clientData);
- }
+ absolutePath);
/*
* Check if path is pure normalized (this can only be the case if it
@@ -2099,7 +2064,7 @@ Tcl_FSGetInternalRep(
* not easily achievable with the current implementation.
*/
- if (srcFsPathPtr->fsRecPtr == NULL) {
+ if (srcFsPathPtr->fsPtr == NULL) {
/*
* This only usually happens in wrappers like TclpStat which create a
* string object and pass it to TclpObjStat. Code which calls the
@@ -2119,7 +2084,7 @@ Tcl_FSGetInternalRep(
*/
srcFsPathPtr = PATHOBJ(pathPtr);
- if (srcFsPathPtr->fsRecPtr == NULL) {
+ if (srcFsPathPtr->fsPtr == NULL) {
return NULL;
}
}
@@ -2131,7 +2096,7 @@ Tcl_FSGetInternalRep(
* for this is we ask what filesystem this path belongs to.
*/
- if (fsPtr != srcFsPathPtr->fsRecPtr->fsPtr) {
+ if (fsPtr != srcFsPathPtr->fsPtr) {
const Tcl_Filesystem *actualFs = Tcl_FSGetFileSystemForPath(pathPtr);
if (actualFs == fsPtr) {
@@ -2144,7 +2109,7 @@ Tcl_FSGetInternalRep(
Tcl_FSCreateInternalRepProc *proc;
char *nativePathPtr;
- proc = srcFsPathPtr->fsRecPtr->fsPtr->createInternalRepProc;
+ proc = srcFsPathPtr->fsPtr->createInternalRepProc;
if (proc == NULL) {
return NULL;
}
@@ -2212,8 +2177,8 @@ TclFSEnsureEpochOk(
* Check whether the object is already assigned to a fs.
*/
- if (srcFsPathPtr->fsRecPtr != NULL) {
- *fsPtrPtr = srcFsPathPtr->fsRecPtr->fsPtr;
+ if (srcFsPathPtr->fsPtr != NULL) {
+ *fsPtrPtr = srcFsPathPtr->fsPtr;
}
return TCL_OK;
}
@@ -2237,10 +2202,9 @@ TclFSEnsureEpochOk(
void
TclFSSetPathDetails(
Tcl_Obj *pathPtr,
- FilesystemRecord *fsRecPtr,
+ const Tcl_Filesystem *fsPtr,
ClientData clientData)
{
- ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&tclFsDataKey);
FsPath *srcFsPathPtr;
/*
@@ -2254,10 +2218,9 @@ TclFSSetPathDetails(
}
srcFsPathPtr = PATHOBJ(pathPtr);
- srcFsPathPtr->fsRecPtr = fsRecPtr;
+ srcFsPathPtr->fsPtr = fsPtr;
srcFsPathPtr->nativePathPtr = clientData;
- srcFsPathPtr->filesystemEpoch = tsdPtr->filesystemEpoch;
- fsRecPtr->fileRefCount++;
+ srcFsPathPtr->filesystemEpoch = TclFSEpoch();
}
/*
@@ -2346,7 +2309,6 @@ SetFsPathFromAny(
FsPath *fsPathPtr;
Tcl_Obj *transPtr;
char *name;
- ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&tclFsDataKey);
if (pathPtr->typePtr == &tclFsPathType) {
return TCL_OK;
@@ -2373,7 +2335,6 @@ SetFsPathFromAny(
*/
if (name[0] == '~') {
- char *expandedUser;
Tcl_DString temp;
int split;
char separator = '/';
@@ -2406,9 +2367,9 @@ SetFsPathFromAny(
dir = TclGetEnv("HOME", &dirString);
if (dir == NULL) {
if (interp) {
- Tcl_ResetResult(interp);
- Tcl_AppendResult(interp, "couldn't find HOME environment "
- "variable to expand path", NULL);
+ Tcl_SetObjResult(interp, Tcl_NewStringObj(
+ "couldn't find HOME environment variable to"
+ " expand path", -1));
Tcl_SetErrorCode(interp, "TCL", "VALUE", "PATH",
"HOMELESS", NULL);
}
@@ -2425,9 +2386,8 @@ SetFsPathFromAny(
Tcl_DStringInit(&temp);
if (TclpGetUserHome(name+1, &temp) == NULL) {
if (interp != NULL) {
- Tcl_ResetResult(interp);
- Tcl_AppendResult(interp, "user \"", name+1,
- "\" doesn't exist", NULL);
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "user \"%s\" doesn't exist", name+1));
Tcl_SetErrorCode(interp, "TCL", "VALUE", "PATH", "NOUSER",
NULL);
}
@@ -2442,8 +2402,7 @@ SetFsPathFromAny(
}
}
- expandedUser = Tcl_DStringValue(&temp);
- transPtr = Tcl_NewStringObj(expandedUser, Tcl_DStringLength(&temp));
+ transPtr = TclDStringToObj(&temp);
if (split != len) {
/*
@@ -2488,7 +2447,6 @@ SetFsPathFromAny(
transPtr = joined;
}
}
- Tcl_DStringFree(&temp);
} else {
transPtr = TclJoinPath(1, &pathPtr);
}
@@ -2503,12 +2461,15 @@ SetFsPathFromAny(
fsPathPtr->translatedPathPtr = transPtr;
if (transPtr != pathPtr) {
Tcl_IncrRefCount(fsPathPtr->translatedPathPtr);
+ /* Redo translation when $env(HOME) changes */
+ fsPathPtr->filesystemEpoch = TclFSEpoch();
+ } else {
+ fsPathPtr->filesystemEpoch = 0;
}
fsPathPtr->normPathPtr = NULL;
fsPathPtr->cwdPtr = NULL;
fsPathPtr->nativePathPtr = NULL;
- fsPathPtr->fsRecPtr = NULL;
- fsPathPtr->filesystemEpoch = tsdPtr->filesystemEpoch;
+ fsPathPtr->fsPtr = NULL;
/*
* Free old representation before installing our new one.
@@ -2541,25 +2502,15 @@ FreeFsPathInternalRep(
if (fsPathPtr->cwdPtr != NULL) {
TclDecrRefCount(fsPathPtr->cwdPtr);
}
- if (fsPathPtr->nativePathPtr != NULL && fsPathPtr->fsRecPtr != NULL) {
+ if (fsPathPtr->nativePathPtr != NULL && fsPathPtr->fsPtr != NULL) {
Tcl_FSFreeInternalRepProc *freeProc =
- fsPathPtr->fsRecPtr->fsPtr->freeInternalRepProc;
+ fsPathPtr->fsPtr->freeInternalRepProc;
if (freeProc != NULL) {
freeProc(fsPathPtr->nativePathPtr);
fsPathPtr->nativePathPtr = NULL;
}
}
- if (fsPathPtr->fsRecPtr != NULL) {
- fsPathPtr->fsRecPtr->fileRefCount--;
- if (fsPathPtr->fsRecPtr->fileRefCount <= 0) {
- /*
- * It has been unregistered already.
- */
-
- ckfree(fsPathPtr->fsRecPtr);
- }
- }
ckfree(fsPathPtr);
pathPtr->typePtr = NULL;
@@ -2602,10 +2553,10 @@ DupFsPathInternalRep(
copyFsPathPtr->flags = srcFsPathPtr->flags;
- if (srcFsPathPtr->fsRecPtr != NULL
+ if (srcFsPathPtr->fsPtr != NULL
&& srcFsPathPtr->nativePathPtr != NULL) {
Tcl_FSDupInternalRepProc *dupProc =
- srcFsPathPtr->fsRecPtr->fsPtr->dupInternalRepProc;
+ srcFsPathPtr->fsPtr->dupInternalRepProc;
if (dupProc != NULL) {
copyFsPathPtr->nativePathPtr =
@@ -2616,11 +2567,8 @@ DupFsPathInternalRep(
} else {
copyFsPathPtr->nativePathPtr = NULL;
}
- copyFsPathPtr->fsRecPtr = srcFsPathPtr->fsRecPtr;
+ copyFsPathPtr->fsPtr = srcFsPathPtr->fsPtr;
copyFsPathPtr->filesystemEpoch = srcFsPathPtr->filesystemEpoch;
- if (copyFsPathPtr->fsRecPtr != NULL) {
- copyFsPathPtr->fsRecPtr->fileRefCount++;
- }
copyPtr->typePtr = &tclFsPathType;
}
diff --git a/generic/tclPipe.c b/generic/tclPipe.c
index 5f59c38..83fb818 100644
--- a/generic/tclPipe.c
+++ b/generic/tclPipe.c
@@ -106,9 +106,10 @@ FileForRedirect(
if (msg) {
Tcl_SetObjResult(interp, msg);
} else {
- Tcl_AppendResult(interp, "channel \"",
- Tcl_GetChannelName(chan), "\" wasn't opened for ",
- ((writing) ? "writing" : "reading"), NULL);
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "channel \"%s\" wasn't opened for %s",
+ Tcl_GetChannelName(chan),
+ ((writing) ? "writing" : "reading")));
Tcl_SetErrorCode(interp, "TCL", "OPERATION", "EXEC",
"BADCHAN", NULL);
}
@@ -141,9 +142,10 @@ FileForRedirect(
file = TclpOpenFile(name, flags);
Tcl_DStringFree(&nameString);
if (file == NULL) {
- Tcl_AppendResult(interp, "couldn't ",
- ((writing) ? "write" : "read"), " file \"", spec, "\": ",
- Tcl_PosixError(interp), NULL);
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "couldn't %s file \"%s\": %s",
+ (writing ? "write" : "read"), spec,
+ Tcl_PosixError(interp)));
return NULL;
}
*closePtr = 1;
@@ -151,8 +153,8 @@ FileForRedirect(
return file;
badLastArg:
- Tcl_AppendResult(interp, "can't specify \"", arg,
- "\" as last word in command", NULL);
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "can't specify \"%s\" as last word in command", arg));
Tcl_SetErrorCode(interp, "TCL", "OPERATION", "EXEC", "SYNTAX", NULL);
return NULL;
}
@@ -284,7 +286,7 @@ TclCleanupChildren(
for (i = 0; i < numPids; i++) {
/*
* We need to get the resolved pid before we wait on it as the windows
- * implimentation of Tcl_WaitPid deletes the information such that any
+ * implementation of Tcl_WaitPid deletes the information such that any
* following calls to TclpGetPid fail.
*/
@@ -304,8 +306,8 @@ TclCleanupChildren(
msg =
"child process lost (is SIGCHLD ignored or trapped?)";
}
- Tcl_AppendResult(interp, "error waiting for process to exit: ",
- msg, NULL);
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "error waiting for process to exit: %s", msg));
}
continue;
}
@@ -335,16 +337,17 @@ TclCleanupChildren(
p = Tcl_SignalMsg(WTERMSIG(waitStatus));
Tcl_SetErrorCode(interp, "CHILDKILLED", msg1,
Tcl_SignalId(WTERMSIG(waitStatus)), p, NULL);
- Tcl_AppendResult(interp, "child killed: ", p, "\n", NULL);
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "child killed: %s\n", p));
} else if (WIFSTOPPED(waitStatus)) {
p = Tcl_SignalMsg(WSTOPSIG(waitStatus));
Tcl_SetErrorCode(interp, "CHILDSUSP", msg1,
Tcl_SignalId(WSTOPSIG(waitStatus)), p, NULL);
- Tcl_AppendResult(interp, "child suspended: ", p, "\n",
- NULL);
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "child suspended: %s\n", p));
} else {
- Tcl_AppendResult(interp,
- "child wait status didn't make sense\n", NULL);
+ Tcl_SetObjResult(interp, Tcl_NewStringObj(
+ "child wait status didn't make sense\n", -1));
Tcl_SetErrorCode(interp, "TCL", "OPERATION", "EXEC",
"ODDWAITRESULT", msg1, NULL);
}
@@ -374,8 +377,9 @@ TclCleanupChildren(
result = TCL_ERROR;
Tcl_DecrRefCount(objPtr);
Tcl_ResetResult(interp);
- Tcl_AppendResult(interp, "error reading stderr output file: ",
- Tcl_PosixError(interp), NULL);
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "error reading stderr output file: %s",
+ Tcl_PosixError(interp)));
} else if (count > 0) {
anyErrorInfo = 1;
Tcl_SetObjResult(interp, objPtr);
@@ -393,7 +397,8 @@ TclCleanupChildren(
*/
if ((abnormalExit != 0) && (anyErrorInfo == 0) && (interp != NULL)) {
- Tcl_AppendResult(interp, "child process exited abnormally", NULL);
+ Tcl_SetObjResult(interp, Tcl_NewStringObj(
+ "child process exited abnormally", -1));
}
return result;
}
@@ -542,8 +547,8 @@ TclCreatePipeline(
}
if (*p == '\0') {
if ((i == (lastBar + 1)) || (i == (argc - 1))) {
- Tcl_SetResult(interp, "illegal use of | or |& in command",
- TCL_STATIC);
+ Tcl_SetObjResult(interp, Tcl_NewStringObj(
+ "illegal use of | or |& in command", -1));
Tcl_SetErrorCode(interp, "TCL", "OPERATION", "EXEC",
"PIPESYNTAX", NULL);
goto error;
@@ -570,8 +575,9 @@ TclCreatePipeline(
if (*inputLiteral == '\0') {
inputLiteral = ((i + 1) == argc) ? NULL : argv[i + 1];
if (inputLiteral == NULL) {
- Tcl_AppendResult(interp, "can't specify \"", argv[i],
- "\" as last word in command", NULL);
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "can't specify \"%s\" as last word in command",
+ argv[i]));
Tcl_SetErrorCode(interp, "TCL", "OPERATION", "EXEC",
"PIPESYNTAX", NULL);
goto error;
@@ -680,8 +686,9 @@ TclCreatePipeline(
*/
if (i != argc-1) {
- Tcl_AppendResult(interp, "must specify \"", argv[i],
- "\" as last word in command", NULL);
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "must specify \"%s\" as last word in command",
+ argv[i]));
Tcl_SetErrorCode(interp, "TCL", "OPERATION", "EXEC",
"PIPESYNTAX", NULL);
goto error;
@@ -722,8 +729,8 @@ TclCreatePipeline(
* We had a bar followed only by redirections.
*/
- Tcl_SetResult(interp, "illegal use of | or |& in command",
- TCL_STATIC);
+ Tcl_SetObjResult(interp, Tcl_NewStringObj(
+ "illegal use of | or |& in command", -1));
Tcl_SetErrorCode(interp, "TCL", "OPERATION", "EXEC", "PIPESYNTAX",
NULL);
goto error;
@@ -739,9 +746,9 @@ TclCreatePipeline(
inputFile = TclpCreateTempFile(inputLiteral);
if (inputFile == NULL) {
- Tcl_AppendResult(interp,
- "couldn't create input file for command: ",
- Tcl_PosixError(interp), NULL);
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "couldn't create input file for command: %s",
+ Tcl_PosixError(interp)));
goto error;
}
inputClose = 1;
@@ -752,9 +759,9 @@ TclCreatePipeline(
*/
if (TclpCreatePipe(&inputFile, inPipePtr) == 0) {
- Tcl_AppendResult(interp,
- "couldn't create input pipe for command: ",
- Tcl_PosixError(interp), NULL);
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "couldn't create input pipe for command: %s",
+ Tcl_PosixError(interp)));
goto error;
}
inputClose = 1;
@@ -781,9 +788,9 @@ TclCreatePipeline(
*/
if (TclpCreatePipe(outPipePtr, &outputFile) == 0) {
- Tcl_AppendResult(interp,
- "couldn't create output pipe for command: ",
- Tcl_PosixError(interp), NULL);
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "couldn't create output pipe for command: %s",
+ Tcl_PosixError(interp)));
goto error;
}
outputClose = 1;
@@ -821,9 +828,9 @@ TclCreatePipeline(
errorFile = TclpCreateTempFile(NULL);
if (errorFile == NULL) {
- Tcl_AppendResult(interp,
- "couldn't create error file for command: ",
- Tcl_PosixError(interp), NULL);
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "couldn't create error file for command: %s",
+ Tcl_PosixError(interp)));
goto error;
}
*errFilePtr = errorFile;
@@ -894,8 +901,8 @@ TclCreatePipeline(
} else {
argv[lastArg] = NULL;
if (TclpCreatePipe(&pipeIn, &curOutFile) == 0) {
- Tcl_AppendResult(interp, "couldn't create pipe: ",
- Tcl_PosixError(interp), NULL);
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "couldn't create pipe: %s", Tcl_PosixError(interp)));
goto error;
}
}
@@ -1074,15 +1081,17 @@ Tcl_OpenCommandChannel(
if (flags & TCL_ENFORCE_MODE) {
if ((flags & TCL_STDOUT) && (outPipe == NULL)) {
- Tcl_AppendResult(interp, "can't read output from command:"
- " standard output was redirected", NULL);
+ Tcl_SetObjResult(interp, Tcl_NewStringObj(
+ "can't read output from command:"
+ " standard output was redirected", -1));
Tcl_SetErrorCode(interp, "TCL", "OPERATION", "EXEC",
"BADREDIRECT", NULL);
goto error;
}
if ((flags & TCL_STDIN) && (inPipe == NULL)) {
- Tcl_AppendResult(interp, "can't write input to command:"
- " standard input was redirected", NULL);
+ Tcl_SetObjResult(interp, Tcl_NewStringObj(
+ "can't write input to command:"
+ " standard input was redirected", -1));
Tcl_SetErrorCode(interp, "TCL", "OPERATION", "EXEC",
"BADREDIRECT", NULL);
goto error;
@@ -1093,8 +1102,8 @@ Tcl_OpenCommandChannel(
numPids, pidPtr);
if (channel == NULL) {
- Tcl_AppendResult(interp, "pipe for command could not be created",
- NULL);
+ Tcl_SetObjResult(interp, Tcl_NewStringObj(
+ "pipe for command could not be created", -1));
Tcl_SetErrorCode(interp, "TCL", "OPERATION", "EXEC", "NOPIPE", NULL);
goto error;
}
diff --git a/generic/tclPkg.c b/generic/tclPkg.c
index fdaea57..9b6e942 100644
--- a/generic/tclPkg.c
+++ b/generic/tclPkg.c
@@ -154,8 +154,9 @@ Tcl_PkgProvideEx(
}
return TCL_OK;
}
- Tcl_AppendResult(interp, "conflicting versions provided for package \"",
- name, "\": ", pkgPtr->version, ", then ", version, NULL);
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "conflicting versions provided for package \"%s\": %s, then %s",
+ name, pkgPtr->version, version));
Tcl_SetErrorCode(interp, "TCL", "PACKAGE", "VERSIONCONFLICT", NULL);
return TCL_ERROR;
}
@@ -284,9 +285,9 @@ Tcl_PkgRequireEx(
*/
tclEmptyStringRep = &tclEmptyString;
- Tcl_AppendResult(interp, "Cannot load package \"", name,
- "\" in standalone executable: This package is not "
- "compiled with stub support", NULL);
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "Cannot load package \"%s\" in standalone executable:"
+ " This package is not compiled with stub support", name));
Tcl_SetErrorCode(interp, "TCL", "PACKAGE", "UNSTUBBED", NULL);
return NULL;
}
@@ -374,9 +375,10 @@ PkgRequireCore(
*/
if (pkgPtr->clientData != NULL) {
- Tcl_AppendResult(interp, "circular package dependency: "
- "attempt to provide ", name, " ",
- (char *) pkgPtr->clientData, " requires ", name, NULL);
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "circular package dependency:"
+ " attempt to provide %s %s requires %s",
+ name, (char *) pkgPtr->clientData, name));
AddRequirementsToResult(interp, reqc, reqv);
Tcl_SetErrorCode(interp, "TCL", "PACKAGE", "CIRCULARITY", NULL);
return NULL;
@@ -494,10 +496,10 @@ PkgRequireCore(
Tcl_ResetResult(interp);
if (pkgPtr->version == NULL) {
code = TCL_ERROR;
- Tcl_AppendResult(interp, "attempt to provide package ",
- name, " ", versionToProvide,
- " failed: no version of package ", name,
- " provided", NULL);
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "attempt to provide package %s %s failed:"
+ " no version of package %s provided",
+ name, versionToProvide, name));
Tcl_SetErrorCode(interp, "TCL", "PACKAGE", "UNPROVIDED",
NULL);
} else {
@@ -517,11 +519,11 @@ PkgRequireCore(
ckfree(vi);
if (res != 0) {
code = TCL_ERROR;
- Tcl_AppendResult(interp,
- "attempt to provide package ", name, " ",
- versionToProvide, " failed: package ",
- name, " ", pkgPtr->version,
- " provided instead", NULL);
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "attempt to provide package %s %s failed:"
+ " package %s %s provided instead",
+ name, versionToProvide,
+ name, pkgPtr->version));
Tcl_SetErrorCode(interp, "TCL", "PACKAGE",
"WRONGPROVIDE", NULL);
}
@@ -530,10 +532,10 @@ PkgRequireCore(
} else if (code != TCL_ERROR) {
Tcl_Obj *codePtr = Tcl_NewIntObj(code);
- Tcl_ResetResult(interp);
- Tcl_AppendResult(interp, "attempt to provide package ", name,
- " ", versionToProvide, " failed: bad return code: ",
- TclGetString(codePtr), NULL);
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "attempt to provide package %s %s failed:"
+ " bad return code: %s",
+ name, versionToProvide, TclGetString(codePtr)));
Tcl_SetErrorCode(interp, "TCL", "PACKAGE", "BADRESULT", NULL);
TclDecrRefCount(codePtr);
code = TCL_ERROR;
@@ -591,13 +593,9 @@ PkgRequireCore(
Tcl_DStringFree(&command);
if ((code != TCL_OK) && (code != TCL_ERROR)) {
- Tcl_Obj *codePtr = Tcl_NewIntObj(code);
-
- Tcl_ResetResult(interp);
- Tcl_AppendResult(interp, "bad return code: ",
- TclGetString(codePtr), NULL);
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "bad return code: %d", code));
Tcl_SetErrorCode(interp, "TCL", "PACKAGE", "BADRESULT", NULL);
- Tcl_DecrRefCount(codePtr);
code = TCL_ERROR;
}
if (code == TCL_ERROR) {
@@ -610,7 +608,8 @@ PkgRequireCore(
}
if (pkgPtr->version == NULL) {
- Tcl_AppendResult(interp, "can't find package ", name, NULL);
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "can't find package %s", name));
Tcl_SetErrorCode(interp, "TCL", "PACKAGE", "UNFOUND", NULL);
AddRequirementsToResult(interp, reqc, reqv);
return NULL;
@@ -628,8 +627,9 @@ PkgRequireCore(
ckfree(pkgVersionI);
if (!satisfies) {
- Tcl_AppendResult(interp, "version conflict for package \"", name,
- "\": have ", pkgPtr->version, ", need", NULL);
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "version conflict for package \"%s\": have %s, need",
+ name, pkgPtr->version));
Tcl_SetErrorCode(interp, "TCL", "PACKAGE", "VERSIONCONFLICT",
NULL);
AddRequirementsToResult(interp, reqc, reqv);
@@ -721,10 +721,11 @@ Tcl_PkgPresentEx(
}
if (version != NULL) {
- Tcl_AppendResult(interp, "package ", name, " ", version,
- " is not present", NULL);
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "package %s %s is not present", name, version));
} else {
- Tcl_AppendResult(interp, "package ", name, " is not present", NULL);
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "package %s is not present", name));
}
Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "PACKAGE", name, NULL);
return NULL;
@@ -850,7 +851,8 @@ Tcl_PackageObjCmd(
if (res == 0){
if (objc == 4) {
ckfree(argv3i);
- Tcl_SetResult(interp, availPtr->script, TCL_VOLATILE);
+ Tcl_SetObjResult(interp,
+ Tcl_NewStringObj(availPtr->script, -1));
return TCL_OK;
}
Tcl_EventuallyFree(availPtr->script, TCL_DYNAMIC);
@@ -955,7 +957,8 @@ Tcl_PackageObjCmd(
if (hPtr != NULL) {
pkgPtr = Tcl_GetHashValue(hPtr);
if (pkgPtr->version != NULL) {
- Tcl_SetResult(interp, pkgPtr->version, TCL_VOLATILE);
+ Tcl_SetObjResult(interp,
+ Tcl_NewStringObj(pkgPtr->version, -1));
}
}
return TCL_OK;
@@ -1017,7 +1020,8 @@ Tcl_PackageObjCmd(
if (objc == 2) {
if (iPtr->packageUnknown != NULL) {
- Tcl_SetResult(interp, iPtr->packageUnknown, TCL_VOLATILE);
+ Tcl_SetObjResult(interp,
+ Tcl_NewStringObj(iPtr->packageUnknown, -1));
}
} else if (objc == 3) {
if (iPtr->packageUnknown != NULL) {
@@ -1351,8 +1355,8 @@ CheckVersionAndConvert(
error:
ckfree(ibuf);
- Tcl_AppendResult(interp, "expected version number but got \"", string,
- "\"", NULL);
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "expected version number but got \"%s\"", string));
Tcl_SetErrorCode(interp, "TCL", "VALUE", "VERSION", NULL);
return TCL_ERROR;
}
@@ -1614,8 +1618,8 @@ CheckRequirement(
* More dashes found after the first. This is wrong.
*/
- Tcl_AppendResult(interp, "expected versionMin-versionMax but got \"",
- string, "\"", NULL);
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "expected versionMin-versionMax but got \"%s\"", string));
Tcl_SetErrorCode(interp, "TCL", "VALUE", "VERSIONRANGE", NULL);
return TCL_ERROR;
}
@@ -1667,19 +1671,17 @@ AddRequirementsToResult(
Tcl_Obj *const reqv[]) /* 0 means to use the latest version
* available. */
{
- if (reqc > 0) {
- int i;
+ Tcl_Obj *result = Tcl_GetObjResult(interp);
+ int i, length;
- for (i = 0; i < reqc; i++) {
- int length;
- const char *v = Tcl_GetStringFromObj(reqv[i], &length);
+ for (i = 0; i < reqc; i++) {
+ const char *v = Tcl_GetStringFromObj(reqv[i], &length);
- if ((length & 0x1) && (v[length/2] == '-')
- && (strncmp(v, v+((length+1)/2), length/2) == 0)) {
- Tcl_AppendResult(interp, " exactly ", v+((length+1)/2), NULL);
- } else {
- Tcl_AppendResult(interp, " ", v, NULL);
- }
+ if ((length & 0x1) && (v[length/2] == '-')
+ && (strncmp(v, v+((length+1)/2), length/2) == 0)) {
+ Tcl_AppendPrintfToObj(result, " exactly %s", v+((length+1)/2));
+ } else {
+ Tcl_AppendPrintfToObj(result, " %s", v);
}
}
}
@@ -1708,15 +1710,15 @@ AddRequirementsToDString(
Tcl_Obj *const reqv[]) /* 0 means to use the latest version
* available. */
{
- if (reqc > 0) {
- int i;
+ int i;
+ if (reqc > 0) {
for (i = 0; i < reqc; i++) {
- Tcl_DStringAppend(dsPtr, " ", 1);
- Tcl_DStringAppend(dsPtr, TclGetString(reqv[i]), -1);
+ TclDStringAppendLiteral(dsPtr, " ");
+ TclDStringAppendObj(dsPtr, reqv[i]);
}
} else {
- Tcl_DStringAppend(dsPtr, " 0-", -1);
+ TclDStringAppendLiteral(dsPtr, " 0-");
}
}
diff --git a/generic/tclPlatDecls.h b/generic/tclPlatDecls.h
index 37f5479..48ad390 100644
--- a/generic/tclPlatDecls.h
+++ b/generic/tclPlatDecls.h
@@ -31,7 +31,7 @@
* TCHAR is needed here for win32, so if it is not defined yet do it here.
* This way, we don't need to include <tchar.h> just for one define.
*/
-#if defined(_WIN32) && !defined(_TCHAR_DEFINED)
+#if (defined(_WIN32) || defined(__CYGWIN__)) && !defined(_TCHAR_DEFINED)
# if defined(_UNICODE)
typedef wchar_t TCHAR;
# else
@@ -46,19 +46,7 @@
* Exported function declarations:
*/
-#if !defined(__WIN32__) && !defined(MAC_OSX_TCL) /* UNIX */
-/* 0 */
-EXTERN int Tcl_MacOSXOpenBundleResources(Tcl_Interp *interp,
- const char *bundleName, int hasResourceFile,
- int maxPathLen, char *libraryPath);
-/* 1 */
-EXTERN int Tcl_MacOSXOpenVersionedBundleResources(
- Tcl_Interp *interp, const char *bundleName,
- const char *bundleVersion,
- int hasResourceFile, int maxPathLen,
- char *libraryPath);
-#endif /* UNIX */
-#ifdef __WIN32__ /* WIN */
+#if defined(__WIN32__) || defined(__CYGWIN__) /* WIN */
/* 0 */
EXTERN TCHAR * Tcl_WinUtfToTChar(const char *str, int len,
Tcl_DString *dsPtr);
@@ -83,11 +71,7 @@ typedef struct TclPlatStubs {
int magic;
const struct TclPlatStubHooks *hooks;
-#if !defined(__WIN32__) && !defined(MAC_OSX_TCL) /* UNIX */
- int (*tcl_MacOSXOpenBundleResources) (Tcl_Interp *interp, const char *bundleName, int hasResourceFile, int maxPathLen, char *libraryPath); /* 0 */
- int (*tcl_MacOSXOpenVersionedBundleResources) (Tcl_Interp *interp, const char *bundleName, const char *bundleVersion, int hasResourceFile, int maxPathLen, char *libraryPath); /* 1 */
-#endif /* UNIX */
-#ifdef __WIN32__ /* WIN */
+#if defined(__WIN32__) || defined(__CYGWIN__) /* WIN */
TCHAR * (*tcl_WinUtfToTChar) (const char *str, int len, Tcl_DString *dsPtr); /* 0 */
char * (*tcl_WinTCharToUtf) (const TCHAR *str, int len, Tcl_DString *dsPtr); /* 1 */
#endif /* WIN */
@@ -111,13 +95,7 @@ extern const TclPlatStubs *tclPlatStubsPtr;
* Inline function declarations:
*/
-#if !defined(__WIN32__) && !defined(MAC_OSX_TCL) /* UNIX */
-#define Tcl_MacOSXOpenBundleResources \
- (tclPlatStubsPtr->tcl_MacOSXOpenBundleResources) /* 0 */
-#define Tcl_MacOSXOpenVersionedBundleResources \
- (tclPlatStubsPtr->tcl_MacOSXOpenVersionedBundleResources) /* 1 */
-#endif /* UNIX */
-#ifdef __WIN32__ /* WIN */
+#if defined(__WIN32__) || defined(__CYGWIN__) /* WIN */
#define Tcl_WinUtfToTChar \
(tclPlatStubsPtr->tcl_WinUtfToTChar) /* 0 */
#define Tcl_WinTCharToUtf \
diff --git a/generic/tclPort.h b/generic/tclPort.h
index 79bea88..7021b8d 100644
--- a/generic/tclPort.h
+++ b/generic/tclPort.h
@@ -25,19 +25,6 @@
# include "tclUnixPort.h"
#endif
-#if defined(__CYGWIN__)
-# define USE_PUTENV 1
-# define USE_PUTENV_FOR_UNSET 1
-/* On Cygwin, the environment is imported from the Cygwin DLL. */
-# define environ __cygwin_environ
-# define timezone _timezone
- DLLIMPORT extern char **__cygwin_environ;
- DLLIMPORT extern int cygwin_conv_to_win32_path(const char *, char *);
- DLLIMPORT extern int cygwin_posix_to_win32_path_list_buf_size(char *value);
- DLLIMPORT extern void cygwin_posix_to_win32_path_list(char *buf, char *value);
- DLLIMPORT extern void __stdcall SetEnvironmentVariableA(const char*, const char *);
-#endif
-
#if !defined(LLONG_MIN)
# ifdef TCL_WIDE_INT_IS_LONG
# define LLONG_MIN LONG_MIN
diff --git a/generic/tclProc.c b/generic/tclProc.c
index d008217..933e7d2 100644
--- a/generic/tclProc.c
+++ b/generic/tclProc.c
@@ -152,22 +152,24 @@ Tcl_ProcObjCmd(
&nsPtr, &altNsPtr, &cxtNsPtr, &procName);
if (nsPtr == NULL) {
- Tcl_AppendResult(interp, "can't create procedure \"", fullName,
- "\": unknown namespace", NULL);
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "can't create procedure \"%s\": unknown namespace",
+ fullName));
Tcl_SetErrorCode(interp, "TCL", "VALUE", "COMMAND", NULL);
return TCL_ERROR;
}
if (procName == NULL) {
- Tcl_AppendResult(interp, "can't create procedure \"", fullName,
- "\": bad procedure name", 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_AppendResult(interp, "can't create procedure \"", procName,
- "\" in non-global namespace with name starting with \":\"",
- NULL);
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "can't create procedure \"%s\" in non-global namespace with"
+ " name starting with \":\"", procName));
Tcl_SetErrorCode(interp, "TCL", "VALUE", "COMMAND", NULL);
return TCL_ERROR;
}
@@ -194,7 +196,7 @@ Tcl_ProcObjCmd(
Tcl_DStringInit(&ds);
if (nsPtr != iPtr->globalNsPtr) {
Tcl_DStringAppend(&ds, nsPtr->fullName, -1);
- Tcl_DStringAppend(&ds, "::", 2);
+ TclDStringAppendLiteral(&ds, "::");
}
Tcl_DStringAppend(&ds, procName, -1);
@@ -518,16 +520,17 @@ TclCreateProc(
}
if (fieldCount > 2) {
ckfree(fieldValues);
- Tcl_AppendResult(interp,
- "too many fields in argument specifier \"",
- argArray[i], "\"", NULL);
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "too many fields in argument specifier \"%s\"",
+ argArray[i]));
Tcl_SetErrorCode(interp, "TCL", "OPERATION", "PROC",
"FORMALARGUMENTFORMAT", NULL);
goto procError;
}
if ((fieldCount == 0) || (*fieldValues[0] == 0)) {
ckfree(fieldValues);
- Tcl_AppendResult(interp, "argument with no name", NULL);
+ Tcl_SetObjResult(interp, Tcl_NewStringObj(
+ "argument with no name", -1));
Tcl_SetErrorCode(interp, "TCL", "OPERATION", "PROC",
"FORMALARGUMENTFORMAT", NULL);
goto procError;
@@ -553,16 +556,18 @@ TclCreateProc(
} while (*q != '\0');
q--;
if (*q == ')') { /* We have an array element. */
- Tcl_AppendResult(interp, "formal parameter \"",
- fieldValues[0], "\" is an array element", NULL);
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "formal parameter \"%s\" is an array element",
+ fieldValues[0]));
ckfree(fieldValues);
Tcl_SetErrorCode(interp, "TCL", "OPERATION", "PROC",
"FORMALARGUMENTFORMAT", NULL);
goto procError;
}
} else if ((*p == ':') && (*(p+1) == ':')) {
- Tcl_AppendResult(interp, "formal parameter \"",
- fieldValues[0], "\" is not a simple name", NULL);
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "formal parameter \"%s\" is not a simple name",
+ fieldValues[0]));
ckfree(fieldValues);
Tcl_SetErrorCode(interp, "TCL", "OPERATION", "PROC",
"FORMALARGUMENTFORMAT", NULL);
@@ -767,8 +772,7 @@ TclGetFrame(
return result;
levelError:
- Tcl_ResetResult(interp);
- Tcl_AppendResult(interp, "bad level \"", name, "\"", NULL);
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf("bad level \"%s\"", name));
Tcl_SetErrorCode(interp, "TCL", "VALUE", "STACKLEVEL", NULL);
return -1;
}
@@ -900,8 +904,7 @@ TclObjGetFrame(
return result;
levelError:
- Tcl_ResetResult(interp);
- Tcl_AppendResult(interp, "bad level \"", name, "\"", NULL);
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf("bad level \"%s\"", name));
Tcl_SetErrorCode(interp, "TCL", "VALUE", "STACKLEVEL", NULL);
return -1;
}
@@ -1879,10 +1882,9 @@ InterpProcNR2(
* transform to an error now.
*/
- Tcl_ResetResult(interp);
- Tcl_AppendResult(interp, "invoked \"",
- ((result == TCL_BREAK) ? "break" : "continue"),
- "\" outside of a loop", NULL);
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "invoked \"%s\" outside of a loop",
+ ((result == TCL_BREAK) ? "break" : "continue")));
Tcl_SetErrorCode(interp, "TCL", "RESULT", "UNEXPECTED", NULL);
result = TCL_ERROR;
@@ -1999,8 +2001,8 @@ TclProcCompileProc(
if (codePtr->flags & TCL_BYTECODE_PRECOMPILED) {
if ((Interp *) *codePtr->interpHandle != iPtr) {
- Tcl_AppendResult(interp,
- "a precompiled script jumped interps", NULL);
+ Tcl_SetObjResult(interp, Tcl_NewStringObj(
+ "a precompiled script jumped interps", -1));
Tcl_SetErrorCode(interp, "TCL", "OPERATION", "PROC",
"CROSSINTERPBYTECODE", NULL);
return TCL_ERROR;
@@ -2234,7 +2236,7 @@ TclProcCleanupProc(
* procbody structures created by tbcload.
*/
- if (!iPtr) {
+ if (iPtr == NULL) {
return;
}
@@ -2245,13 +2247,15 @@ TclProcCleanupProc(
cfPtr = Tcl_GetHashValue(hePtr);
- if (cfPtr->type == TCL_LOCATION_SOURCE) {
- Tcl_DecrRefCount(cfPtr->data.eval.path);
- cfPtr->data.eval.path = NULL;
+ if (cfPtr) {
+ if (cfPtr->type == TCL_LOCATION_SOURCE) {
+ Tcl_DecrRefCount(cfPtr->data.eval.path);
+ cfPtr->data.eval.path = NULL;
+ }
+ ckfree(cfPtr->line);
+ cfPtr->line = NULL;
+ ckfree(cfPtr);
}
- ckfree(cfPtr->line);
- cfPtr->line = NULL;
- ckfree(cfPtr);
Tcl_DeleteHashEntry(hePtr);
}
@@ -2483,7 +2487,8 @@ SetLambdaFromAny(
Interp *iPtr = (Interp *) interp;
const char *name;
Tcl_Obj *argsPtr, *bodyPtr, *nsObjPtr, **objv;
- int objc, result;
+ int isNew, objc, result;
+ CmdFrame *cfPtr = NULL;
Proc *procPtr;
if (interp == NULL) {
@@ -2578,14 +2583,14 @@ SetLambdaFromAny(
if (contextPtr->line
&& (contextPtr->nline >= 2) && (contextPtr->line[1] >= 0)) {
- int isNew, buf[2];
- CmdFrame *cfPtr = ckalloc(sizeof(CmdFrame));
+ int buf[2];
/*
* Move from approximation (line of list cmd word) to actual
* location (line of 2nd list element).
*/
+ cfPtr = ckalloc(sizeof(CmdFrame));
TclListLines(objPtr, contextPtr->line[1], 2, buf, NULL);
cfPtr->level = -1;
@@ -2601,9 +2606,6 @@ SetLambdaFromAny(
cfPtr->cmd.str.cmd = NULL;
cfPtr->cmd.str.len = 0;
-
- Tcl_SetHashValue(Tcl_CreateHashEntry(iPtr->linePBodyPtr,
- procPtr, &isNew), cfPtr);
}
/*
@@ -2615,6 +2617,8 @@ SetLambdaFromAny(
}
TclStackFree(interp, contextPtr);
}
+ Tcl_SetHashValue(Tcl_CreateHashEntry(iPtr->linePBodyPtr, procPtr,
+ &isNew), cfPtr);
/*
* Set the namespace for this lambda: given by objv[2] understood as a
@@ -2930,8 +2934,8 @@ Tcl_DisassembleObjCmd(
procPtr = TclFindProc((Interp *) interp, TclGetString(objv[2]));
if (procPtr == NULL) {
- Tcl_AppendResult(interp, "\"", TclGetString(objv[2]),
- "\" isn't a procedure", NULL);
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "\"%s\" isn't a procedure", TclGetString(objv[2])));
Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "PROC",
TclGetString(objv[2]), NULL);
return TCL_ERROR;
@@ -2980,8 +2984,8 @@ Tcl_DisassembleObjCmd(
return TCL_ERROR;
}
if (oPtr->classPtr == NULL) {
- Tcl_AppendResult(interp, "\"", TclGetString(objv[2]),
- "\" is not a class", NULL);
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "\"%s\" is not a class", TclGetString(objv[2])));
Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "CLASS",
TclGetString(objv[2]), NULL);
return TCL_ERROR;
@@ -3015,16 +3019,16 @@ Tcl_DisassembleObjCmd(
methodBody:
if (hPtr == NULL) {
unknownMethod:
- Tcl_AppendResult(interp, "unknown method \"",
- TclGetString(objv[3]), "\"", NULL);
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "unknown method \"%s\"", TclGetString(objv[3])));
Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "METHOD",
TclGetString(objv[3]), NULL);
return TCL_ERROR;
}
procPtr = TclOOGetProcFromMethod(Tcl_GetHashValue(hPtr));
if (procPtr == NULL) {
- Tcl_AppendResult(interp,
- "body not available for this kind of method", NULL);
+ Tcl_SetObjResult(interp, Tcl_NewStringObj(
+ "body not available for this kind of method", -1));
Tcl_SetErrorCode(interp, "TCL", "OPERATION", "DISASSEMBLE",
"METHODTYPE", NULL);
return TCL_ERROR;
@@ -3059,7 +3063,8 @@ Tcl_DisassembleObjCmd(
if (((ByteCode *) codeObjPtr->internalRep.otherValuePtr)->flags
& TCL_BYTECODE_PRECOMPILED) {
- Tcl_AppendResult(interp,"may not disassemble prebuilt bytecode",NULL);
+ Tcl_SetObjResult(interp, Tcl_NewStringObj(
+ "may not disassemble prebuilt bytecode", -1));
Tcl_SetErrorCode(interp, "TCL", "OPERATION", "DISASSEMBLE",
"BYTECODE", NULL);
return TCL_ERROR;
diff --git a/generic/tclRegexp.c b/generic/tclRegexp.c
index 5c5af7b..6c1dc08 100644
--- a/generic/tclRegexp.c
+++ b/generic/tclRegexp.c
@@ -714,14 +714,14 @@ TclRegError(
int status) /* Status code to report. */
{
char buf[100]; /* ample in practice */
- char cbuf[100]; /* lots in practice */
+ char cbuf[TCL_INTEGER_SPACE];
size_t n;
const char *p;
Tcl_ResetResult(interp);
n = TclReError(status, NULL, buf, sizeof(buf));
p = (n > sizeof(buf)) ? "..." : "";
- Tcl_AppendResult(interp, msg, buf, p, NULL);
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf("%s%s%s", msg, buf, p));
sprintf(cbuf, "%d", status);
(void) TclReError(REG_ITOA, NULL, cbuf, sizeof(cbuf));
@@ -947,10 +947,8 @@ CompileRegexp(
*/
if (TclReToGlob(NULL, string, length, &stringBuf, &exact) == TCL_OK) {
- regexpPtr->globObjPtr = Tcl_NewStringObj(Tcl_DStringValue(&stringBuf),
- Tcl_DStringLength(&stringBuf));
+ regexpPtr->globObjPtr = TclDStringToObj(&stringBuf);
Tcl_IncrRefCount(regexpPtr->globObjPtr);
- Tcl_DStringFree(&stringBuf);
} else {
regexpPtr->globObjPtr = NULL;
}
diff --git a/generic/tclResult.c b/generic/tclResult.c
index 4443cc1..17aac74 100644
--- a/generic/tclResult.c
+++ b/generic/tclResult.c
@@ -1390,10 +1390,9 @@ TclMergeReturnOptions(
* Value is not a legal dictionary.
*/
- Tcl_ResetResult(interp);
- Tcl_AppendResult(interp, "bad ", compare,
- " value: expected dictionary but got \"",
- TclGetString(objv[1]), "\"", NULL);
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "bad %s value: expected dictionary but got \"%s\"",
+ compare, TclGetString(objv[1])));
Tcl_SetErrorCode(interp, "TCL", "RESULT", "ILLEGAL_OPTIONS",
NULL);
goto error;
@@ -1440,10 +1439,9 @@ TclMergeReturnOptions(
* Value is not a legal level.
*/
- Tcl_ResetResult(interp);
- Tcl_AppendResult(interp, "bad -level value: "
- "expected non-negative integer but got \"",
- TclGetString(valuePtr), "\"", NULL);
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "bad -level value: expected non-negative integer but got"
+ " \"%s\"", TclGetString(valuePtr)));
Tcl_SetErrorCode(interp, "TCL", "RESULT", "ILLEGAL_LEVEL", NULL);
goto error;
}
@@ -1462,10 +1460,10 @@ TclMergeReturnOptions(
/*
* Value is not a list, which is illegal for -errorcode.
*/
- Tcl_ResetResult(interp);
- Tcl_AppendResult(interp, "bad -errorcode value: "
- "expected a list but got \"",
- TclGetString(valuePtr), "\"", NULL);
+
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "bad -errorcode value: expected a list but got \"%s\"",
+ TclGetString(valuePtr)));
Tcl_SetErrorCode(interp, "TCL", "RESULT", "ILLEGAL_ERRORCODE",
NULL);
goto error;
@@ -1484,10 +1482,10 @@ TclMergeReturnOptions(
/*
* Value is not a list, which is illegal for -errorstack.
*/
- Tcl_ResetResult(interp);
- Tcl_AppendResult(interp, "bad -errorstack value: "
- "expected a list but got \"", TclGetString(valuePtr),
- "\"", NULL);
+
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "bad -errorstack value: expected a list but got \"%s\"",
+ TclGetString(valuePtr)));
Tcl_SetErrorCode(interp, "TCL", "RESULT", "NONLIST_ERRORSTACK",
NULL);
goto error;
@@ -1496,10 +1494,10 @@ TclMergeReturnOptions(
/*
* Errorstack must always be an even-sized list
*/
- Tcl_ResetResult(interp);
- Tcl_AppendResult(interp,
- "forbidden odd-sized list for -errorstack: \"",
- TclGetString(valuePtr), "\"", NULL);
+
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "forbidden odd-sized list for -errorstack: \"%s\"",
+ TclGetString(valuePtr)));
Tcl_SetErrorCode(interp, "TCL", "RESULT",
"ODDSIZEDLIST_ERRORSTACK", NULL);
goto error;
@@ -1650,9 +1648,8 @@ Tcl_SetReturnOptions(
Tcl_IncrRefCount(options);
if (TCL_ERROR == TclListObjGetElements(interp, options, &objc, &objv)
|| (objc % 2)) {
- Tcl_ResetResult(interp);
- Tcl_AppendResult(interp, "expected dict but got \"",
- TclGetString(options), "\"", NULL);
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "expected dict but got \"%s\"", TclGetString(options)));
Tcl_SetErrorCode(interp, "TCL", "RESULT", "ILLEGAL_OPTIONS", NULL);
code = TCL_ERROR;
} else if (TCL_ERROR == TclMergeReturnOptions(interp, objc, objv,
diff --git a/generic/tclScan.c b/generic/tclScan.c
index d21bfaf..ef7eedf 100644
--- a/generic/tclScan.c
+++ b/generic/tclScan.c
@@ -261,6 +261,10 @@ ValidateFormat(
int objIndex, xpgSize, nspace = numVars;
int *nassign = TclStackAlloc(interp, nspace * sizeof(int));
char buf[TCL_UTF_MAX+1];
+ Tcl_Obj *errorMsg; /* Place to build an error messages. Note that
+ * these are messy operations because we do
+ * not want to use the formatting engine;
+ * we're inside there! */
/*
* Initialize an array that records the number of times a variable is
@@ -328,9 +332,9 @@ ValidateFormat(
gotSequential = 1;
if (gotXpg) {
mixedXPG:
- Tcl_SetResult(interp,
+ Tcl_SetObjResult(interp, Tcl_NewStringObj(
"cannot mix \"%\" and \"%n$\" conversion specifiers",
- TCL_STATIC);
+ -1));
Tcl_SetErrorCode(interp, "TCL", "FORMAT", "MIXEDSPECTYPES", NULL);
goto error;
}
@@ -375,9 +379,9 @@ ValidateFormat(
switch (ch) {
case 'c':
if (flags & SCAN_WIDTH) {
- Tcl_SetResult(interp,
+ Tcl_SetObjResult(interp, Tcl_NewStringObj(
"field width may not be specified in %c conversion",
- TCL_STATIC);
+ -1));
Tcl_SetErrorCode(interp, "TCL", "FORMAT", "BADWIDTH", NULL);
goto error;
}
@@ -389,9 +393,11 @@ ValidateFormat(
if (flags & (SCAN_LONGER|SCAN_BIG)) {
invalidFieldSize:
buf[Tcl_UniCharToUtf(ch, buf)] = '\0';
- Tcl_AppendResult(interp,
- "field size modifier may not be specified in %", buf,
- " conversion", NULL);
+ errorMsg = Tcl_NewStringObj(
+ "field size modifier may not be specified in %", -1);
+ Tcl_AppendToObj(errorMsg, buf, -1);
+ Tcl_AppendToObj(errorMsg, " conversion", -1);
+ Tcl_SetObjResult(interp, errorMsg);
Tcl_SetErrorCode(interp, "TCL", "FORMAT", "BADSIZE", NULL);
goto error;
}
@@ -409,8 +415,8 @@ ValidateFormat(
break;
case 'u':
if (flags & SCAN_BIG) {
- Tcl_SetResult(interp,
- "unsigned bignum scans are invalid", TCL_STATIC);
+ Tcl_SetObjResult(interp, Tcl_NewStringObj(
+ "unsigned bignum scans are invalid", -1));
Tcl_SetErrorCode(interp, "TCL", "FORMAT", "BADUNSIGNED",NULL);
goto error;
}
@@ -446,15 +452,18 @@ ValidateFormat(
}
break;
badSet:
- Tcl_SetResult(interp, "unmatched [ in format string",
- TCL_STATIC);
- Tcl_SetErrorCode(interp, "TCL", "FORMAT", "BRACKET", NULL);
+ Tcl_SetObjResult(interp, Tcl_NewStringObj(
+ "unmatched [ in format string", -1));
+ Tcl_SetErrorCode(interp, "TCL", "FORMAT", "BRACKET", NULL);
goto error;
default:
buf[Tcl_UniCharToUtf(ch, buf)] = '\0';
- Tcl_AppendResult(interp, "bad scan conversion character \"", buf,
- "\"", NULL);
- Tcl_SetErrorCode(interp, "TCL", "FORMAT", "BADTYPE", NULL);
+ errorMsg = Tcl_NewStringObj(
+ "bad scan conversion character \"", -1);
+ Tcl_AppendToObj(errorMsg, buf, -1);
+ Tcl_AppendToObj(errorMsg, "\"", -1);
+ Tcl_SetObjResult(interp, errorMsg);
+ Tcl_SetErrorCode(interp, "TCL", "FORMAT", "BADTYPE", NULL);
goto error;
}
if (!(flags & SCAN_SUPPRESS)) {
@@ -498,9 +507,9 @@ ValidateFormat(
}
for (i = 0; i < numVars; i++) {
if (nassign[i] > 1) {
- Tcl_SetResult(interp,
+ Tcl_SetObjResult(interp, Tcl_NewStringObj(
"variable is assigned by multiple \"%n$\" conversion specifiers",
- TCL_STATIC);
+ -1));
Tcl_SetErrorCode(interp, "TCL", "FORMAT", "POLYASSIGNED", NULL);
goto error;
} else if (!xpgSize && (nassign[i] == 0)) {
@@ -509,9 +518,9 @@ ValidateFormat(
* and/or numVars != 0), then too many vars were given
*/
- Tcl_SetResult(interp,
+ Tcl_SetObjResult(interp, Tcl_NewStringObj(
"variable is not assigned by any conversion specifiers",
- TCL_STATIC);
+ -1));
Tcl_SetErrorCode(interp, "TCL", "FORMAT", "UNASSIGNED", NULL);
goto error;
}
@@ -522,13 +531,13 @@ ValidateFormat(
badIndex:
if (gotXpg) {
- Tcl_SetResult(interp, "\"%n$\" argument index out of range",
- TCL_STATIC);
+ Tcl_SetObjResult(interp, Tcl_NewStringObj(
+ "\"%n$\" argument index out of range", -1));
Tcl_SetErrorCode(interp, "TCL", "FORMAT", "INDEXRANGE", NULL);
} else {
- Tcl_SetResult(interp,
+ Tcl_SetObjResult(interp, Tcl_NewStringObj(
"different numbers of variable names and field specifiers",
- TCL_STATIC);
+ -1));
Tcl_SetErrorCode(interp, "TCL", "FORMAT", "FIELDVARMISMATCH", NULL);
}
diff --git a/generic/tclStrToD.c b/generic/tclStrToD.c
index 332cfca..2d534a68 100755
--- a/generic/tclStrToD.c
+++ b/generic/tclStrToD.c
@@ -192,8 +192,6 @@ static int maxDigits; /* The maximum number of digits to the left of
* the decimal point of a double. */
static int minDigits; /* The maximum number of digits to the right
* of the decimal point in a double. */
-static int mantDIGIT; /* Number of mp_digit's needed to hold the
- * significand of a double. */
static const double pow_10_2_n[] = { /* Inexact higher powers of ten. */
1.0,
100.0,
@@ -4425,7 +4423,6 @@ TclInitDoubleConversion(void)
+ 0.5 * log(10.)) / log(10.));
minDigits = (int) floor((DBL_MIN_EXP - DBL_MANT_DIG)
* log((double) FLT_RADIX) / log(10.));
- mantDIGIT = (mantBits + DIGIT_BIT-1) / DIGIT_BIT;
log10_DIGIT_MAX = (int) floor(DIGIT_BIT * log(2.) / log(10.));
/*
diff --git a/generic/tclStubInit.c b/generic/tclStubInit.c
index 8f42f96..87cd4eb 100644
--- a/generic/tclStubInit.c
+++ b/generic/tclStubInit.c
@@ -39,6 +39,7 @@
#undef Tcl_CreateHashEntry
#undef Tcl_Panic
#undef Tcl_FindExecutable
+#undef TclpGetPid
#undef TclSockMinimumBuffers
/* See bug 510001: TclSockMinimumBuffers needs plat imp */
@@ -46,36 +47,33 @@
# define TclSockMinimumBuffersOld 0
#else
#define TclSockMinimumBuffersOld sockMinimumBuffersOld
-static int TclSockMinimumBuffersOld(sock, size)
- int sock;
- int size;
+static int TclSockMinimumBuffersOld(int sock, int size)
{
return TclSockMinimumBuffers(INT2PTR(sock), size);
}
#endif
-#ifdef __CYGWIN__
-
-/* Trick, so we don't have to include <windows.h> here, which
- * - b.t.w. - lacks this function anyway */
-#define GET_MODULE_HANDLE_EX_FLAG_FROM_ADDRESS 0x00000004
-int __stdcall GetModuleHandleExW(unsigned int, const char *, void *);
-
-#define TclWinGetPlatformId winGetPlatformId
-#define Tcl_WinUtfToTChar winUtfToTChar
-#define Tcl_WinTCharToUtf winTCharToUtf
-#define TclWinGetTclInstance winGetTclInstance
-#define TclWinNToHS winNToHS
-#define TclWinSetSockOpt winSetSockOpt
-#define TclWinNoBackslash winNoBackslash
-#define TclWinSetInterfaces (void (*) (int)) doNothing
-#define TclWinAddProcess (void (*) (void *, unsigned int)) doNothing
-#define TclWinFlushDirtyChannels doNothing
-#define TclWinResetInterfaces doNothing
+#ifdef __WIN32__
+# define TclUnixWaitForFile 0
+# define TclUnixCopyFile 0
+# define TclpReaddir 0
+# define TclpIsAtty 0
+#elif defined(__CYGWIN__)
+# define TclpIsAtty TclPlatIsAtty
+# define TclWinSetInterfaces (void (*) (int)) doNothing
+# define TclWinAddProcess (void (*) (void *, unsigned int)) doNothing
+# define TclWinFlushDirtyChannels doNothing
+# define TclWinResetInterfaces doNothing
static Tcl_Encoding winTCharEncoding;
static int
+TclpIsAtty(int fd)
+{
+ return isatty(fd);
+}
+
+int
TclWinGetPlatformId()
{
/* Don't bother to determine the real platform on cygwin,
@@ -83,7 +81,7 @@ TclWinGetPlatformId()
return 2; /* VER_PLATFORM_WIN32_NT */;
}
-static void *TclWinGetTclInstance()
+void *TclWinGetTclInstance()
{
void *hInstance = NULL;
GetModuleHandleExW(GET_MODULE_HANDLE_EX_FLAG_FROM_ADDRESS,
@@ -91,20 +89,33 @@ static void *TclWinGetTclInstance()
return hInstance;
}
-static unsigned short
+unsigned short
TclWinNToHS(unsigned short ns)
{
return ntohs(ns);
}
-static int
-TclWinSetSockOpt(void *s, int level, int optname,
+int
+TclWinSetSockOpt(SOCKET s, int level, int optname,
const char *optval, int optlen)
{
return setsockopt((int) s, level, optname, optval, optlen);
}
-static char *
+int
+TclWinGetSockOpt(SOCKET s, int level, int optname,
+ char *optval, int *optlen)
+{
+ return getsockopt((int) s, level, optname, optval, optlen);
+}
+
+struct servent *
+TclWinGetServByName(const char *name, const char *proto)
+{
+ return getservbyname(name, proto);
+}
+
+char *
TclWinNoBackslash(char *path)
{
char *p;
@@ -117,17 +128,23 @@ TclWinNoBackslash(char *path)
return path;
}
+int
+TclpGetPid(Tcl_Pid pid)
+{
+ return (int) (size_t) pid;
+}
+
static void
doNothing(void)
{
/* dummy implementation, no need to do anything */
}
-static char *
-Tcl_WinUtfToTChar(string, len, dsPtr)
- const char *string;
- int len;
- Tcl_DString *dsPtr;
+char *
+Tcl_WinUtfToTChar(
+ const char *string,
+ int len,
+ Tcl_DString *dsPtr)
{
if (!winTCharEncoding) {
winTCharEncoding = Tcl_GetEncoding(0, "unicode");
@@ -136,7 +153,7 @@ Tcl_WinUtfToTChar(string, len, dsPtr)
string, len, dsPtr);
}
-static char *
+char *
Tcl_WinTCharToUtf(
const char *string,
int len,
@@ -149,38 +166,15 @@ Tcl_WinTCharToUtf(
string, len, dsPtr);
}
-#define Tcl_MacOSXOpenBundleResources (int (*) _ANSI_ARGS_(( \
- Tcl_Interp *, const char *, int, int, char *))) Tcl_WinUtfToTChar
-#define Tcl_MacOSXOpenVersionedBundleResources (int (*) _ANSI_ARGS_(( \
- Tcl_Interp *, const char *, const char *, int, int, char *))) Tcl_WinTCharToUtf
-#define TclMacOSXGetFileAttribute (int (*) _ANSI_ARGS_((Tcl_Interp *, \
- int, Tcl_Obj *, Tcl_Obj **))) TclpCreateProcess
-#define TclMacOSXMatchType (int (*) _ANSI_ARGS_((Tcl_Interp *, const char *, \
- const char *, Tcl_StatBuf *, Tcl_GlobTypeData *))) TclpMakeFile
-#define TclMacOSXNotifierAddRunLoopMode (void (*) _ANSI_ARGS_((const void *))) TclpOpenFile
-#define TclpLocaltime_unix (struct tm *(*) _ANSI_ARGS_((const time_t *))) TclGetAndDetachPids
-#define TclpGmtime_unix (struct tm *(*) _ANSI_ARGS_((const time_t *))) TclpCloseFile
+#define TclMacOSXGetFileAttribute (int (*) (Tcl_Interp *, \
+ int, Tcl_Obj *, Tcl_Obj **)) TclpCreateProcess
+#define TclMacOSXMatchType (int (*) (Tcl_Interp *, const char *, \
+ const char *, Tcl_StatBuf *, Tcl_GlobTypeData *)) TclpMakeFile
+#define TclMacOSXNotifierAddRunLoopMode (void (*) (const void *)) TclpOpenFile
+#define TclpLocaltime_unix (struct tm *(*) (const time_t *)) TclGetAndDetachPids
+#define TclpGmtime_unix (struct tm *(*) (const time_t *)) TclpCloseFile
-#elif !defined(__WIN32__) /* UNIX and MAC */
-# define TclWinConvertError (void (*) _ANSI_ARGS_((unsigned int))) TclGetAndDetachPids
-# undef TclWinConvertWSAError
-# define TclWinConvertWSAError (void (*) _ANSI_ARGS_((unsigned int))) TclpCloseFile
-# define TclWinGetPlatformId (int (*)()) TclpCreateTempFile
-# define TclWinGetTclInstance (void *(*)()) TclpCreateProcess
-# define TclWinNToHS (unsigned short (*) _ANSI_ARGS_((unsigned short ns))) TclpMakeFile
-# define TclWinSetSockOpt (int (*) _ANSI_ARGS_((void *, int, int, const char *, int))) TclpOpenFile
-# define TclWinAddProcess 0
-# define TclWinNoBackslash 0
-# define TclWinSetInterfaces 0
-# define TclWinFlushDirtyChannels 0
-# define TclWinResetInterfaces 0
-# define TclMacOSXGetFileAttribute 0 /* Only implemented in Tcl >= 8.5 */
-# define TclMacOSXMatchType 0 /* Only implemented in Tcl >= 8.5 */
-# define TclMacOSXNotifierAddRunLoopMode 0 /* Only implemented in Tcl >= 8.5 */
-# ifndef MAC_OSX_TCL
-# define Tcl_MacOSXOpenBundleResources 0
-# define Tcl_MacOSXOpenVersionedBundleResources 0
-# endif
+#else /* UNIX and MAC */
# define TclpLocaltime_unix TclpLocaltime
# define TclpGmtime_unix TclpGmtime
#endif
@@ -455,63 +449,61 @@ static const TclIntStubs tclIntStubs = {
static const TclIntPlatStubs tclIntPlatStubs = {
TCL_STUB_MAGIC,
0,
-#if !defined(__WIN32__) && !defined(MAC_OSX_TCL) /* UNIX */
- TclWinConvertError, /* 0 */
- TclWinConvertWSAError, /* 1 */
+#if !defined(__WIN32__) && !defined(__CYGWIN__) && !defined(MAC_OSX_TCL) /* UNIX */
+ TclGetAndDetachPids, /* 0 */
+ TclpCloseFile, /* 1 */
TclpCreateCommandChannel, /* 2 */
TclpCreatePipe, /* 3 */
- TclWinGetTclInstance, /* 4 */
+ TclpCreateProcess, /* 4 */
0, /* 5 */
- TclWinNToHS, /* 6 */
- TclWinSetSockOpt, /* 7 */
+ TclpMakeFile, /* 6 */
+ TclpOpenFile, /* 7 */
TclUnixWaitForFile, /* 8 */
- TclWinGetPlatformId, /* 9 */
+ TclpCreateTempFile, /* 9 */
TclpReaddir, /* 10 */
TclpLocaltime_unix, /* 11 */
TclpGmtime_unix, /* 12 */
TclpInetNtoa, /* 13 */
TclUnixCopyFile, /* 14 */
- TclMacOSXGetFileAttribute, /* 15 */
+ 0, /* 15 */
0, /* 16 */
0, /* 17 */
- TclMacOSXMatchType, /* 18 */
- TclMacOSXNotifierAddRunLoopMode, /* 19 */
- TclWinAddProcess, /* 20 */
+ 0, /* 18 */
+ 0, /* 19 */
+ 0, /* 20 */
0, /* 21 */
- TclpCreateTempFile, /* 22 */
+ 0, /* 22 */
0, /* 23 */
- TclWinNoBackslash, /* 24 */
+ 0, /* 24 */
0, /* 25 */
- TclWinSetInterfaces, /* 26 */
- TclWinFlushDirtyChannels, /* 27 */
- TclWinResetInterfaces, /* 28 */
+ 0, /* 26 */
+ 0, /* 27 */
+ 0, /* 28 */
TclWinCPUID, /* 29 */
- TclGetAndDetachPids, /* 30 */
- TclpCloseFile, /* 31 */
#endif /* UNIX */
-#ifdef __WIN32__ /* WIN */
+#if defined(__WIN32__) || defined(__CYGWIN__) /* WIN */
TclWinConvertError, /* 0 */
TclWinConvertWSAError, /* 1 */
TclWinGetServByName, /* 2 */
TclWinGetSockOpt, /* 3 */
TclWinGetTclInstance, /* 4 */
- 0, /* 5 */
+ TclUnixWaitForFile, /* 5 */
TclWinNToHS, /* 6 */
TclWinSetSockOpt, /* 7 */
TclpGetPid, /* 8 */
TclWinGetPlatformId, /* 9 */
- 0, /* 10 */
+ TclpReaddir, /* 10 */
TclGetAndDetachPids, /* 11 */
TclpCloseFile, /* 12 */
TclpCreateCommandChannel, /* 13 */
TclpCreatePipe, /* 14 */
TclpCreateProcess, /* 15 */
- 0, /* 16 */
- 0, /* 17 */
+ TclpIsAtty, /* 16 */
+ TclUnixCopyFile, /* 17 */
TclpMakeFile, /* 18 */
TclpOpenFile, /* 19 */
TclWinAddProcess, /* 20 */
- 0, /* 21 */
+ TclpInetNtoa, /* 21 */
TclpCreateTempFile, /* 22 */
0, /* 23 */
TclWinNoBackslash, /* 24 */
@@ -522,16 +514,16 @@ static const TclIntPlatStubs tclIntPlatStubs = {
TclWinCPUID, /* 29 */
#endif /* WIN */
#ifdef MAC_OSX_TCL /* MACOSX */
- TclWinConvertError, /* 0 */
- TclWinConvertWSAError, /* 1 */
+ TclGetAndDetachPids, /* 0 */
+ TclpCloseFile, /* 1 */
TclpCreateCommandChannel, /* 2 */
TclpCreatePipe, /* 3 */
- TclWinGetTclInstance, /* 4 */
+ TclpCreateProcess, /* 4 */
0, /* 5 */
- TclWinNToHS, /* 6 */
- TclWinSetSockOpt, /* 7 */
+ TclpMakeFile, /* 6 */
+ TclpOpenFile, /* 7 */
TclUnixWaitForFile, /* 8 */
- TclWinGetPlatformId, /* 9 */
+ TclpCreateTempFile, /* 9 */
TclpReaddir, /* 10 */
TclpLocaltime_unix, /* 11 */
TclpGmtime_unix, /* 12 */
@@ -542,29 +534,23 @@ static const TclIntPlatStubs tclIntPlatStubs = {
TclMacOSXCopyFileAttributes, /* 17 */
TclMacOSXMatchType, /* 18 */
TclMacOSXNotifierAddRunLoopMode, /* 19 */
- TclWinAddProcess, /* 20 */
+ 0, /* 20 */
0, /* 21 */
- TclpCreateTempFile, /* 22 */
+ 0, /* 22 */
0, /* 23 */
- TclWinNoBackslash, /* 24 */
+ 0, /* 24 */
0, /* 25 */
- TclWinSetInterfaces, /* 26 */
- TclWinFlushDirtyChannels, /* 27 */
- TclWinResetInterfaces, /* 28 */
+ 0, /* 26 */
+ 0, /* 27 */
+ 0, /* 28 */
TclWinCPUID, /* 29 */
- TclGetAndDetachPids, /* 30 */
- TclpCloseFile, /* 31 */
#endif /* MACOSX */
};
static const TclPlatStubs tclPlatStubs = {
TCL_STUB_MAGIC,
0,
-#if !defined(__WIN32__) && !defined(MAC_OSX_TCL) /* UNIX */
- Tcl_MacOSXOpenBundleResources, /* 0 */
- Tcl_MacOSXOpenVersionedBundleResources, /* 1 */
-#endif /* UNIX */
-#ifdef __WIN32__ /* WIN */
+#if defined(__WIN32__) || defined(__CYGWIN__) /* WIN */
Tcl_WinUtfToTChar, /* 0 */
Tcl_WinTCharToUtf, /* 1 */
#endif /* WIN */
@@ -664,7 +650,7 @@ const TclStubs tclStubs = {
#if !defined(__WIN32__) && !defined(MAC_OSX_TCL) /* UNIX */
Tcl_CreateFileHandler, /* 9 */
#endif /* UNIX */
-#ifdef __WIN32__ /* WIN */
+#if defined(__WIN32__) /* WIN */
0, /* 9 */
#endif /* WIN */
#ifdef MAC_OSX_TCL /* MACOSX */
@@ -673,7 +659,7 @@ const TclStubs tclStubs = {
#if !defined(__WIN32__) && !defined(MAC_OSX_TCL) /* UNIX */
Tcl_DeleteFileHandler, /* 10 */
#endif /* UNIX */
-#ifdef __WIN32__ /* WIN */
+#if defined(__WIN32__) /* WIN */
0, /* 10 */
#endif /* WIN */
#ifdef MAC_OSX_TCL /* MACOSX */
@@ -838,7 +824,7 @@ const TclStubs tclStubs = {
#if !defined(__WIN32__) && !defined(MAC_OSX_TCL) /* UNIX */
Tcl_GetOpenFile, /* 167 */
#endif /* UNIX */
-#ifdef __WIN32__ /* WIN */
+#if defined(__WIN32__) /* WIN */
0, /* 167 */
#endif /* WIN */
#ifdef MAC_OSX_TCL /* MACOSX */
diff --git a/generic/tclTest.c b/generic/tclTest.c
index 37ec751..b4192b2 100644
--- a/generic/tclTest.c
+++ b/generic/tclTest.c
@@ -313,11 +313,8 @@ static int TestexitmainloopCmd(ClientData dummy,
Tcl_Interp *interp, int argc, const char **argv);
static int TestpanicCmd(ClientData dummy,
Tcl_Interp *interp, int argc, const char **argv);
-static int TestfinexitObjCmd(ClientData dummy,
- Tcl_Interp *interp, int objc,
- Tcl_Obj *const objv[]);
-static int TestparseargsCmd(ClientData dummy, Tcl_Interp *interp,
- int objc, Tcl_Obj *const objv[]);
+static int TestparseargsCmd(ClientData dummy, Tcl_Interp *interp,
+ int objc, Tcl_Obj *const objv[]);
static int TestparserObjCmd(ClientData dummy,
Tcl_Interp *interp, int objc,
Tcl_Obj *const objv[]);
@@ -419,6 +416,11 @@ static int TestNRELevels(ClientData clientData,
static int TestInterpResolverCmd(ClientData clientData,
Tcl_Interp *interp, int objc,
Tcl_Obj *const objv[]);
+#if defined(HAVE_CPUID) || defined(__WIN32__)
+static int TestcpuidCmd(ClientData dummy,
+ Tcl_Interp* interp, int objc,
+ Tcl_Obj *CONST objv[]);
+#endif
static const Tcl_Filesystem testReportingFilesystem = {
"reporting",
@@ -633,7 +635,6 @@ Tcltest_Init(
Tcl_CreateObjCommand(interp, "testlocale", TestlocaleCmd, NULL,
NULL);
Tcl_CreateCommand(interp, "testpanic", TestpanicCmd, NULL, NULL);
- Tcl_CreateObjCommand(interp, "testfinexit", TestfinexitObjCmd, NULL, NULL);
Tcl_CreateObjCommand(interp, "testparseargs", TestparseargsCmd,NULL,NULL);
Tcl_CreateObjCommand(interp, "testparser", TestparserObjCmd,
NULL, NULL);
@@ -676,6 +677,10 @@ Tcltest_Init(
NULL, NULL);
Tcl_CreateCommand(interp, "testexitmainloop", TestexitmainloopCmd,
NULL, NULL);
+#if defined(HAVE_CPUID) || defined(__WIN32__)
+ Tcl_CreateObjCommand(interp, "testcpuid", TestcpuidCmd,
+ (ClientData) 0, NULL);
+#endif
t3ArgTypes[0] = TCL_EITHER;
t3ArgTypes[1] = TCL_EITHER;
Tcl_CreateMathFunc(interp, "T3", 2, t3ArgTypes, TestMathFunc2,
@@ -861,6 +866,7 @@ TestasyncCmd(
|| (Tcl_GetInt(interp, argv[4], &code) != TCL_OK)) {
return TCL_ERROR;
}
+ Tcl_MutexLock(&asyncTestMutex);
for (asyncPtr = firstHandler; asyncPtr != NULL;
asyncPtr = asyncPtr->nextPtr) {
if (asyncPtr->id == id) {
@@ -869,6 +875,7 @@ TestasyncCmd(
}
}
Tcl_SetObjResult(interp, Tcl_NewStringObj(argv[3], -1));
+ Tcl_MutexUnlock(&asyncTestMutex);
return code;
#ifdef TCL_THREADS
} else if (strcmp(argv[1], "marklater") == 0) {
@@ -878,6 +885,7 @@ TestasyncCmd(
if (Tcl_GetInt(interp, argv[2], &id) != TCL_OK) {
return TCL_ERROR;
}
+ Tcl_MutexLock(&asyncTestMutex);
for (asyncPtr = firstHandler; asyncPtr != NULL;
asyncPtr = asyncPtr->nextPtr) {
if (asyncPtr->id == id) {
@@ -886,11 +894,13 @@ TestasyncCmd(
INT2PTR(id), TCL_THREAD_STACK_DEFAULT,
TCL_THREAD_NOFLAGS) != TCL_OK) {
Tcl_SetResult(interp, "can't create thread", TCL_STATIC);
+ Tcl_MutexUnlock(&asyncTestMutex);
return TCL_ERROR;
}
break;
}
}
+ Tcl_MutexUnlock(&asyncTestMutex);
} else {
Tcl_AppendResult(interp, "bad option \"", argv[1],
"\": must be create, delete, int, mark, or marklater", NULL);
@@ -3262,7 +3272,7 @@ TestlocaleCmd(
"ctype", "numeric", "time", "collate", "monetary",
"all", NULL
};
- static int lcTypes[] = {
+ static const int lcTypes[] = {
LC_CTYPE, LC_NUMERIC, LC_TIME, LC_COLLATE, LC_MONETARY,
LC_ALL
};
@@ -4538,47 +4548,6 @@ TestpanicCmd(
return TCL_OK;
}
-/*
- *----------------------------------------------------------------------
- *
- * TestfinexitObjCmd --
- *
- * Calls a variant of [exit] including the full finalization path.
- *
- * Results:
- * Error, or doesn't return.
- *
- * Side effects:
- * Exits application.
- *
- *----------------------------------------------------------------------
- */
-
-static int
-TestfinexitObjCmd(
- ClientData dummy, /* Not used. */
- Tcl_Interp *interp, /* Current interpreter. */
- int objc, /* Number of arguments. */
- Tcl_Obj *const objv[]) /* Argument objects. */
-{
- int value;
-
- if ((objc != 1) && (objc != 2)) {
- Tcl_WrongNumArgs(interp, 1, objv, "?returnCode?");
- return TCL_ERROR;
- }
-
- if (objc == 1) {
- value = 0;
- } else if (Tcl_GetIntFromObj(interp, objv[1], &value) != TCL_OK) {
- return TCL_ERROR;
- }
- Tcl_Finalize();
- TclpExit(value);
- /*NOTREACHED*/
- return TCL_ERROR; /* Better not ever reach this! */
-}
-
static int
TestfileCmd(
ClientData dummy, /* Not used. */
@@ -6648,6 +6617,62 @@ TestNumUtfCharsCmd(
}
return TCL_OK;
}
+
+#if defined(HAVE_CPUID) || defined(__WIN32__)
+/*
+ *----------------------------------------------------------------------
+ *
+ * TestcpuidCmd --
+ *
+ * Retrieves CPU ID information.
+ *
+ * Usage:
+ * testwincpuid <eax>
+ *
+ * Parameters:
+ * eax - The value to pass in the EAX register to a CPUID instruction.
+ *
+ * Results:
+ * Returns a four-element list containing the values from the EAX, EBX,
+ * ECX and EDX registers returned from the CPUID instruction.
+ *
+ * Side effects:
+ * None.
+ *
+ *----------------------------------------------------------------------
+ */
+
+static int
+TestcpuidCmd(
+ ClientData dummy,
+ Tcl_Interp* interp, /* Tcl interpreter */
+ int objc, /* Parameter count */
+ Tcl_Obj *const * objv) /* Parameter vector */
+{
+ int status, index, i;
+ unsigned int regs[4];
+ Tcl_Obj *regsObjs[4];
+
+ if (objc != 2) {
+ Tcl_WrongNumArgs(interp, 1, objv, "eax");
+ return TCL_ERROR;
+ }
+ if (Tcl_GetIntFromObj(interp, objv[1], &index) != TCL_OK) {
+ return TCL_ERROR;
+ }
+ status = TclWinCPUID((unsigned) index, regs);
+ if (status != TCL_OK) {
+ Tcl_SetObjResult(interp,
+ Tcl_NewStringObj("operation not available", -1));
+ return status;
+ }
+ for (i=0 ; i<4 ; ++i) {
+ regsObjs[i] = Tcl_NewIntObj((int) regs[i]);
+ }
+ Tcl_SetObjResult(interp, Tcl_NewListObj(4, regsObjs));
+ return TCL_OK;
+}
+#endif
/*
* Used to do basic checks of the TCL_HASH_KEY_SYSTEM_HASH flag
diff --git a/generic/tclTimer.c b/generic/tclTimer.c
index cf91dca..6b17825 100644
--- a/generic/tclTimer.c
+++ b/generic/tclTimer.c
@@ -182,8 +182,7 @@ static void TimerSetupProc(ClientData clientData, int flags);
static ThreadSpecificData *
InitTimer(void)
{
- ThreadSpecificData *tsdPtr = (ThreadSpecificData *)
- TclThreadDataKeyGet(&dataKey);
+ ThreadSpecificData *tsdPtr = TclThreadDataKeyGet(&dataKey);
if (tsdPtr == NULL) {
tsdPtr = TCL_TSD_INIT(&dataKey);
@@ -214,8 +213,7 @@ static void
TimerExitProc(
ClientData clientData) /* Not used. */
{
- ThreadSpecificData *tsdPtr = (ThreadSpecificData *)
- TclThreadDataKeyGet(&dataKey);
+ ThreadSpecificData *tsdPtr = TclThreadDataKeyGet(&dataKey);
Tcl_DeleteEventSource(TimerSetupProc, TimerCheckProc, NULL);
if (tsdPtr != NULL) {
@@ -297,9 +295,8 @@ TclCreateAbsoluteTimerHandler(
ClientData clientData)
{
register TimerHandler *timerHandlerPtr, *tPtr2, *prevPtr;
- ThreadSpecificData *tsdPtr;
+ ThreadSpecificData *tsdPtr = InitTimer();
- tsdPtr = InitTimer();
timerHandlerPtr = ckalloc(sizeof(TimerHandler));
/*
@@ -832,8 +829,9 @@ Tcl_AfterObjCmd(
if (Tcl_GetWideIntFromObj(NULL, objv[1], &ms) != TCL_OK) {
const char *arg = Tcl_GetString(objv[1]);
- Tcl_AppendResult(interp, "bad argument \"", arg,
- "\": must be cancel, idle, info, or an integer", NULL);
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "bad argument \"%s\": must be"
+ " cancel, idle, info, or an integer", arg));
Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "INDEX", "argument",
arg, NULL);
return TCL_ERROR;
@@ -971,8 +969,8 @@ Tcl_AfterObjCmd(
if (afterPtr == NULL) {
const char *eventStr = TclGetString(objv[2]);
- Tcl_AppendResult(interp, "event \"", eventStr, "\" doesn't exist",
- NULL);
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "event \"%s\" doesn't exist", eventStr));
Tcl_SetErrorCode(interp, "TCL","LOOKUP","EVENT", eventStr, NULL);
return TCL_ERROR;
} else {
diff --git a/generic/tclTomMathStubLib.c b/generic/tclTomMathStubLib.c
index e7e4aea..a3bc4b3 100644
--- a/generic/tclTomMathStubLib.c
+++ b/generic/tclTomMathStubLib.c
@@ -73,10 +73,10 @@ TclTomMathInitializeStubs(
tclTomMathStubsPtr = stubsPtr;
return actualVersion;
}
- Tcl_ResetResult(interp);
- Tcl_AppendResult(interp, "error loading ", packageName,
- " (requested version ", version, ", actual version ",
- actualVersion, "): ", errMsg, NULL);
+
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "error loading %s (requested version %s, actual version %s): %s",
+ packageName, version, actualVersion, errMsg));
return NULL;
}
diff --git a/generic/tclTrace.c b/generic/tclTrace.c
index 2e38086..519f201 100644
--- a/generic/tclTrace.c
+++ b/generic/tclTrace.c
@@ -113,7 +113,7 @@ static const char *const traceTypeOptions[] = {
static Tcl_TraceTypeObjCmd *const traceSubCmds[] = {
TraceExecutionObjCmd,
TraceCommandObjCmd,
- TraceVariableObjCmd,
+ TraceVariableObjCmd
};
/*
@@ -366,8 +366,9 @@ Tcl_TraceObjCmd(
return TCL_OK;
badVarOps:
- Tcl_AppendResult(interp, "bad operations \"", flagOps,
- "\": should be one or more of rwua", NULL);
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "bad operations \"%s\": should be one or more of rwua",
+ flagOps));
Tcl_SetErrorCode(interp, "TCL", "OPERATION", "TRACE", "BADOPS", NULL);
return TCL_ERROR;
}
@@ -434,9 +435,9 @@ TraceExecutionObjCmd(
return result;
}
if (listLen == 0) {
- Tcl_SetResult(interp, "bad operation list \"\": must be "
- "one or more of enter, leave, enterstep, or leavestep",
- TCL_STATIC);
+ Tcl_SetObjResult(interp, Tcl_NewStringObj(
+ "bad operation list \"\": must be one or more of"
+ " enter, leave, enterstep, or leavestep", -1));
Tcl_SetErrorCode(interp, "TCL", "OPERATION", "TRACE", "NOOPS",
NULL);
return TCL_ERROR;
@@ -677,8 +678,9 @@ TraceCommandObjCmd(
return result;
}
if (listLen == 0) {
- Tcl_SetResult(interp, "bad operation list \"\": must be "
- "one or more of delete or rename", TCL_STATIC);
+ Tcl_SetObjResult(interp, Tcl_NewStringObj(
+ "bad operation list \"\": must be one or more of"
+ " delete or rename", -1));
Tcl_SetErrorCode(interp, "TCL", "OPERATION", "TRACE", "NOOPS",
NULL);
return TCL_ERROR;
@@ -875,8 +877,9 @@ TraceVariableObjCmd(
return result;
}
if (listLen == 0) {
- Tcl_SetResult(interp, "bad operation list \"\": must be "
- "one or more of array, read, unset, or write", TCL_STATIC);
+ Tcl_SetObjResult(interp, Tcl_NewStringObj(
+ "bad operation list \"\": must be one or more of"
+ " array, read, unset, or write", -1));
Tcl_SetErrorCode(interp, "TCL", "OPERATION", "TRACE", "NOOPS",
NULL);
return TCL_ERROR;
@@ -1298,9 +1301,9 @@ TraceCommandProc(
Tcl_DStringAppendElement(&cmd, oldName);
Tcl_DStringAppendElement(&cmd, (newName ? newName : ""));
if (flags & TCL_TRACE_RENAME) {
- Tcl_DStringAppend(&cmd, " rename", 7);
+ TclDStringAppendLiteral(&cmd, " rename");
} else if (flags & TCL_TRACE_DELETE) {
- Tcl_DStringAppend(&cmd, " delete", 7);
+ TclDStringAppendLiteral(&cmd, " delete");
}
/*
@@ -1994,24 +1997,24 @@ TraceVarProc(
#ifndef TCL_REMOVE_OBSOLETE_TRACES
if (tvarPtr->flags & TCL_TRACE_OLD_STYLE) {
if (flags & TCL_TRACE_ARRAY) {
- Tcl_DStringAppend(&cmd, " a", 2);
+ TclDStringAppendLiteral(&cmd, " a");
} else if (flags & TCL_TRACE_READS) {
- Tcl_DStringAppend(&cmd, " r", 2);
+ TclDStringAppendLiteral(&cmd, " r");
} else if (flags & TCL_TRACE_WRITES) {
- Tcl_DStringAppend(&cmd, " w", 2);
+ TclDStringAppendLiteral(&cmd, " w");
} else if (flags & TCL_TRACE_UNSETS) {
- Tcl_DStringAppend(&cmd, " u", 2);
+ TclDStringAppendLiteral(&cmd, " u");
}
} else {
#endif
if (flags & TCL_TRACE_ARRAY) {
- Tcl_DStringAppend(&cmd, " array", 6);
+ TclDStringAppendLiteral(&cmd, " array");
} else if (flags & TCL_TRACE_READS) {
- Tcl_DStringAppend(&cmd, " read", 5);
+ TclDStringAppendLiteral(&cmd, " read");
} else if (flags & TCL_TRACE_WRITES) {
- Tcl_DStringAppend(&cmd, " write", 6);
+ TclDStringAppendLiteral(&cmd, " write");
} else if (flags & TCL_TRACE_UNSETS) {
- Tcl_DStringAppend(&cmd, " unset", 6);
+ TclDStringAppendLiteral(&cmd, " unset");
}
#ifndef TCL_REMOVE_OBSOLETE_TRACES
}
@@ -2577,7 +2580,7 @@ TclCallVarTraces(
char *newPart1;
Tcl_DStringInit(&nameCopy);
- Tcl_DStringAppend(&nameCopy, part1, (p-part1));
+ Tcl_DStringAppend(&nameCopy, part1, p-part1);
newPart1 = Tcl_DStringValue(&nameCopy);
newPart1[offset] = 0;
part1 = newPart1;
@@ -2715,7 +2718,8 @@ TclCallVarTraces(
if (disposeFlags & TCL_TRACE_RESULT_OBJECT) {
Tcl_SetObjResult((Tcl_Interp *)iPtr, (Tcl_Obj *) result);
} else {
- Tcl_SetResult((Tcl_Interp *)iPtr, result, TCL_STATIC);
+ Tcl_SetObjResult((Tcl_Interp *)iPtr,
+ Tcl_NewStringObj(result, -1));
}
Tcl_AddErrorInfo((Tcl_Interp *)iPtr, "");
diff --git a/generic/tclUniData.c b/generic/tclUniData.c
index 2fabe58..5c88639 100644
--- a/generic/tclUniData.c
+++ b/generic/tclUniData.c
@@ -882,7 +882,7 @@ static const unsigned char groupMap[] = {
18, 18, 18, 18, 7, 7, 7, 5, 6, 85, 18, 18, 18, 18, 18, 18, 18, 18,
18, 18, 7, 7, 7, 5, 6, 0, 85, 85, 85, 85, 85, 85, 85, 85, 85, 85, 85,
85, 85, 0, 0, 0, 4, 4, 4, 4, 4, 4, 4, 4, 4, 4, 4, 4, 4, 4, 4, 4, 4,
- 4, 4, 4, 4, 4, 4, 4, 4, 4, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
+ 4, 4, 4, 4, 4, 4, 4, 4, 4, 4, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
0, 0, 0, 0, 0, 0, 0, 0, 86, 86, 86, 86, 86, 86, 86, 86, 86, 86, 86,
86, 86, 111, 111, 111, 111, 86, 111, 111, 111, 86, 86, 86, 86, 86,
86, 86, 86, 86, 86, 86, 86, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
diff --git a/generic/tclUtil.c b/generic/tclUtil.c
index a1c1996..6d42080 100644
--- a/generic/tclUtil.c
+++ b/generic/tclUtil.c
@@ -655,16 +655,16 @@ TclFindElement(
if (p == limit) {
if (openBraces != 0) {
if (interp != NULL) {
- Tcl_SetResult(interp, "unmatched open brace in list",
- TCL_STATIC);
+ Tcl_SetObjResult(interp, Tcl_NewStringObj(
+ "unmatched open brace in list", -1));
Tcl_SetErrorCode(interp, "TCL", "VALUE", "LIST", "BRACE",
NULL);
}
return TCL_ERROR;
} else if (inQuotes) {
if (interp != NULL) {
- Tcl_SetResult(interp, "unmatched open quote in list",
- TCL_STATIC);
+ Tcl_SetObjResult(interp, Tcl_NewStringObj(
+ "unmatched open quote in list", -1));
Tcl_SetErrorCode(interp, "TCL", "VALUE", "LIST", "QUOTE",
NULL);
}
@@ -810,8 +810,8 @@ Tcl_SplitList(
if (i >= size) {
ckfree(argv);
if (interp != NULL) {
- Tcl_SetResult(interp, "internal error in Tcl_SplitList",
- TCL_STATIC);
+ Tcl_SetObjResult(interp, Tcl_NewStringObj(
+ "internal error in Tcl_SplitList", -1));
Tcl_SetErrorCode(interp, "TCL", "INTERNAL", "Tcl_SplitList",
NULL);
}
@@ -2438,6 +2438,37 @@ Tcl_DStringAppend(
/*
*----------------------------------------------------------------------
*
+ * TclDStringAppendObj, TclDStringAppendDString --
+ *
+ * Simple wrappers round Tcl_DStringAppend that make it easier to append
+ * from particular sources of strings.
+ *
+ *----------------------------------------------------------------------
+ */
+
+char *
+TclDStringAppendObj(
+ Tcl_DString *dsPtr,
+ Tcl_Obj *objPtr)
+{
+ int length;
+ char *bytes = Tcl_GetStringFromObj(objPtr, &length);
+
+ return Tcl_DStringAppend(dsPtr, bytes, length);
+}
+
+char *
+TclDStringAppendDString(
+ Tcl_DString *dsPtr,
+ Tcl_DString *toAppendPtr)
+{
+ return Tcl_DStringAppend(dsPtr, Tcl_DStringValue(toAppendPtr),
+ Tcl_DStringLength(toAppendPtr));
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
* Tcl_DStringAppendElement --
*
* Append a list element to the current value of a dynamic string.
@@ -2715,6 +2746,64 @@ Tcl_DStringGetResult(
/*
*----------------------------------------------------------------------
*
+ * TclDStringToObj --
+ *
+ * This function moves a dynamic string's contents to a new Tcl_Obj. Be
+ * aware that this function does *not* check that the encoding of the
+ * contents of the dynamic string is correct; this is the caller's
+ * responsibility to enforce.
+ *
+ * Results:
+ * The newly-allocated untyped (i.e., typePtr==NULL) Tcl_Obj with a
+ * reference count of zero.
+ *
+ * Side effects:
+ * The string is "moved" to the object. dsPtr is reinitialized to an
+ * empty string; it does not need to be Tcl_DStringFree'd after this if
+ * not used further.
+ *
+ *----------------------------------------------------------------------
+ */
+
+Tcl_Obj *
+TclDStringToObj(
+ Tcl_DString *dsPtr)
+{
+ Tcl_Obj *result;
+
+ if (dsPtr->length == 0) {
+ TclNewObj(result);
+ } else if (dsPtr->string == dsPtr->staticSpace) {
+ /*
+ * Static buffer, so must copy.
+ */
+
+ TclNewStringObj(result, dsPtr->string, dsPtr->length);
+ } else {
+ /*
+ * Dynamic buffer, so transfer ownership and reset.
+ */
+
+ TclNewObj(result);
+ result->bytes = dsPtr->string;
+ result->length = dsPtr->length;
+ }
+
+ /*
+ * Re-establish the DString as empty with no buffer allocated.
+ */
+
+ dsPtr->string = dsPtr->staticSpace;
+ dsPtr->spaceAvl = TCL_DSTRING_STATIC_SIZE;
+ dsPtr->length = 0;
+ dsPtr->staticSpace[0] = '\0';
+
+ return result;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
* Tcl_DStringStartSublist --
*
* This function adds the necessary information to a dynamic string
@@ -2735,9 +2824,9 @@ Tcl_DStringStartSublist(
Tcl_DString *dsPtr) /* Dynamic string. */
{
if (TclNeedSpace(dsPtr->string, dsPtr->string + dsPtr->length)) {
- Tcl_DStringAppend(dsPtr, " {", -1);
+ TclDStringAppendLiteral(dsPtr, " {");
} else {
- Tcl_DStringAppend(dsPtr, "{", -1);
+ TclDStringAppendLiteral(dsPtr, "{");
}
}
@@ -2763,7 +2852,7 @@ void
Tcl_DStringEndSublist(
Tcl_DString *dsPtr) /* Dynamic string. */
{
- Tcl_DStringAppend(dsPtr, "}", -1);
+ TclDStringAppendLiteral(dsPtr, "}");
}
/*
@@ -3293,16 +3382,10 @@ TclGetIntForIndex(
parseError:
if (interp != NULL) {
- /*
- * The result might not be empty; this resets it which should be both
- * a cheap operation, and of little problem because this is an
- * error-generation path anyway.
- */
-
bytes = Tcl_GetString(objPtr);
- Tcl_ResetResult(interp);
- Tcl_AppendResult(interp, "bad index \"", bytes,
- "\": must be integer?[+-]integer? or end?[+-]integer?", NULL);
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "bad index \"%s\": must be integer?[+-]integer? or"
+ " end?[+-]integer?", bytes));
if (!strncmp(bytes, "end-", 4)) {
bytes += 4;
}
@@ -3337,10 +3420,10 @@ static void
UpdateStringOfEndOffset(
register Tcl_Obj *objPtr)
{
- char buffer[TCL_INTEGER_SPACE + sizeof("end") + 1];
+ char buffer[TCL_INTEGER_SPACE + 5];
register int len;
- memcpy(buffer, "end", sizeof("end") + 1);
+ memcpy(buffer, "end", 4);
len = sizeof("end") - 1;
if (objPtr->internalRep.longValue != 0) {
buffer[len++] = '-';
@@ -3394,9 +3477,8 @@ SetEndOffsetFromAny(
if ((*bytes != 'e') || (strncmp(bytes, "end",
(size_t)((length > 3) ? 3 : length)) != 0)) {
if (interp != NULL) {
- Tcl_ResetResult(interp);
- Tcl_AppendResult(interp, "bad index \"", bytes,
- "\": must be end?[+-]integer?", NULL);
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "bad index \"%s\": must be end?[+-]integer?", bytes));
Tcl_SetErrorCode(interp, "TCL", "VALUE", "INDEX", NULL);
}
return TCL_ERROR;
@@ -3430,9 +3512,8 @@ SetEndOffsetFromAny(
badIndexFormat:
if (interp != NULL) {
- Tcl_ResetResult(interp);
- Tcl_AppendResult(interp, "bad index \"", bytes,
- "\": must be end?[+-]integer?", NULL);
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "bad index \"%s\": must be end?[+-]integer?", bytes));
Tcl_SetErrorCode(interp, "TCL", "VALUE", "INDEX", NULL);
}
return TCL_ERROR;
@@ -3508,8 +3589,8 @@ TclCheckBadOctal(
* be added to an existing error message as extra info.
*/
- Tcl_AppendResult(interp, " (looks like invalid octal number)",
- NULL);
+ Tcl_AppendToObj(Tcl_GetObjResult(interp),
+ " (looks like invalid octal number)", -1);
}
return 1;
}
@@ -4125,7 +4206,7 @@ TclReToGlob(
invalidGlob:
if (interp != NULL) {
- Tcl_AppendResult(interp, msg, NULL);
+ Tcl_SetObjResult(interp, Tcl_NewStringObj(msg, -1));
Tcl_SetErrorCode(interp, "TCL", "RE2GLOB", code, NULL);
}
Tcl_DStringFree(dsPtr);
diff --git a/generic/tclVar.c b/generic/tclVar.c
index e92dc5f..e31e9cf 100644
--- a/generic/tclVar.c
+++ b/generic/tclVar.c
@@ -3065,7 +3065,8 @@ ArrayStartSearchCmd(
if ((varPtr == NULL) || !TclIsVarArray(varPtr)
|| TclIsVarUndefined(varPtr)) {
- Tcl_AppendResult(interp, "\"", varName, "\" isn't an array", NULL);
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "\"%s\" isn't an array", varName));
Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "ARRAY", varName, NULL);
return TCL_ERROR;
}
@@ -3160,8 +3161,8 @@ ArrayAnyMoreCmd(
if ((varPtr == NULL) || !TclIsVarArray(varPtr)
|| TclIsVarUndefined(varPtr)) {
- Tcl_AppendResult(interp, "\"", TclGetString(varNameObj),
- "\" isn't an array", NULL);
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "\"%s\" isn't an array", TclGetString(varNameObj)));
Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "ARRAY",
TclGetString(varNameObj), NULL);
return TCL_ERROR;
@@ -3266,8 +3267,8 @@ ArrayNextElementCmd(
if ((varPtr == NULL) || !TclIsVarArray(varPtr)
|| TclIsVarUndefined(varPtr)) {
- Tcl_AppendResult(interp, "\"", TclGetString(varNameObj),
- "\" isn't an array", NULL);
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "\"%s\" isn't an array", TclGetString(varNameObj)));
Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "ARRAY",
TclGetString(varNameObj), NULL);
return TCL_ERROR;
@@ -3376,8 +3377,8 @@ ArrayDoneSearchCmd(
if ((varPtr == NULL) || !TclIsVarArray(varPtr)
|| TclIsVarUndefined(varPtr)) {
- Tcl_AppendResult(interp, "\"", TclGetString(varNameObj),
- "\" isn't an array", NULL);
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "\"%s\" isn't an array", TclGetString(varNameObj)));
Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "ARRAY",
TclGetString(varNameObj), NULL);
return TCL_ERROR;
@@ -4019,8 +4020,8 @@ ArrayStatsCmd(
if ((varPtr == NULL) || !TclIsVarArray(varPtr)
|| TclIsVarUndefined(varPtr)) {
- Tcl_AppendResult(interp, "\"", TclGetString(varNameObj),
- "\" isn't an array", NULL);
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "\"%s\" isn't an array", TclGetString(varNameObj)));
Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "ARRAY",
TclGetString(varNameObj), NULL);
return TCL_ERROR;
@@ -4028,7 +4029,8 @@ ArrayStatsCmd(
stats = Tcl_HashStats((Tcl_HashTable *) varPtr->value.tablePtr);
if (stats == NULL) {
- Tcl_SetResult(interp, "error reading array statistics", TCL_STATIC);
+ Tcl_SetObjResult(interp, Tcl_NewStringObj(
+ "error reading array statistics", -1));
return TCL_ERROR;
}
Tcl_SetObjResult(interp, Tcl_NewStringObj(stats, -1));
@@ -4317,10 +4319,10 @@ ObjMakeUpvar(
|| (varFramePtr == NULL)
|| !HasLocalVars(varFramePtr)
|| (strstr(TclGetString(myNamePtr), "::") != NULL))) {
- Tcl_AppendResult((Tcl_Interp *) iPtr, "bad variable name \"",
- TclGetString(myNamePtr), "\": upvar won't create "
+ Tcl_SetObjResult((Tcl_Interp *) iPtr, Tcl_ObjPrintf(
+ "bad variable name \"%s\": upvar won't create "
"namespace variable that refers to procedure variable",
- NULL);
+ TclGetString(myNamePtr)));
Tcl_SetErrorCode(interp, "TCL", "UPVAR", "INVERTED", NULL);
return TCL_ERROR;
}
@@ -4418,9 +4420,10 @@ TclPtrObjMakeUpvar(
* myName looks like an array reference.
*/
- Tcl_AppendResult((Tcl_Interp *) iPtr, "bad variable name \"",
- myName, "\": upvar won't create a scalar variable "
- "that looks like an array element", NULL);
+ Tcl_SetObjResult((Tcl_Interp *) iPtr, Tcl_ObjPrintf(
+ "bad variable name \"%s\": upvar won't create a"
+ " scalar variable that looks like an array element",
+ myName));
Tcl_SetErrorCode(interp, "TCL", "UPVAR", "LOCAL_ELEMENT",
NULL);
return TCL_ERROR;
@@ -4447,15 +4450,15 @@ TclPtrObjMakeUpvar(
}
if (varPtr == otherPtr) {
- Tcl_SetResult((Tcl_Interp *) iPtr,
- "can't upvar from variable to itself", TCL_STATIC);
+ Tcl_SetObjResult((Tcl_Interp *) iPtr, Tcl_NewStringObj(
+ "can't upvar from variable to itself", -1));
Tcl_SetErrorCode(interp, "TCL", "UPVAR", "SELF", NULL);
return TCL_ERROR;
}
if (TclIsVarTraced(varPtr)) {
- Tcl_AppendResult((Tcl_Interp *) iPtr, "variable \"", myName,
- "\" has traces: can't use for upvar", NULL);
+ Tcl_SetObjResult((Tcl_Interp *) iPtr, Tcl_ObjPrintf(
+ "variable \"%s\" has traces: can't use for upvar", myName));
Tcl_SetErrorCode(interp, "TCL", "UPVAR", "TRACED", NULL);
return TCL_ERROR;
} else if (!TclIsVarUndefined(varPtr)) {
@@ -4469,8 +4472,8 @@ TclPtrObjMakeUpvar(
*/
if (!TclIsVarLink(varPtr)) {
- Tcl_AppendResult((Tcl_Interp *) iPtr, "variable \"", myName,
- "\" already exists", NULL);
+ Tcl_SetObjResult((Tcl_Interp *) iPtr, Tcl_ObjPrintf(
+ "variable \"%s\" already exists", myName));
Tcl_SetErrorCode(interp, "TCL", "UPVAR", "EXISTS", NULL);
return TCL_ERROR;
}
@@ -4968,8 +4971,8 @@ Tcl_UpvarObjCmd(
* for this particular case.
*/
- Tcl_AppendResult(interp, "bad level \"", TclGetString(levelObj), "\"",
- NULL);
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "bad level \"%s\"", TclGetString(levelObj)));
Tcl_SetErrorCode(interp, "TCL", "VALUE", "LEVEL", NULL);
return TCL_ERROR;
}
@@ -4978,8 +4981,8 @@ Tcl_UpvarObjCmd(
* We've now finished with parsing levels; skip to the variable names.
*/
- objc -= hasLevel+1;
- objv += hasLevel+1;
+ objc -= hasLevel + 1;
+ objv += hasLevel + 1;
/*
* Iterate over each (other variable, local variable) pair. Divide the
@@ -5060,8 +5063,8 @@ SetArraySearchObj(
return TCL_OK;
syntax:
- Tcl_AppendResult(interp, "illegal search identifier \"", string, "\"",
- NULL);
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "illegal search identifier \"%s\"", string));
Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "ARRAYSEARCH", string, NULL);
return TCL_ERROR;
}
@@ -5126,10 +5129,9 @@ ParseSearchId(
*/
if (strcmp(string+offset, varName) != 0) {
- Tcl_AppendResult(interp, "search identifier \"", string,
- "\" isn't for variable \"", varName, "\"", NULL);
- Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "ARRAYSEARCH", string,
- NULL);
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "search identifier \"%s\" isn't for variable \"%s\"",
+ string, varName));
goto badLookup;
}
@@ -5153,7 +5155,8 @@ ParseSearchId(
}
}
}
- Tcl_AppendResult(interp, "couldn't find search \"", string, "\"", NULL);
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "couldn't find search \"%s\"", string));
badLookup:
Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "ARRAYSEARCH", string, NULL);
return NULL;
@@ -5894,8 +5897,8 @@ ObjFindNamespaceVar(
Tcl_DecrRefCount(simpleNamePtr);
}
if ((varPtr == NULL) && (flags & TCL_LEAVE_ERR_MSG)) {
- Tcl_ResetResult(interp);
- Tcl_AppendResult(interp, "unknown variable \"", name, "\"", NULL);
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "unknown variable \"%s\"", name));
Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "VARIABLE", name, NULL);
}
return (Tcl_Var) varPtr;
diff --git a/generic/tclZlib.c b/generic/tclZlib.c
index 341f8e0..544fb6e 100644
--- a/generic/tclZlib.c
+++ b/generic/tclZlib.c
@@ -17,6 +17,16 @@
#include "tclInt.h"
#ifdef HAVE_ZLIB
#include <zlib.h>
+#include "tclIO.h"
+
+/*
+ * The version of the zlib "package" that this implements. Note that this
+ * thoroughly supersedes the versions included with tclkit, which are "1.1",
+ * so this is at least "2.0" (there's no general *commitment* to have the same
+ * interface, even if that is mostly true).
+ */
+
+#define TCL_ZLIB_VERSION "2.0"
/*
* Magic flags used with wbits fields to indicate that we're handling the gzip
@@ -90,6 +100,7 @@ typedef struct {
GzipHeader outHeader; /* Header to write to an output stream, when
* compressing a gzip stream. */
Tcl_TimerToken timer; /* Timer used for keeping events fresh. */
+ Tcl_DString decompressed; /* Buffer for decompression results. */
} ZlibChannelData;
/*
@@ -112,13 +123,6 @@ typedef struct {
#define DEFAULT_BUFFER_SIZE 4096
/*
- * Time to wait (in milliseconds) before flushing the channel when reading
- * data through the transform.
- */
-
-#define TRANSFORM_FLUSH_DELAY 5
-
-/*
* Prototypes for private procedures defined later in this file:
*/
@@ -127,7 +131,7 @@ static Tcl_DriverBlockModeProc ZlibTransformBlockMode;
static Tcl_DriverCloseProc ZlibTransformClose;
static Tcl_DriverGetHandleProc ZlibTransformGetHandle;
static Tcl_DriverGetOptionProc ZlibTransformGetOption;
-static Tcl_DriverHandlerProc ZlibTransformHandler;
+static Tcl_DriverHandlerProc ZlibTransformEventHandler;
static Tcl_DriverInputProc ZlibTransformInput;
static Tcl_DriverOutputProc ZlibTransformOutput;
static Tcl_DriverSetOptionProc ZlibTransformSetOption;
@@ -139,13 +143,16 @@ static void ConvertError(Tcl_Interp *interp, int code);
static void ExtractHeader(gz_header *headerPtr, Tcl_Obj *dictObj);
static int GenerateHeader(Tcl_Interp *interp, Tcl_Obj *dictObj,
GzipHeader *headerPtr, int *extraSizePtr);
+static inline int ResultCopy(ZlibChannelData *cd, char *buf,
+ int toRead);
+static int ResultGenerate(ZlibChannelData *cd, int n, int flush,
+ int *errorCodePtr);
static Tcl_Channel ZlibStackChannelTransform(Tcl_Interp *interp,
int mode, int format, int level,
Tcl_Channel channel, Tcl_Obj *gzipHeaderDictPtr);
static void ZlibStreamCleanup(ZlibStreamHandle *zshPtr);
-static void ZlibTransformTimerKill(ZlibChannelData *cd);
+static inline void ZlibTransformEventTimerKill(ZlibChannelData *cd);
static void ZlibTransformTimerRun(ClientData clientData);
-static void ZlibTransformTimerSetup(ZlibChannelData *cd);
/*
* Type of zlib-based compressing and decompressing channels.
@@ -165,7 +172,7 @@ static const Tcl_ChannelType zlibChannelType = {
NULL, /* close2Proc */
ZlibTransformBlockMode,
NULL, /* flushProc */
- ZlibTransformHandler,
+ ZlibTransformEventHandler,
NULL, /* wideSeekProc */
NULL,
NULL
@@ -399,9 +406,7 @@ ExtractHeader(
Tcl_ExternalToUtfDString(latin1enc, (char *) headerPtr->comment, -1,
&tmp);
- SetValue(dictObj, "comment", Tcl_NewStringObj(Tcl_DStringValue(&tmp),
- Tcl_DStringLength(&tmp)));
- Tcl_DStringFree(&tmp);
+ SetValue(dictObj, "comment", TclDStringToObj(&tmp));
}
SetValue(dictObj, "crc", Tcl_NewBooleanObj(headerPtr->hcrc));
if (headerPtr->name != Z_NULL) {
@@ -418,9 +423,7 @@ ExtractHeader(
Tcl_ExternalToUtfDString(latin1enc, (char *) headerPtr->name, -1,
&tmp);
- SetValue(dictObj, "filename", Tcl_NewStringObj(Tcl_DStringValue(&tmp),
- Tcl_DStringLength(&tmp)));
- Tcl_DStringFree(&tmp);
+ SetValue(dictObj, "filename", TclDStringToObj(&tmp));
}
if (headerPtr->os != 255) {
SetValue(dictObj, "os", Tcl_NewIntObj(headerPtr->os));
@@ -543,6 +546,7 @@ Tcl_ZlibStreamInit(
zshPtr->currentInput = NULL;
zshPtr->streamEnd = 0;
memset(&zshPtr->stream, 0, sizeof(z_stream));
+ zshPtr->stream.adler = 1;
/*
* No output buffer available yet
@@ -569,13 +573,12 @@ Tcl_ZlibStreamInit(
goto error;
}
Tcl_DStringInit(&cmdname);
- Tcl_DStringAppend(&cmdname, "::tcl::zlib::streamcmd_", -1);
- Tcl_DStringAppend(&cmdname, Tcl_GetString(Tcl_GetObjResult(interp)),
- -1);
+ TclDStringAppendLiteral(&cmdname, "::tcl::zlib::streamcmd_");
+ TclDStringAppendObj(&cmdname, Tcl_GetObjResult(interp));
if (Tcl_GetCommandInfo(interp, Tcl_DStringValue(&cmdname),
&cmdinfo) == 1) {
- Tcl_SetResult(interp,
- "BUG: Stream command name already exists", TCL_STATIC);
+ Tcl_SetObjResult(interp, Tcl_NewStringObj(
+ "BUG: Stream command name already exists", -1));
Tcl_SetErrorCode(interp, "TCL", "BUG", "EXISTING_CMD", NULL);
Tcl_DStringFree(&cmdname);
goto error;
@@ -897,8 +900,8 @@ Tcl_ZlibStreamPut(
if (zshPtr->streamEnd) {
if (zshPtr->interp) {
- Tcl_SetResult(zshPtr->interp,
- "already past compressed stream end", TCL_STATIC);
+ Tcl_SetObjResult(zshPtr->interp, Tcl_NewStringObj(
+ "already past compressed stream end", -1));
Tcl_SetErrorCode(zshPtr->interp, "TCL", "ZIP", "CLOSED", NULL);
}
return TCL_ERROR;
@@ -1082,9 +1085,9 @@ Tcl_ZlibStreamGet(
if (zshPtr->stream.avail_in > 0) {
if (zshPtr->interp) {
- Tcl_SetResult(zshPtr->interp,
- "Unexpected zlib internal state during decompression",
- TCL_STATIC);
+ Tcl_SetObjResult(zshPtr->interp, Tcl_NewStringObj(
+ "unexpected zlib internal state during"
+ " decompression", -1));
Tcl_SetErrorCode(zshPtr->interp, "TCL", "ZIP", "STATE",
NULL);
}
@@ -1893,7 +1896,7 @@ ZlibCmd(
format = TCL_ZLIB_FORMAT_GZIP;
break;
default:
- Tcl_AppendResult(interp, "IMPOSSIBLE", NULL);
+ Tcl_SetObjResult(interp, Tcl_NewStringObj("impossible!", -1));
return TCL_ERROR;
}
@@ -1907,16 +1910,16 @@ ZlibCmd(
*/
if (mode == TCL_ZLIB_STREAM_DEFLATE && !(chanMode & TCL_WRITABLE)) {
- Tcl_AppendResult(interp,
+ Tcl_SetObjResult(interp, Tcl_NewStringObj(
"compression may only be applied to writable channels",
- NULL);
+ -1));
Tcl_SetErrorCode(interp, "TCL", "ZIP", "UNWRITABLE", NULL);
return TCL_ERROR;
}
if (mode == TCL_ZLIB_STREAM_INFLATE && !(chanMode & TCL_READABLE)) {
- Tcl_AppendResult(interp,
+ Tcl_SetObjResult(interp, Tcl_NewStringObj(
"decompression may only be applied to readable channels",
- NULL);
+ -1));
Tcl_SetErrorCode(interp, "TCL", "ZIP", "UNREADABLE", NULL);
return TCL_ERROR;
}
@@ -1934,8 +1937,8 @@ ZlibCmd(
switch ((enum pushOptions) option) {
case poHeader:
if (++i > objc-1) {
- Tcl_AppendResult(interp,
- "value missing for -header option", NULL);
+ Tcl_SetObjResult(interp, Tcl_NewStringObj(
+ "value missing for -header option", -1));
Tcl_SetErrorCode(interp, "TCL", "ZIP", "NOVAL", NULL);
return TCL_ERROR;
}
@@ -1947,8 +1950,8 @@ ZlibCmd(
break;
case poLevel:
if (++i > objc-1) {
- Tcl_AppendResult(interp,
- "value missing for -level option", NULL);
+ Tcl_SetObjResult(interp, Tcl_NewStringObj(
+ "value missing for -level option", -1));
Tcl_SetErrorCode(interp, "TCL", "ZIP", "NOVAL", NULL);
return TCL_ERROR;
}
@@ -1964,8 +1967,8 @@ ZlibCmd(
break;
case poLimit:
if (++i > objc-1) {
- Tcl_AppendResult(interp,
- "value missing for -limit option", NULL);
+ Tcl_SetObjResult(interp, Tcl_NewStringObj(
+ "value missing for -limit option", -1));
Tcl_SetErrorCode(interp, "TCL", "ZIP", "NOVAL", NULL);
return TCL_ERROR;
}
@@ -1993,14 +1996,15 @@ ZlibCmd(
return TCL_ERROR;
badLevel:
- Tcl_AppendResult(interp, "level must be 0 to 9", NULL);
+ Tcl_SetObjResult(interp, Tcl_NewStringObj("level must be 0 to 9", -1));
Tcl_SetErrorCode(interp, "TCL", "VALUE", "COMPRESSIONLEVEL", NULL);
if (extraInfoStr) {
Tcl_AddErrorInfo(interp, extraInfoStr);
}
return TCL_ERROR;
badBuffer:
- Tcl_AppendResult(interp, "buffer size must be 32 to 65536", NULL);
+ Tcl_SetObjResult(interp, Tcl_NewStringObj(
+ "buffer size must be 32 to 65536", -1));
Tcl_SetErrorCode(interp, "TCL", "VALUE", "BUFFERSIZE", NULL);
return TCL_ERROR;
}
@@ -2083,9 +2087,9 @@ ZlibStreamCmd(
break;
case ao_buffer: /* -buffer */
if (i == objc-2) {
- Tcl_AppendResult(interp, "\"-buffer\" option must be "
- "followed by integer decompression buffersize",
- NULL);
+ Tcl_SetObjResult(interp, Tcl_NewStringObj(
+ "\"-buffer\" option must be followed by integer"
+ " decompression buffersize", -1));
Tcl_SetErrorCode(interp, "TCL", "ZIP", "NOVAL", NULL);
return TCL_ERROR;
}
@@ -2094,8 +2098,8 @@ ZlibStreamCmd(
return TCL_ERROR;
}
if (buffersize < 1 || buffersize > 65536) {
- Tcl_AppendResult(interp,
- "buffer size must be 32 to 65536", NULL);
+ Tcl_SetObjResult(interp, Tcl_NewStringObj(
+ "buffer size must be 32 to 65536", -1));
Tcl_SetErrorCode(interp, "TCL", "VALUE", "BUFFERSIZE",
NULL);
return TCL_ERROR;
@@ -2103,8 +2107,9 @@ ZlibStreamCmd(
}
if (flush == -2) {
- Tcl_AppendResult(interp, "\"-flush\", \"-fullflush\" and "
- "\"-finalize\" options are mutually exclusive", NULL);
+ Tcl_SetObjResult(interp, Tcl_NewStringObj(
+ "\"-flush\", \"-fullflush\" and \"-finalize\" options"
+ " are mutually exclusive", -1));
Tcl_SetErrorCode(interp, "TCL", "ZIP", "EXCLUSIVE", NULL);
return TCL_ERROR;
}
@@ -2155,13 +2160,14 @@ ZlibStreamCmd(
}
break;
case ao_buffer:
- Tcl_AppendResult(interp,
- "\"-buffer\" option not supported here", NULL);
+ Tcl_SetObjResult(interp, Tcl_NewStringObj(
+ "\"-buffer\" option not supported here", -1));
return TCL_ERROR;
}
if (flush == -2) {
- Tcl_AppendResult(interp, "\"-flush\", \"-fullflush\" and "
- "\"-finalize\" options are mutually exclusive", NULL);
+ Tcl_SetObjResult(interp, Tcl_NewStringObj(
+ "\"-flush\", \"-fullflush\" and \"-finalize\" options"
+ " are mutually exclusive", -1));
Tcl_SetErrorCode(interp, "TCL", "ZIP", "EXCLUSIVE", NULL);
return TCL_ERROR;
}
@@ -2263,6 +2269,12 @@ ZlibStreamCmd(
*----------------------------------------------------------------------
* Set of functions to support channel stacking.
*----------------------------------------------------------------------
+ *
+ * ZlibTransformClose --
+ *
+ * How to shut down a stacked compressing/decompressing transform.
+ *
+ *----------------------------------------------------------------------
*/
static int
@@ -2277,7 +2289,7 @@ ZlibTransformClose(
* Delete the support timer.
*/
- ZlibTransformTimerKill(cd);
+ ZlibTransformEventTimerKill(cd);
/*
* Flush any data waiting to be compressed.
@@ -2305,9 +2317,9 @@ ZlibTransformClose(
* then interp may be NULL */
if (!TclInThreadExit()) {
if (interp) {
- Tcl_AppendResult(interp,
- "error while finalizing file: ",
- Tcl_PosixError(interp), NULL);
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "error while finalizing file: %s",
+ Tcl_PosixError(interp)));
}
}
result = TCL_ERROR;
@@ -2324,6 +2336,8 @@ ZlibTransformClose(
* Release all memory.
*/
+ Tcl_DStringFree(&cd->decompressed);
+
if (cd->inBuffer) {
ckfree(cd->inBuffer);
cd->inBuffer = NULL;
@@ -2335,6 +2349,16 @@ ZlibTransformClose(
ckfree(cd);
return result;
}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * ZlibTransformInput --
+ *
+ * Reader filter that does decompression.
+ *
+ *----------------------------------------------------------------------
+ */
static int
ZlibTransformInput(
@@ -2346,78 +2370,144 @@ ZlibTransformInput(
ZlibChannelData *cd = instanceData;
Tcl_DriverInputProc *inProc =
Tcl_ChannelInputProc(Tcl_GetChannelType(cd->parent));
- int e, readBytes, flush = Z_NO_FLUSH;
+ int readBytes, gotBytes, copied;
if (cd->mode == TCL_ZLIB_STREAM_DEFLATE) {
return inProc(Tcl_GetChannelInstanceData(cd->parent), buf, toRead,
errorCodePtr);
}
- cd->inStream.next_out = (Bytef *) buf;
- cd->inStream.avail_out = toRead;
- if (cd->inStream.next_in == NULL) {
- goto doReadFirst;
- }
- while (1) {
- e = inflate(&cd->inStream, flush);
- if ((e == Z_STREAM_END) || (e==Z_OK && cd->inStream.avail_out==0)) {
- return toRead - cd->inStream.avail_out;
- }
-
+ gotBytes = 0;
+ while (toRead > 0) {
/*
- * Z_BUF_ERROR can be ignored as per http://www.zlib.net/zlib_how.html
- *
- * Just indicates that the zlib couldn't consume input/produce output,
- * and is fixed by supplying more input.
+ * Loop until the request is satisfied (or no data available from
+ * below, possibly EOF).
*/
- if ((e != Z_OK) && (e != Z_BUF_ERROR)) {
- Tcl_Obj *errObj = Tcl_NewListObj(0, NULL);
+ copied = ResultCopy(cd, buf, toRead);
+ toRead -= copied;
+ buf += copied;
+ gotBytes += copied;
- Tcl_ListObjAppendElement(NULL, errObj,
- Tcl_NewStringObj(cd->inStream.msg, -1));
- Tcl_SetChannelError(cd->parent, errObj);
- *errorCodePtr = EINVAL;
- return -1;
+ if (toRead == 0) {
+ return gotBytes;
}
/*
- * Check if the inflate stopped early.
+ * The buffer is exhausted, but the caller wants even more. We now
+ * have to go to the underlying channel, get more bytes and then
+ * transform them for delivery. We may not get what we want (full EOF
+ * or temporarily out of data).
+ *
+ * Length (cd->decompressed) == 0, toRead > 0 here.
+ *
+ * The zlib transform allows us to read at most one character from the
+ * underlying channel to properly identify Z_STREAM_END without
+ * reading over the border.
*/
- if (cd->inStream.avail_in > 0) {
- continue;
- }
-
- /*
- * Emptied the buffer of data from the underlying channel. Get some
- * more.
- */
+ readBytes = Tcl_ReadRaw(cd->parent, cd->inBuffer, 1);
- doReadFirst:
/*
- * Hack for Bug 2762041. Disable pre-reading of lots of input, read
- * only one character. This way the Z_END_OF_STREAM can be read
- * without triggering an EOF in the base channel. The higher input
- * loops in DoReadChars() would react to that by stopping, despite the
- * transform still having data which could be read.
- *
- * This is only a hack because other transforms may not be able to
- * work around the general problem in this way.
+ * Three cases here:
+ * 1. Got some data from the underlying channel (readBytes > 0) so
+ * it should be fed through the decompression engine.
+ * 2. Got an error (readBytes < 0) which we should report up except
+ * for the case where we can convert it to a short read.
+ * 3. Got an end-of-data from EOF or blocking (readBytes == 0). If
+ * it is EOF, try flushing the data out of the decompressor.
*/
- readBytes = Tcl_ReadRaw(cd->parent, cd->inBuffer, 1);
if (readBytes < 0) {
+ /*
+ * Report errors to caller. The state of the seek system is
+ * unchanged!
+ */
+
+ if ((Tcl_GetErrno() == EAGAIN) && (gotBytes > 0)) {
+ /*
+ * EAGAIN is a special situation. If we had some data before
+ * we report that instead of the request to re-try.
+ */
+
+ return gotBytes;
+ }
+
*errorCodePtr = Tcl_GetErrno();
return -1;
} else if (readBytes == 0) {
- flush = Z_SYNC_FLUSH;
- }
+ /*
+ * Check wether we hit on EOF in 'parent' or not. If not,
+ * differentiate between blocking and non-blocking modes. In
+ * non-blocking mode we ran temporarily out of data. Signal this
+ * to the caller via EWOULDBLOCK and error return (-1). In the
+ * other cases we simply return what we got and let the caller
+ * wait for more. On the other hand, if we got an EOF we have to
+ * convert and flush all waiting partial data.
+ */
+
+ if (!Tcl_Eof(cd->parent)) {
+ /*
+ * The state of the seek system is unchanged!
+ */
+
+ if ((gotBytes == 0) && (cd->flags & ASYNC)) {
+ *errorCodePtr = EWOULDBLOCK;
+ return -1;
+ }
+ return gotBytes;
+ }
+
+ /*
+ * (Semi-)Eof in parent.
+ *
+ * Now this is a bit different. The partial data waiting is
+ * converted and returned.
+ */
+
+ if (ResultGenerate(cd, 0, Z_SYNC_FLUSH, errorCodePtr) != TCL_OK) {
+ return -1;
+ }
+
+ if (Tcl_DStringLength(&cd->decompressed) == 0) {
+ /*
+ * The drain delivered nothing. Time to deliver what we've
+ * got.
+ */
+
+ return gotBytes;
+ }
+
+ /*
+ * Reset eof, force caller to drain result buffer.
+ */
+
+ ((Channel *) cd->parent)->state->flags &= ~CHANNEL_EOF;
+ } else /* readBytes > 0 */ {
+ /*
+ * Transform the read chunk, which was not empty. Anything we get
+ * back is a transformation result to be put into our buffers, and
+ * the next iteration will put it into the result.
+ */
- cd->inStream.next_in = (Bytef *) cd->inBuffer;
- cd->inStream.avail_in = readBytes;
+ if (ResultGenerate(cd, readBytes, Z_NO_FLUSH,
+ errorCodePtr) != TCL_OK) {
+ return -1;
+ }
+ }
}
+ return gotBytes;
}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * ZlibTransformOutput --
+ *
+ * Writer filter that does compression.
+ *
+ *----------------------------------------------------------------------
+ */
static int
ZlibTransformOutput(
@@ -2462,6 +2552,16 @@ ZlibTransformOutput(
return toWrite - cd->outStream.avail_in;
}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * ZlibTransformSetOption --
+ *
+ * Writing side of [fconfigure] on our channel.
+ *
+ *----------------------------------------------------------------------
+ */
static int
ZlibTransformSetOption( /* not used */
@@ -2484,8 +2584,9 @@ ZlibTransformSetOption( /* not used */
} else if (value[0] == 's' && strcmp(value, "sync") == 0) {
flushType = Z_SYNC_FLUSH;
} else {
- Tcl_AppendResult(interp, "unknown -flush type \"", value,
- "\": must be full or sync", NULL);
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "unknown -flush type \"%s\": must be full or sync",
+ value));
Tcl_SetErrorCode(interp, "TCL", "VALUE", "FLUSH", NULL);
return TCL_ERROR;
}
@@ -2512,9 +2613,10 @@ ZlibTransformSetOption( /* not used */
}
if (Tcl_WriteRaw(cd->parent, cd->outBuffer,
- cd->outStream.next_out - (Bytef*)cd->outBuffer) < 0) {
- Tcl_AppendResult(interp, "problem flushing channel: ",
- Tcl_PosixError(interp), NULL);
+ cd->outStream.next_out - (Bytef *) cd->outBuffer) < 0) {
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "problem flushing channel: %s",
+ Tcl_PosixError(interp)));
return TCL_ERROR;
}
}
@@ -2525,9 +2627,24 @@ ZlibTransformSetOption( /* not used */
return Tcl_BadChannelOption(interp, optionName, chanOptions);
}
+ /*
+ * Pass all unknown options down, to deeper transforms and/or the base
+ * channel.
+ */
+
return setOptionProc(Tcl_GetChannelInstanceData(cd->parent), interp,
optionName, value);
}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * ZlibTransformGetOption --
+ *
+ * Reading side of [fconfigure] on our channel.
+ *
+ *----------------------------------------------------------------------
+ */
static int
ZlibTransformGetOption(
@@ -2582,10 +2699,7 @@ ZlibTransformGetOption(
Tcl_DStringAppendElement(dsPtr, Tcl_GetString(tmpObj));
Tcl_DecrRefCount(tmpObj);
} else {
- int len;
- const char *str = Tcl_GetStringFromObj(tmpObj, &len);
-
- Tcl_DStringAppend(dsPtr, str, len);
+ TclDStringAppendObj(dsPtr, tmpObj);
Tcl_DecrRefCount(tmpObj);
return TCL_OK;
}
@@ -2604,6 +2718,17 @@ ZlibTransformGetOption(
}
return Tcl_BadChannelOption(interp, optionName, chanOptions);
}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * ZlibTransformWatch, ZlibTransformEventHandler --
+ *
+ * If we have data pending, trigger a readable event after a short time
+ * (in order to allow a real event to catch up).
+ *
+ *----------------------------------------------------------------------
+ */
static void
ZlibTransformWatch(
@@ -2619,63 +2744,28 @@ ZlibTransformWatch(
watchProc = Tcl_ChannelWatchProc(Tcl_GetChannelType(cd->parent));
watchProc(Tcl_GetChannelInstanceData(cd->parent), mask);
- if (!(mask & TCL_READABLE)
- || (cd->inStream.avail_in == (uInt) cd->inAllocated)) {
- ZlibTransformTimerKill(cd);
- } else {
- ZlibTransformTimerSetup(cd);
- }
-}
-
-static int
-ZlibTransformGetHandle(
- ClientData instanceData,
- int direction,
- ClientData *handlePtr)
-{
- ZlibChannelData *cd = instanceData;
-
- return Tcl_GetChannelHandle(cd->parent, direction, handlePtr);
-}
-static int
-ZlibTransformBlockMode(
- ClientData instanceData,
- int mode)
-{
- ZlibChannelData *cd = instanceData;
-
- if (mode == TCL_MODE_NONBLOCKING) {
- cd->flags |= ASYNC;
- } else {
- cd->flags &= ~ASYNC;
+ if (!(mask & TCL_READABLE) || Tcl_DStringLength(&cd->decompressed) == 0) {
+ ZlibTransformEventTimerKill(cd);
+ } else if (cd->timer == NULL) {
+ cd->timer = Tcl_CreateTimerHandler(SYNTHETIC_EVENT_TIME,
+ ZlibTransformTimerRun, cd);
}
- return TCL_OK;
}
static int
-ZlibTransformHandler(
+ZlibTransformEventHandler(
ClientData instanceData,
int interestMask)
{
ZlibChannelData *cd = instanceData;
- ZlibTransformTimerKill(cd);
+ ZlibTransformEventTimerKill(cd);
return interestMask;
}
-static void
-ZlibTransformTimerSetup(
- ZlibChannelData *cd)
-{
- if (cd->timer == NULL) {
- cd->timer = Tcl_CreateTimerHandler(TRANSFORM_FLUSH_DELAY,
- ZlibTransformTimerRun, cd);
- }
-}
-
-static void
-ZlibTransformTimerKill(
+static inline void
+ZlibTransformEventTimerKill(
ZlibChannelData *cd)
{
if (cd->timer != NULL) {
@@ -2697,6 +2787,53 @@ ZlibTransformTimerRun(
/*
*----------------------------------------------------------------------
*
+ * ZlibTransformGetHandle --
+ *
+ * Anything that needs the OS handle is told to get it from what we are
+ * stacked on top of.
+ *
+ *----------------------------------------------------------------------
+ */
+
+static int
+ZlibTransformGetHandle(
+ ClientData instanceData,
+ int direction,
+ ClientData *handlePtr)
+{
+ ZlibChannelData *cd = instanceData;
+
+ return Tcl_GetChannelHandle(cd->parent, direction, handlePtr);
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * ZlibTransformBlockMode --
+ *
+ * We need to keep track of the blocking mode; it changes our behavior.
+ *
+ *----------------------------------------------------------------------
+ */
+
+static int
+ZlibTransformBlockMode(
+ ClientData instanceData,
+ int mode)
+{
+ ZlibChannelData *cd = instanceData;
+
+ if (mode == TCL_MODE_NONBLOCKING) {
+ cd->flags |= ASYNC;
+ } else {
+ cd->flags &= ~ASYNC;
+ }
+ return TCL_OK;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
* ZlibStackChannelTransform --
*
* Stacks either compression or decompression onto a channel.
@@ -2808,6 +2945,8 @@ ZlibStackChannelTransform(
}
}
+ Tcl_DStringInit(&cd->decompressed);
+
chan = Tcl_StackChannel(interp, &zlibChannelType, cd,
Tcl_GetChannelMode(channel), channel);
if (chan == NULL) {
@@ -2833,6 +2972,150 @@ ZlibStackChannelTransform(
/*
*----------------------------------------------------------------------
+ *
+ * ResultCopy --
+ *
+ * Copies the requested number of bytes from the buffer into the
+ * specified array and removes them from the buffer afterward. Copies
+ * less if there is not enough data in the buffer.
+ *
+ * Side effects:
+ * See above.
+ *
+ * Result:
+ * The number of actually copied bytes, possibly less than 'toRead'.
+ *
+ *----------------------------------------------------------------------
+ */
+
+static inline int
+ResultCopy(
+ ZlibChannelData *cd, /* The location of the buffer to read from. */
+ char *buf, /* The buffer to copy into */
+ int toRead) /* Number of requested bytes */
+{
+ int have = Tcl_DStringLength(&cd->decompressed);
+
+ if (have == 0) {
+ /*
+ * Nothing to copy in the case of an empty buffer.
+ */
+
+ return 0;
+ } else if (have > toRead) {
+ /*
+ * The internal buffer contains more than requested. Copy the
+ * requested subset to the caller, shift the remaining bytes down, and
+ * truncate.
+ */
+
+ char *src = Tcl_DStringValue(&cd->decompressed);
+
+ memcpy(buf, src, toRead);
+ memmove(src, src + toRead, have - toRead);
+
+ Tcl_DStringSetLength(&cd->decompressed, have - toRead);
+ return toRead;
+ } else /* have <= toRead */ {
+ /*
+ * There is just or not enough in the buffer to fully satisfy the
+ * caller, so take everything as best effort.
+ */
+
+ memcpy(buf, Tcl_DStringValue(&cd->decompressed), have);
+ TclDStringClear(&cd->decompressed);
+ return have;
+ }
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * ResultGenerate --
+ *
+ * Extract uncompressed bytes from the compression engine and store them
+ * in our working buffer.
+ *
+ * Result:
+ * TCL_OK/TCL_ERROR (with *errorCodePtr updated with reason).
+ *
+ * Side effects:
+ * See above.
+ *
+ *----------------------------------------------------------------------
+ */
+
+static int
+ResultGenerate(
+ ZlibChannelData *cd,
+ int n,
+ int flush,
+ int *errorCodePtr)
+{
+#define MAXBUF 1024
+ unsigned char buf[MAXBUF];
+ int e, written;
+
+ cd->inStream.next_in = (Bytef *) cd->inBuffer;
+ cd->inStream.avail_in = n;
+
+ while (1) {
+ cd->inStream.next_out = (Bytef *) buf;
+ cd->inStream.avail_out = MAXBUF;
+
+ e = inflate(&cd->inStream, flush);
+
+ /*
+ * avail_out is now the left over space in the output. Therefore
+ * "MAXBUF - avail_out" is the amount of bytes generated.
+ */
+
+ written = MAXBUF - cd->inStream.avail_out;
+ if (written) {
+ Tcl_DStringAppend(&cd->decompressed, (char *) buf, written);
+ }
+
+ /*
+ * The cases where we're definitely done.
+ */
+
+ if (((flush == Z_SYNC_FLUSH) && (e == Z_BUF_ERROR))
+ || (e == Z_STREAM_END)
+ || (e == Z_OK && cd->inStream.avail_out == 0)) {
+ return TCL_OK;
+ }
+
+ /*
+ * Z_BUF_ERROR can be ignored as per http://www.zlib.net/zlib_how.html
+ *
+ * Just indicates that the zlib couldn't consume input/produce output,
+ * and is fixed by supplying more input.
+ *
+ * Otherwise, we've got errors and need to report to higher-up.
+ */
+
+ if ((e != Z_OK) && (e != Z_BUF_ERROR)) {
+ Tcl_Obj *errObj = Tcl_NewListObj(0, NULL);
+
+ Tcl_ListObjAppendElement(NULL, errObj,
+ Tcl_NewStringObj(cd->inStream.msg, -1));
+ Tcl_SetChannelError(cd->parent, errObj);
+ *errorCodePtr = EINVAL;
+ return TCL_ERROR;
+ }
+
+ /*
+ * Check if the inflate stopped early.
+ */
+
+ if (cd->inStream.avail_in <= 0 && flush != Z_SYNC_FLUSH) {
+ return TCL_OK;
+ }
+ }
+}
+
+/*
+ *----------------------------------------------------------------------
* Finally, the TclZlibInit function. Used to install the zlib API.
*----------------------------------------------------------------------
*/
@@ -2854,7 +3137,7 @@ TclZlibInit(
*/
Tcl_CreateObjCommand(interp, "zlib", ZlibCmd, 0, 0);
- return TCL_OK;
+ return Tcl_PkgProvide(interp, "zlib", TCL_ZLIB_VERSION);
}
/*
@@ -2874,7 +3157,7 @@ Tcl_ZlibStreamInit(
Tcl_Obj *dictObj,
Tcl_ZlibStream *zshandle)
{
- Tcl_SetResult(interp, "unimplemented", TCL_STATIC);
+ Tcl_SetObjResult(interp, Tcl_NewStringObj("unimplemented", -1));
Tcl_SetErrorCode(interp, "TCL", "UNIMPLEMENTED", NULL);
return TCL_ERROR;
}
@@ -2940,7 +3223,7 @@ Tcl_ZlibDeflate(
int level,
Tcl_Obj *gzipHeaderDictObj)
{
- Tcl_SetResult(interp, "unimplemented", TCL_STATIC);
+ Tcl_SetObjResult(interp, Tcl_NewStringObj("unimplemented", -1));
Tcl_SetErrorCode(interp, "TCL", "UNIMPLEMENTED", NULL);
return TCL_ERROR;
}
@@ -2953,7 +3236,7 @@ Tcl_ZlibInflate(
int bufferSize,
Tcl_Obj *gzipHeaderDictObj)
{
- Tcl_SetResult(interp, "unimplemented", TCL_STATIC);
+ Tcl_SetObjResult(interp, Tcl_NewStringObj("unimplemented", -1));
Tcl_SetErrorCode(interp, "TCL", "UNIMPLEMENTED", NULL);
return TCL_ERROR;
}