summaryrefslogtreecommitdiffstats
diff options
context:
space:
mode:
-rw-r--r--ChangeLog15
-rw-r--r--generic/tclTimer.c12
-rw-r--r--tests/timer.test14
3 files changed, 33 insertions, 8 deletions
diff --git a/ChangeLog b/ChangeLog
index c4bf470..9a6363f 100644
--- a/ChangeLog
+++ b/ChangeLog
@@ -1,3 +1,10 @@
+2004-08-25 Don Porter <dgp@users.sourceforge.net>
+
+ * tests/timer.test (timer-10.1): Test for Bug 1016167.
+ * generic/tclTimer.c: Workaround for situation when a
+ [namespace import] causes the objv[0] value to be something
+ other than what Tcl_AfterObjCmd expects. [Bug 1016167].
+
2004-08-25 Donal K. Fellows <donal.k.fellows@man.ac.uk>
* generic/tclNamesp.c (NsEnsembleImplementationCmd): Use the
@@ -8,10 +15,10 @@
2004-08-24 Don Porter <dgp@users.sourceforge.net>
- * generic/tclProc.c: The routine TclProcInterpProc was a specific
- * generic/tclTestProcBodyObj.c: instance of the general service already provided
- by TclObjInvokeProc. Removed TclProcInterpProc and TclGetInterpProc from the
- code...
+ * generic/tclProc.c: The routine TclProcInterpProc was a
+ * generic/tclTestProcBodyObj.c: specific instance of the general
+ service already provided by TclObjInvokeProc. Removed
+ TclProcInterpProc and TclGetInterpProc from the code...
* generic/tclInt.decls ...and from the internal stubs table.
* generic/tclIntDecls.h
diff --git a/generic/tclTimer.c b/generic/tclTimer.c
index b441ac3..f7a3d46 100644
--- a/generic/tclTimer.c
+++ b/generic/tclTimer.c
@@ -9,7 +9,7 @@
* See the file "license.terms" for information on usage and redistribution
* of this file, and for a DISCLAIMER OF ALL WARRANTIES.
*
- * RCS: @(#) $Id: tclTimer.c,v 1.8 2004/04/06 22:25:55 dgp Exp $
+ * RCS: @(#) $Id: tclTimer.c,v 1.9 2004/08/25 22:21:34 dgp Exp $
*/
#include "tclInt.h"
@@ -765,6 +765,12 @@ Tcl_AfterObjCmd(clientData, interp, objc, objv)
*/
if (assocPtr == NULL) {
+ Tcl_Command token = Tcl_GetCommandFromObj(interp, objv[0]);
+ Tcl_Command originalToken = TclGetOriginalCommand(token);
+
+ if (originalToken != NULL) {
+ token = originalToken;
+ }
assocPtr = (AfterAssocData *) ckalloc(sizeof(AfterAssocData));
assocPtr->interp = interp;
assocPtr->firstAfterPtr = NULL;
@@ -776,8 +782,8 @@ Tcl_AfterObjCmd(clientData, interp, objc, objv)
cmdInfo.objClientData = (ClientData) assocPtr;
cmdInfo.deleteProc = NULL;
cmdInfo.deleteData = (ClientData) assocPtr;
- Tcl_SetCommandInfo(interp, Tcl_GetStringFromObj(objv[0], &length),
- &cmdInfo);
+
+ Tcl_SetCommandInfoFromToken(token, &cmdInfo);
}
/*
diff --git a/tests/timer.test b/tests/timer.test
index 2eab350..46b21de 100644
--- a/tests/timer.test
+++ b/tests/timer.test
@@ -13,7 +13,7 @@
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
-# RCS: @(#) $Id: timer.test,v 1.8 2004/05/19 13:03:37 dkf Exp $
+# RCS: @(#) $Id: timer.test,v 1.9 2004/08/25 22:21:34 dgp Exp $
if {[lsearch [namespace children] ::tcltest] == -1} {
package require tcltest
@@ -538,6 +538,18 @@ test timer-9.1 {AfterCleanupProc procedure} {
set x
} {before after2 after4}
+test timer-10.1 {Bug 1016167: [after] overwrites imports} -setup {
+ interp create slave
+ slave eval namespace export after
+ slave eval namespace eval foo namespace import ::after
+} -body {
+ slave eval foo::after 1
+ slave eval namespace origin foo::after
+} -cleanup {
+ # Bug will cause crash here; would cause failure otherwise
+ interp delete slave
+} -result ::after
+
# cleanup
::tcltest::cleanupTests
return