summaryrefslogtreecommitdiffstats
diff options
context:
space:
mode:
Diffstat
-rw-r--r--ChangeLog25
-rw-r--r--changes6
-rw-r--r--generic/tclBasic.c52
-rw-r--r--generic/tclBinary.c43
-rw-r--r--generic/tclCompCmds.c8
-rw-r--r--generic/tclCompExpr.c101
-rw-r--r--generic/tclOOMethod.c50
-rw-r--r--generic/tclParse.c2
-rw-r--r--generic/tclTest.c22
-rw-r--r--generic/tclUtil.c3
-rw-r--r--library/auto.tcl69
-rw-r--r--library/tm.tcl9
-rw-r--r--tests/binary.test28
-rw-r--r--tests/error.test10
-rw-r--r--tests/oo.test30
-rw-r--r--tests/zlib.test21
-rw-r--r--unix/tclUnixFCmd.c4
-rw-r--r--unix/tclUnixSock.c2
18 files changed, 343 insertions, 142 deletions
diff --git a/ChangeLog b/ChangeLog
index 13fd83b..ee5d70b 100644
--- a/ChangeLog
+++ b/ChangeLog
@@ -1,4 +1,15 @@
-2013-08-30 Don Porter <dgp@users.sourceforge.net>
+A NOTE ON THE CHANGELOG:
+Starting in early 2011, Tcl source code has been under the management of
+fossil, hosted at http://core.tcl.tk/tcl/ . Fossil presents a "Timeline"
+view of changes made that is superior in every way to a hand edited log file.
+Because of this, many Tcl developers are now out of the habit of maintaining
+this log file. You may still find useful things in it, but the Timeline is
+a better first place to look now.
+============================================================================
+
+2013-09-16 Don Porter <dgp@users.sourceforge.net>
+
+ *** 8.6.1 TAGGED FOR RELEASE ***
* generic/tcl.h: Bump version number to 8.6.1.
* library/init.tcl:
@@ -10,6 +21,18 @@
* unix/configure: autoconf-2.59
* win/configure:
+2013-09-09 Donal Fellows <dkf@users.sf.net>
+
+ * generic/tclOOMethod.c (CloneProcedureMethod): [Bug 3609693]: Strip
+ the internal representation of method bodies during cloning in order
+ to ensure that any bound references to instance variables are removed.
+
+2013-09-01 Donal Fellows <dkf@users.sf.net>
+
+ * generic/tclBinary.c (BinaryDecodeHex): [Bug b98fa55285]: Ensure that
+ whitespace at the end of a string don't cause the decoder to drop the
+ last decoded byte.
+
2013-08-03 Donal Fellows <dkf@users.sf.net>
* library/auto.tcl: [Patch 3611643]: Allow TclOO classes to be found
diff --git a/changes b/changes
index 5428c3e..983c4ca 100644
--- a/changes
+++ b/changes
@@ -8290,6 +8290,10 @@ reported usage of large expressions (porter)
2013-09-01 (bug fix)[b98fa55] [binary decode] fail on whitespace (reche,fellows)
+2013-09-07 (bug fix)[86ceb4] have tm path favor first provider (neumann,porter)
+
+2013-09-09 (bug fix)[3609693] copied object member variable confusion (fellows)
+
Many optmizations, improvements, and tightened stack management in bytecode.
---- Released 8.6.1, Septemer 18, 2013 --- http://core.tcl.tk/tcl/ for details
+--- Released 8.6.1, Septemer 19, 2013 --- http://core.tcl.tk/tcl/ for details
diff --git a/generic/tclBasic.c b/generic/tclBasic.c
index 884b5cc..a41351e 100644
--- a/generic/tclBasic.c
+++ b/generic/tclBasic.c
@@ -2175,7 +2175,8 @@ Tcl_CreateCommand(
*
* Side effects:
* If a command named "cmdName" already exists for interp, it is
- * first deleted. Then the new command is created from the arguments.
+ * first deleted. Then the new command is created from the arguments.
+ * [***] (See below for exception).
*
* In the future, during bytecode evaluation when "cmdName" is seen as
* the name of a command by Tcl_EvalObj or Tcl_Eval, the object-based
@@ -2242,8 +2243,27 @@ Tcl_CreateObjCommand(
if (!isNew) {
cmdPtr = Tcl_GetHashValue(hPtr);
+ /* Command already exists. */
+
+ /*
+ * [***] This is wrong. See Tcl Bug a16752c252.
+ * However, this buggy behavior is kept under particular
+ * circumstances to accommodate deployed binaries of the
+ * "tclcompiler" program. http://sourceforge.net/projects/tclpro/
+ * that crash if the bug is fixed.
+ */
+
+ if (cmdPtr->objProc == TclInvokeStringCommand
+ && cmdPtr->clientData == clientData
+ && cmdPtr->deleteData == clientData
+ && cmdPtr->deleteProc == deleteProc) {
+ cmdPtr->objProc = proc;
+ cmdPtr->objClientData = clientData;
+ return (Tcl_Command) cmdPtr;
+ }
+
/*
- * Command already exists; delete it. Be careful to preserve any
+ * Otherwise, we delete the old command. Be careful to preserve any
* existing import links so we can restore them down below. That way,
* you can redefine a command and its import status will remain
* intact.
@@ -4679,6 +4699,15 @@ TEOV_RunEnterTraces(
TclCleanupCommandMacro(cmdPtr);
if (traceCode != TCL_OK) {
+ if (traceCode == TCL_ERROR) {
+ Tcl_Obj *info;
+
+ TclNewLiteralStringObj(info, "\n (enter trace on \"");
+ Tcl_AppendLimitedToObj(info, command, length, 55, "...");
+ Tcl_AppendToObj(info, "\")", 2);
+ Tcl_AppendObjToErrorInfo(interp, info);
+ iPtr->flags |= ERR_ALREADY_LOGGED;
+ }
return traceCode;
}
if (cmdEpoch != newEpoch) {
@@ -4699,12 +4728,10 @@ TEOV_RunLeaveTraces(
Tcl_Obj *commandPtr = data[1];
Command *cmdPtr = data[2];
Tcl_Obj **objv = data[3];
-
+ int length;
+ const char *command = Tcl_GetStringFromObj(commandPtr, &length);
if (!(cmdPtr->flags & CMD_IS_DELETED)) {
- int length;
- const char *command = Tcl_GetStringFromObj(commandPtr, &length);
-
if (cmdPtr->flags & CMD_HAS_EXEC_TRACES){
traceCode = TclCheckExecutionTraces(interp, command, length,
cmdPtr, result, TCL_TRACE_LEAVE_EXEC, objc, objv);
@@ -4714,7 +4741,6 @@ TEOV_RunLeaveTraces(
cmdPtr, result, TCL_TRACE_LEAVE_EXEC, objc, objv);
}
}
- Tcl_DecrRefCount(commandPtr);
/*
* As cmdPtr is set, TclNRRunCallbacks is about to reduce the numlevels.
@@ -4725,8 +4751,18 @@ TEOV_RunLeaveTraces(
TclCleanupCommandMacro(cmdPtr);
if (traceCode != TCL_OK) {
- return traceCode;
+ if (traceCode == TCL_ERROR) {
+ Tcl_Obj *info;
+
+ TclNewLiteralStringObj(info, "\n (leave trace on \"");
+ Tcl_AppendLimitedToObj(info, command, length, 55, "...");
+ Tcl_AppendToObj(info, "\")", 2);
+ Tcl_AppendObjToErrorInfo(interp, info);
+ iPtr->flags |= ERR_ALREADY_LOGGED;
+ }
+ result = traceCode;
}
+ Tcl_DecrRefCount(commandPtr);
return result;
}
diff --git a/generic/tclBinary.c b/generic/tclBinary.c
index 901237b..7625d39 100644
--- a/generic/tclBinary.c
+++ b/generic/tclBinary.c
@@ -2386,29 +2386,32 @@ BinaryDecodeHex(
while (data < dataend) {
value = 0;
for (i=0 ; i<2 ; i++) {
- if (data < dataend) {
- c = *data++;
-
- if (!isxdigit((int) c)) {
- if (strict || !isspace(c)) {
- goto badChar;
- }
- i--;
- continue;
- }
+ if (data >= dataend) {
value <<= 4;
- c -= '0';
- if (c > 9) {
- c += ('0' - 'A') + 10;
- }
- if (c > 16) {
- c += ('A' - 'a');
+ break;
+ }
+
+ c = *data++;
+ if (!isxdigit((int) c)) {
+ if (strict || !isspace(c)) {
+ goto badChar;
}
- value |= (c & 0xf);
- } else {
- value <<= 4;
- cut++;
+ i--;
+ continue;
}
+
+ value <<= 4;
+ c -= '0';
+ if (c > 9) {
+ c += ('0' - 'A') + 10;
+ }
+ if (c > 16) {
+ c += ('A' - 'a');
+ }
+ value |= (c & 0xf);
+ }
+ if (i < 2) {
+ cut++;
}
*cursor++ = UCHAR(value);
value = 0;
diff --git a/generic/tclCompCmds.c b/generic/tclCompCmds.c
index 8edb2d9..fdc8ec1 100644
--- a/generic/tclCompCmds.c
+++ b/generic/tclCompCmds.c
@@ -2228,7 +2228,7 @@ TclCompileForCmd(
{
Tcl_Token *startTokenPtr, *testTokenPtr, *nextTokenPtr, *bodyTokenPtr;
JumpFixup jumpEvalCondFixup;
- int testCodeOffset, bodyCodeOffset, nextCodeOffset, jumpDist;
+ int bodyCodeOffset, nextCodeOffset, jumpDist;
int bodyRange, nextRange;
DefineLineInformation; /* TIP #280 */
@@ -2309,13 +2309,9 @@ TclCompileForCmd(
* terminates the for.
*/
- testCodeOffset = CurrentOffset(envPtr);
-
- jumpDist = testCodeOffset - jumpEvalCondFixup.codeOffset;
- if (TclFixupForwardJump(envPtr, &jumpEvalCondFixup, jumpDist, 127)) {
+ if (TclFixupForwardJumpToHere(envPtr, &jumpEvalCondFixup, 127)) {
bodyCodeOffset += 3;
nextCodeOffset += 3;
- testCodeOffset += 3;
}
SetLineInformation(2);
diff --git a/generic/tclCompExpr.c b/generic/tclCompExpr.c
index 2a48117..d8e4d9f 100644
--- a/generic/tclCompExpr.c
+++ b/generic/tclCompExpr.c
@@ -490,13 +490,6 @@ typedef struct JumpList {
JumpFixup jump; /* Pass this argument to matching calls of
* TclEmitForwardJump() and
* TclFixupForwardJump(). */
- int depth; /* Remember the currStackDepth of the
- * CompileEnv here. */
- int offset; /* Data used to compute jump lengths to pass
- * to TclFixupForwardJump() */
- int convert; /* Temporary storage used to compute whether
- * numeric conversion will be needed following
- * the operator we're compiling. */
struct JumpList *next; /* Point to next item on the stack */
} JumpList;
@@ -2261,30 +2254,8 @@ CompileExprTree(
if (nodePtr->mark == MARK_LEFT) {
next = nodePtr->left;
- switch (nodePtr->lexeme) {
- case QUESTION:
- newJump = TclStackAlloc(interp, sizeof(JumpList));
- newJump->next = jumpPtr;
- jumpPtr = newJump;
- newJump = TclStackAlloc(interp, sizeof(JumpList));
- newJump->next = jumpPtr;
- jumpPtr = newJump;
- jumpPtr->depth = envPtr->currStackDepth;
+ if (nodePtr->lexeme == QUESTION) {
convert = 1;
- break;
- case AND:
- case OR:
- newJump = TclStackAlloc(interp, sizeof(JumpList));
- newJump->next = jumpPtr;
- jumpPtr = newJump;
- newJump = TclStackAlloc(interp, sizeof(JumpList));
- newJump->next = jumpPtr;
- jumpPtr = newJump;
- newJump = TclStackAlloc(interp, sizeof(JumpList));
- newJump->next = jumpPtr;
- jumpPtr = newJump;
- jumpPtr->depth = envPtr->currStackDepth;
- break;
}
} else if (nodePtr->mark == MARK_RIGHT) {
next = nodePtr->right;
@@ -2317,25 +2288,35 @@ CompileExprTree(
break;
}
case QUESTION:
+ newJump = TclStackAlloc(interp, sizeof(JumpList));
+ newJump->next = jumpPtr;
+ jumpPtr = newJump;
TclEmitForwardJump(envPtr, TCL_FALSE_JUMP, &jumpPtr->jump);
break;
case COLON:
- CLANG_ASSERT(jumpPtr);
+ newJump = TclStackAlloc(interp, sizeof(JumpList));
+ newJump->next = jumpPtr;
+ jumpPtr = newJump;
TclEmitForwardJump(envPtr, TCL_UNCONDITIONAL_JUMP,
- &jumpPtr->next->jump);
- envPtr->currStackDepth = jumpPtr->depth;
- jumpPtr->offset = (envPtr->codeNext - envPtr->codeStart);
- jumpPtr->convert = convert;
+ &jumpPtr->jump);
+ TclAdjustStackDepth(-1, envPtr);
+ if (convert) {
+ jumpPtr->jump.jumpType = TCL_TRUE_JUMP;
+ }
convert = 1;
break;
case AND:
- TclEmitForwardJump(envPtr, TCL_FALSE_JUMP, &jumpPtr->jump);
- break;
case OR:
- TclEmitForwardJump(envPtr, TCL_TRUE_JUMP, &jumpPtr->jump);
+ newJump = TclStackAlloc(interp, sizeof(JumpList));
+ newJump->next = jumpPtr;
+ jumpPtr = newJump;
+ TclEmitForwardJump(envPtr, (nodePtr->lexeme == AND)
+ ? TCL_FALSE_JUMP : TCL_TRUE_JUMP, &jumpPtr->jump);
break;
}
} else {
+ int pc1, pc2, target;
+
switch (nodePtr->lexeme) {
case START:
case QUESTION:
@@ -2375,18 +2356,20 @@ CompileExprTree(
break;
case COLON:
CLANG_ASSERT(jumpPtr);
- if (TclFixupForwardJump(envPtr, &jumpPtr->next->jump,
- (envPtr->codeNext - envPtr->codeStart)
- - jumpPtr->next->jump.codeOffset, 127)) {
- jumpPtr->offset += 3;
+ if (jumpPtr->jump.jumpType == TCL_TRUE_JUMP) {
+ jumpPtr->jump.jumpType = TCL_UNCONDITIONAL_JUMP;
+ convert = 1;
+ }
+ target = jumpPtr->jump.codeOffset + 2;
+ if (TclFixupForwardJumpToHere(envPtr, &jumpPtr->jump, 127)) {
+ target += 3;
}
- TclFixupForwardJump(envPtr, &jumpPtr->jump,
- jumpPtr->offset - jumpPtr->jump.codeOffset, 127);
- convert |= jumpPtr->convert;
- envPtr->currStackDepth = jumpPtr->depth + 1;
freePtr = jumpPtr;
jumpPtr = jumpPtr->next;
TclStackFree(interp, freePtr);
+ TclFixupForwardJump(envPtr, &jumpPtr->jump,
+ target - jumpPtr->jump.codeOffset, 127);
+
freePtr = jumpPtr;
jumpPtr = jumpPtr->next;
TclStackFree(interp, freePtr);
@@ -2394,30 +2377,24 @@ CompileExprTree(
case AND:
case OR:
CLANG_ASSERT(jumpPtr);
- TclEmitForwardJump(envPtr, (nodePtr->lexeme == AND)
- ? TCL_FALSE_JUMP : TCL_TRUE_JUMP,
- &jumpPtr->next->jump);
+ pc1 = CurrentOffset(envPtr);
+ TclEmitInstInt1((nodePtr->lexeme == AND) ? INST_JUMP_FALSE1
+ : INST_JUMP_TRUE1, 0, envPtr);
TclEmitPush(TclRegisterNewLiteral(envPtr,
(nodePtr->lexeme == AND) ? "1" : "0", 1), envPtr);
- TclEmitForwardJump(envPtr, TCL_UNCONDITIONAL_JUMP,
- &jumpPtr->next->next->jump);
+ pc2 = CurrentOffset(envPtr);
+ TclEmitInstInt1(INST_JUMP1, 0, envPtr);
TclAdjustStackDepth(-1, envPtr);
- TclFixupForwardJumpToHere(envPtr, &jumpPtr->next->jump, 127);
+ TclStoreInt1AtPtr(CurrentOffset(envPtr) - pc1,
+ envPtr->codeStart + pc1 + 1);
if (TclFixupForwardJumpToHere(envPtr, &jumpPtr->jump, 127)) {
- jumpPtr->next->next->jump.codeOffset += 3;
+ pc2 += 3;
}
TclEmitPush(TclRegisterNewLiteral(envPtr,
(nodePtr->lexeme == AND) ? "0" : "1", 1), envPtr);
- TclFixupForwardJumpToHere(envPtr, &jumpPtr->next->next->jump,
- 127);
+ TclStoreInt1AtPtr(CurrentOffset(envPtr) - pc2,
+ envPtr->codeStart + pc2 + 1);
convert = 0;
- envPtr->currStackDepth = jumpPtr->depth + 1;
- freePtr = jumpPtr;
- jumpPtr = jumpPtr->next;
- TclStackFree(interp, freePtr);
- freePtr = jumpPtr;
- jumpPtr = jumpPtr->next;
- TclStackFree(interp, freePtr);
freePtr = jumpPtr;
jumpPtr = jumpPtr->next;
TclStackFree(interp, freePtr);
diff --git a/generic/tclOOMethod.c b/generic/tclOOMethod.c
index 81293c7..61215de 100644
--- a/generic/tclOOMethod.c
+++ b/generic/tclOOMethod.c
@@ -1290,11 +1290,57 @@ CloneProcedureMethod(
ClientData *newClientData)
{
ProcedureMethod *pmPtr = clientData;
- ProcedureMethod *pm2Ptr = ckalloc(sizeof(ProcedureMethod));
+ ProcedureMethod *pm2Ptr;
+ Tcl_Obj *bodyObj, *argsObj;
+ CompiledLocal *localPtr;
+ /*
+ * Copy the argument list.
+ */
+
+ argsObj = Tcl_NewObj();
+ for (localPtr=pmPtr->procPtr->firstLocalPtr; localPtr!=NULL;
+ localPtr=localPtr->nextPtr) {
+ if (TclIsVarArgument(localPtr)) {
+ Tcl_Obj *argObj = Tcl_NewObj();
+
+ Tcl_ListObjAppendElement(NULL, argObj,
+ Tcl_NewStringObj(localPtr->name, -1));
+ if (localPtr->defValuePtr != NULL) {
+ Tcl_ListObjAppendElement(NULL, argObj, localPtr->defValuePtr);
+ }
+ Tcl_ListObjAppendElement(NULL, argsObj, argObj);
+ }
+ }
+
+ /*
+ * Must strip the internal representation in order to ensure that any
+ * bound references to instance variables are removed. [Bug 3609693]
+ */
+
+ bodyObj = Tcl_DuplicateObj(pmPtr->procPtr->bodyPtr);
+ TclFreeIntRep(bodyObj);
+
+ /*
+ * Create the actual copy of the method record, manufacturing a new proc
+ * record.
+ */
+
+ pm2Ptr = ckalloc(sizeof(ProcedureMethod));
memcpy(pm2Ptr, pmPtr, sizeof(ProcedureMethod));
pm2Ptr->refCount = 1;
- pm2Ptr->procPtr->refCount++;
+ Tcl_IncrRefCount(argsObj);
+ Tcl_IncrRefCount(bodyObj);
+ if (TclCreateProc(interp, NULL, "", argsObj, bodyObj,
+ &pm2Ptr->procPtr) != TCL_OK) {
+ Tcl_DecrRefCount(argsObj);
+ Tcl_DecrRefCount(bodyObj);
+ ckfree(pm2Ptr);
+ return TCL_ERROR;
+ }
+ Tcl_DecrRefCount(argsObj);
+ Tcl_DecrRefCount(bodyObj);
+
if (pmPtr->cloneClientdataProc) {
pm2Ptr->clientData = pmPtr->cloneClientdataProc(pmPtr->clientData);
}
diff --git a/generic/tclParse.c b/generic/tclParse.c
index c5cb1d1..ee0d4c4 100644
--- a/generic/tclParse.c
+++ b/generic/tclParse.c
@@ -13,9 +13,9 @@
* this file, and for a DISCLAIMER OF ALL WARRANTIES.
*/
-#include <assert.h>
#include "tclInt.h"
#include "tclParse.h"
+#include <assert.h>
/*
* The following table provides parsing information about each possible 8-bit
diff --git a/generic/tclTest.c b/generic/tclTest.c
index 96973d7..f121d0d 100644
--- a/generic/tclTest.c
+++ b/generic/tclTest.c
@@ -4408,8 +4408,26 @@ TestseterrorcodeCmd(
Tcl_SetResult(interp, "too many args", TCL_STATIC);
return TCL_ERROR;
}
- Tcl_SetErrorCode(interp, argv[1], argv[2], argv[3], argv[4],
- argv[5], NULL);
+ switch (argc) {
+ case 1:
+ Tcl_SetErrorCode(interp, "NONE", NULL);
+ break;
+ case 2:
+ Tcl_SetErrorCode(interp, argv[1], NULL);
+ break;
+ case 3:
+ Tcl_SetErrorCode(interp, argv[1], argv[2], NULL);
+ break;
+ case 4:
+ Tcl_SetErrorCode(interp, argv[1], argv[2], argv[3], NULL);
+ break;
+ case 5:
+ Tcl_SetErrorCode(interp, argv[1], argv[2], argv[3], argv[4], NULL);
+ break;
+ case 6:
+ Tcl_SetErrorCode(interp, argv[1], argv[2], argv[3], argv[4],
+ argv[5], NULL);
+ }
return TCL_ERROR;
}
diff --git a/generic/tclUtil.c b/generic/tclUtil.c
index 27e2474..b089132 100644
--- a/generic/tclUtil.c
+++ b/generic/tclUtil.c
@@ -3580,10 +3580,9 @@ UpdateStringOfEndOffset(
register Tcl_Obj *objPtr)
{
char buffer[TCL_INTEGER_SPACE + 5];
- register int len;
+ register int len = 3;
memcpy(buffer, "end", 4);
- len = sizeof("end") - 1;
if (objPtr->internalRep.longValue != 0) {
buffer[len++] = '-';
len += TclFormatInt(buffer+len, -(objPtr->internalRep.longValue));
diff --git a/library/auto.tcl b/library/auto.tcl
index 78c219e..02edcc4 100644
--- a/library/auto.tcl
+++ b/library/auto.tcl
@@ -513,6 +513,32 @@ proc auto_mkindex_parser::fullname {name} {
return [string map [list \0 \$] $name]
}
+# auto_mkindex_parser::indexEntry --
+#
+# Used by commands like "proc" within the auto_mkindex parser to add a
+# correctly-quoted entry to the index. This is shared code so it is done
+# *right*, in one place.
+#
+# Arguments:
+# name - Name that is being added to index.
+
+proc auto_mkindex_parser::indexEntry {name} {
+ variable index
+ variable scriptFile
+
+ # We convert all metacharacters to their backslashed form, and pre-split
+ # the file name that we know about (which will be a proper list, and so
+ # correctly quoted).
+
+ set name [string range [list \}[fullname $name]] 2 end]
+ set filenameParts [file split $scriptFile]
+
+ append index [format \
+ {set auto_index(%s) [list source [file join $dir %s]]%s} \
+ $name $filenameParts \n]
+ return
+}
+
if {[llength $::auto_mkindex_parser::initCommands]} {
return
}
@@ -524,15 +550,7 @@ if {[llength $::auto_mkindex_parser::initCommands]} {
# Adds an entry to the auto index list for the given procedure name.
auto_mkindex_parser::command proc {name args} {
- variable index
- variable scriptFile
- # Do some fancy reformatting on the "source" call to handle platform
- # differences with respect to pathnames. Use format just so that the
- # command is a little easier to read (otherwise it'd be full of
- # backslashed dollar signs, etc.
- append index [list set auto_index([fullname $name])] \
- [format { [list source [file join $dir %s]]} \
- [file split $scriptFile]] "\n"
+ indexEntry $name
}
# Conditionally add support for Tcl byte code files. There are some tricky
@@ -559,14 +577,7 @@ auto_mkindex_parser::hook {
# procedure name.
auto_mkindex_parser::commandInit tbcload::bcproc {name args} {
- variable index
- variable scriptFile
- # Do some nice reformatting of the "source" call, to get around
- # path differences on different platforms. We use the format
- # command just so that the code is a little easier to read.
- append index [list set auto_index([fullname $name])] \
- [format { [list source [file join $dir %s]]} \
- [file split $scriptFile]] "\n"
+ indexEntry $name
}
}
}
@@ -610,6 +621,13 @@ auto_mkindex_parser::command namespace {op args} {
variable contextStack
if {[lindex $args 0] eq "create"} {
set name ::[join [lreverse $contextStack] ::]
+ catch {
+ set name [dict get [lrange $args 1 end] -command]
+ if {![string match ::* $name]} {
+ set name ::[join [lreverse $contextStack] ::]$name
+ }
+ regsub -all ::+ $name :: name
+ }
# create artifical proc to force an entry in the tclIndex
$parser eval [list ::proc $name {} {}]
}
@@ -619,15 +637,14 @@ auto_mkindex_parser::command namespace {op args} {
# AUTO MKINDEX: oo::class create name ?definition?
# Adds an entry to the auto index list for the given class name.
-foreach cmd {oo::class class} {
- auto_mkindex_parser::command $cmd {ecmd name {body ""}} {
- if {$cmd eq "create"} {
- variable index
- variable scriptFile
- append index [format "set %s \[list source \[%s]]\n" \
- [list auto_index([fullname $name])] \
- [list file join $dir {*}[file split $scriptFile]]]
- }
+auto_mkindex_parser::command oo::class {op name {body ""}} {
+ if {$op eq "create"} {
+ indexEntry $name
+ }
+}
+auto_mkindex_parser::command class {op name {body ""}} {
+ if {$op eq "create"} {
+ indexEntry $name
}
}
diff --git a/library/tm.tcl b/library/tm.tcl
index d2af4f5..55efda6 100644
--- a/library/tm.tcl
+++ b/library/tm.tcl
@@ -238,6 +238,15 @@ proc ::tcl::tm::UnknownHandler {original name args} {
continue
}
+ if {[package ifneeded $pkgname $pkgversion] ne {}} {
+ # There's already a provide script registered for
+ # this version of this package. Since all units of
+ # code claiming to be the same version of the same
+ # package ought to be identical, just stick with
+ # the one we already have.
+ continue
+ }
+
# We have found a candidate, generate a "provide script"
# for it, and remember it. Note that we are using ::list
# to do this; locally [list] means something else without
diff --git a/tests/binary.test b/tests/binary.test
index 4393245..d424837 100644
--- a/tests/binary.test
+++ b/tests/binary.test
@@ -2499,6 +2499,34 @@ test binary-71.9 {binary decode hex} -body {
test binary-71.10 {binary decode hex} -body {
string length [binary decode hex " "]
} -result 0
+test binary-71.11 {binary decode hex: Bug b98fa55285} -body {
+ apply {{} {
+ set str "137b6f95e7519389e7c4b36599781e2ccf492699649249aae43fbe8c26\n"
+ set decoded [binary decode hex $str]
+ list [string length $decoded] [scan [string index $decoded end] %c]
+ }}
+} -result {29 38}
+test binary-71.12 {binary decode hex: Bug b98fa55285 cross check} -body {
+ apply {{} {
+ set str "137b6f95e7519389e7c4b36599781e2ccf492699649249aae43fbe8c2\n"
+ set decoded [binary decode hex $str]
+ list [string length $decoded] [scan [string index $decoded end] %c]
+ }}
+} -result {28 140}
+test binary-71.13 {binary decode hex: Bug b98fa55285 cross check} -body {
+ apply {{} {
+ set str "137b6f95e7519389e7c4b36599781e2ccf492699649249aae43fbe8c2\n\n"
+ set decoded [binary decode hex $str]
+ list [string length $decoded] [scan [string index $decoded end] %c]
+ }}
+} -result {28 140}
+test binary-71.14 {binary decode hex: Bug b98fa55285 cross check} -body {
+ apply {{} {
+ set str "137b6f95e7519389e7c4b36599781e2ccf492699649249aae43fbe8c2\n\n\n"
+ set decoded [binary decode hex $str]
+ list [string length $decoded] [scan [string index $decoded end] %c]
+ }}
+} -result {28 140}
test binary-72.1 {binary encode base64} -body {
binary encode base64
diff --git a/tests/error.test b/tests/error.test
index 06f8eca..0de644c 100644
--- a/tests/error.test
+++ b/tests/error.test
@@ -182,6 +182,16 @@ test error-4.7 {errorstack via options dict } -body {
catch {f 12} m d
dict get $d -errorstack
} -match glob -result {INNER * CALL {g 1212} CALL {f 12} UP 1}
+test error-4.8 {errorstack from exec traces} -body {
+ proc foo args {}
+ proc goo {} foo
+ trace add execution foo enter {error bar;#}
+ catch goo m d
+ dict get $d -errorstack
+} -cleanup {
+ rename goo {}; rename foo {}
+ unset -nocomplain m d
+} -result {INNER {error bar} CALL goo UP 1}
# Errors in error command itself
diff --git a/tests/oo.test b/tests/oo.test
index e0e0791..054bc46 100644
--- a/tests/oo.test
+++ b/tests/oo.test
@@ -1839,6 +1839,36 @@ test oo-15.9 {ensemble rewriting must not bleed through oo::copy} -setup {
} -returnCodes error -cleanup {
Foo destroy
} -result {wrong # args: should be "::bar <cloned> a b"}
+test oo-15.10 {variable binding must not bleed through oo::copy} -setup {
+ oo::class create FooClass
+ set result {}
+} -body {
+ set obj1 [FooClass new]
+ oo::objdefine $obj1 {
+ variable var
+ method m {} {
+ set var foo
+ }
+ method get {} {
+ return $var
+ }
+ export eval
+ }
+
+ $obj1 m
+ lappend result [$obj1 get]
+ set obj2 [oo::copy $obj1]
+ $obj2 eval {
+ set var bar
+ }
+ lappend result [$obj2 get]
+ $obj1 eval {
+ set var grill
+ }
+ lappend result [$obj1 get] [$obj2 get]
+} -cleanup {
+ FooClass destroy
+} -result {foo bar grill bar}
test oo-16.1 {OO: object introspection} -body {
info object
diff --git a/tests/zlib.test b/tests/zlib.test
index c469eea..0712929 100644
--- a/tests/zlib.test
+++ b/tests/zlib.test
@@ -233,7 +233,7 @@ test zlib-8.7 {transformation and fconfigure} -setup {
# Dictionary is that which is proposed _in_ SPDY draft
set spdyHeaders "HTTP/1.0 200 OK\r\nContent-Type: text/html; charset=utf-8\r\nX-Robots-Tag: noarchive\r\nLast-Modified: Tue, 05 Jun 2012 02:43:25 GMT\r\nETag: \"1338864205129|#public|0|en|||0\"\r\nExpires: Tue, 05 Jun 2012 16:17:11 GMT\r\nDate: Tue, 05 Jun 2012 16:17:06 GMT\r\nCache-Control: public, max-age=5\r\nX-Content-Type-Options: nosniff\r\nX-XSS-Protection: 1; mode=block\r\nServer: GSE\r\n"
set spdyDict "optionsgetheadpostputdeletetraceacceptaccept-charsetaccept-encodingaccept-languageauthorizationexpectfromhostif-modified-sinceif-matchif-none-matchif-rangeif-unmodifiedsincemax-forwardsproxy-authorizationrangerefererteuser-agent100101200201202203204205206300301302303304305306307400401402403404405406407408409410411412413414415416417500501502503504505accept-rangesageetaglocationproxy-authenticatepublicretry-afterservervarywarningwww-authenticateallowcontent-basecontent-encodingcache-controlconnectiondatetrailertransfer-encodingupgradeviawarningcontent-languagecontent-lengthcontent-locationcontent-md5content-rangecontent-typeetagexpireslast-modifiedset-cookieMondayTuesdayWednesdayThursdayFridaySaturdaySundayJanFebMarAprMayJunJulAugSepOctNovDecchunkedtext/htmlimage/pngimage/jpgimage/gifapplication/xmlapplication/xhtmltext/plainpublicmax-agecharset=iso-8859-1utf-8gzipdeflateHTTP/1.1statusversionurl"
-test zlib-8.8 {transformtion and fconfigure} -setup {
+test zlib-8.8 {transformation and fconfigure} -setup {
lassign [chan pipe] inSide outSide
} -constraints zlib -body {
zlib push compress $outSide -dictionary $spdyDict
@@ -250,7 +250,7 @@ test zlib-8.8 {transformtion and fconfigure} -setup {
catch {close $outSide}
catch {close $inSide}
} -result {260 222 {need dictionary} {TCL ZLIB NEED_DICT 2381337010} 2381337010}
-test zlib-8.9 {transformtion and fconfigure} -setup {
+test zlib-8.9 {transformation and fconfigure} -setup {
lassign [chan pipe] inSide outSide
set strm [zlib stream decompress]
} -constraints zlib -body {
@@ -267,7 +267,7 @@ test zlib-8.9 {transformtion and fconfigure} -setup {
catch {close $inSide}
catch {$strm close}
} -result {3064818174 358 358}
-test zlib-8.10 {transformtion and fconfigure} -setup {
+test zlib-8.10 {transformation and fconfigure} -setup {
lassign [chan pipe] inSide outSide
} -constraints zlib -body {
zlib push deflate $outSide -dictionary $spdyDict
@@ -276,7 +276,10 @@ test zlib-8.10 {transformtion and fconfigure} -setup {
puts -nonewline $outSide $spdyHeaders
chan pop $outSide
set compressed [read $inSide]
- catch {zlib inflate $compressed} err opt
+ catch {
+ zlib inflate $compressed
+ throw UNREACHABLE "should be unreachable"
+ } err opt
list [string length [zlib deflate $spdyHeaders]] \
[string length $compressed] \
$err [dict get $opt -errorcode]
@@ -284,7 +287,7 @@ test zlib-8.10 {transformtion and fconfigure} -setup {
catch {close $outSide}
catch {close $inSide}
} -result {254 212 {data error} {TCL ZLIB DATA}}
-test zlib-8.11 {transformtion and fconfigure} -setup {
+test zlib-8.11 {transformation and fconfigure} -setup {
lassign [chan pipe] inSide outSide
set strm [zlib stream inflate]
} -constraints zlib -body {
@@ -300,7 +303,7 @@ test zlib-8.11 {transformtion and fconfigure} -setup {
catch {close $inSide}
catch {$strm close}
} -result {358 358}
-test zlib-8.12 {transformtion and fconfigure} -setup {
+test zlib-8.12 {transformation and fconfigure} -setup {
lassign [chan pipe] inSide outSide
set strm [zlib stream compress]
} -constraints zlib -body {
@@ -317,7 +320,7 @@ test zlib-8.12 {transformtion and fconfigure} -setup {
catch {close $inSide}
catch {$strm close}
} -result {358 358 3064818174}
-test zlib-8.13 {transformtion and fconfigure} -setup {
+test zlib-8.13 {transformation and fconfigure} -setup {
lassign [chan pipe] inSide outSide
set strm [zlib stream compress]
} -constraints zlib -body {
@@ -334,7 +337,7 @@ test zlib-8.13 {transformtion and fconfigure} -setup {
catch {close $inSide}
catch {$strm close}
} -result {358 358 3064818174}
-test zlib-8.14 {transformtion and fconfigure} -setup {
+test zlib-8.14 {transformation and fconfigure} -setup {
lassign [chan pipe] inSide outSide
set strm [zlib stream deflate]
} -constraints zlib -body {
@@ -350,7 +353,7 @@ test zlib-8.14 {transformtion and fconfigure} -setup {
catch {close $inSide}
catch {$strm close}
} -result {358 358}
-test zlib-8.15 {transformtion and fconfigure} -setup {
+test zlib-8.15 {transformation and fconfigure} -setup {
lassign [chan pipe] inSide outSide
set strm [zlib stream deflate]
} -constraints zlib -body {
diff --git a/unix/tclUnixFCmd.c b/unix/tclUnixFCmd.c
index e27f78f..e270b6a 100644
--- a/unix/tclUnixFCmd.c
+++ b/unix/tclUnixFCmd.c
@@ -462,10 +462,10 @@ DoCopyFile(
switch ((int) (statBufPtr->st_mode & S_IFMT)) {
#ifndef DJGPP
case S_IFLNK: {
- char linkBuf[MAXPATHLEN];
+ char linkBuf[MAXPATHLEN+1];
int length;
- length = readlink(src, linkBuf, sizeof(linkBuf));
+ length = readlink(src, linkBuf, MAXPATHLEN);
/* INTL: Native. */
if (length == -1) {
return TCL_ERROR;
diff --git a/unix/tclUnixSock.c b/unix/tclUnixSock.c
index 9c3d7eb..a6360c2 100644
--- a/unix/tclUnixSock.c
+++ b/unix/tclUnixSock.c
@@ -1358,6 +1358,7 @@ Tcl_OpenTcpServer(
my_errno = errno;
}
close(sock);
+ sock = -1;
continue;
}
if (port == 0 && chosenport == 0) {
@@ -1380,6 +1381,7 @@ Tcl_OpenTcpServer(
my_errno = errno;
}
close(sock);
+ sock = -1;
continue;
}
if (statePtr == NULL) {
generated by cgit v0.12 at 2024-11-22 00:08:49 (GMT)