* generic/tclOOMethod.c (PushMethodCallFrame): [Bug 3001438]: Make

	sure that the cmdPtr field of the procPtr is correct and relevant at
	all times so that [info frame] can report sensible information about a
	frame after a return to it from a recursive call, instead of probably
	crashing (depending on what else has overwritten the Tcl stack!)

3 files changed, 62 insertions, 10 deletions

diff --git a/ChangeLog b/ChangeLog
index 45c4657..04a76ec 100644
--- a/ChangeLog
+++ b/ChangeLog
@@ -1,6 +1,14 @@
+2011-01-18  Donal K. Fellows  <dkf@users.sf.net>
+
+	* generic/tclOOMethod.c (PushMethodCallFrame): [Bug 3001438]: Make
+	sure that the cmdPtr field of the procPtr is correct and relevant at
+	all times so that [info frame] can report sensible information about a
+	frame after a return to it from a recursive call, instead of probably
+	crashing (depending on what else has overwritten the Tcl stack!)
+
 2011-01-18  Jan Nijtmans  <nijtmans@users.sf.net>
 
-	* generic/tclBasic.c:      Various mismatches between Tcl_Panic 
+	* generic/tclBasic.c:      Various mismatches between Tcl_Panic
 	* generic/tclCompCmds.c:   format string and its arguments,
 	* generic/tclCompCmdsSZ.c: discovered thanks to [Bug 3159920]
 	* generic/tclCompExpr.c
@@ -20,11 +28,11 @@
 	* doc/tclvars.n:
 	* generic/tclStrToD.c:
 	* generic/tclUtil.c (Tcl_PrintDouble):
-	* tests/util.test (util-16.*): Restored full Tcl 8.4 compatibility
-	for the formatting of floating point numbers when $::tcl_precision
-	is not zero. Added compatibility tests to make sure that excess
-	trailing zeroes are suppressed for all eight major code paths.
-	[Bug 3157475]
+	* tests/util.test (util-16.*): [Bug 3157475]: Restored full Tcl 8.4
+	compatibility for the formatting of floating point numbers when
+	$::tcl_precision is not zero. Added compatibility tests to make sure
+	that excess trailing zeroes are suppressed for all eight major code
+	paths.
 
 2011-01-12  Jan Nijtmans  <nijtmans@users.sf.net>
 
diff --git a/generic/tclOOMethod.c b/generic/tclOOMethod.c
index 61aeb12..735ced9 100644
--- a/generic/tclOOMethod.c
+++ b/generic/tclOOMethod.c
@@ -8,7 +8,7 @@
  * See the file "license.terms" for information on usage and redistribution of
  * this file, and for a DISCLAIMER OF ALL WARRANTIES.
  *
- * RCS: @(#) $Id: tclOOMethod.c,v 1.29 2010/11/09 16:26:30 dkf Exp $
+ * RCS: @(#) $Id: tclOOMethod.c,v 1.30 2011/01/18 13:50:03 dkf Exp $
  */
 
 #ifdef HAVE_CONFIG_H
@@ -41,6 +41,7 @@ typedef struct {
     Tcl_Obj *nameObj;		/* The "name" of the command. */
     Command cmd;		/* The command structure. Mostly bogus. */
     ExtraFrameInfo efi;		/* Extra information used for [info frame]. */
+    Command *oldCmdPtr;
     struct PNI pni;		/* Specialist information used in the efi
 				 * field for this type of call. */
 } PMFrameData;
@@ -711,6 +712,13 @@ InvokeProcedureMethod(
 	result = pmPtr->preCallProc(pmPtr->clientData, interp, context,
 		(Tcl_CallFrame *) fdPtr->framePtr, &isFinished);
 	if (isFinished || result != TCL_OK) {
+	    /*
+	     * Restore the old cmdPtr so that a subsequent use of [info frame]
+	     * won't crash on us. [Bug 3001438]
+	     */
+
+	    pmPtr->procPtr->cmdPtr = fdPtr->oldCmdPtr;
+
 	    Tcl_PopCallFrame(interp);
 	    TclStackFree(interp, fdPtr->framePtr);
 	    if (--pmPtr->refCount < 1) {
@@ -752,6 +760,13 @@ FinalizePMCall(
     }
 
     /*
+     * Restore the old cmdPtr so that a subsequent use of [info frame] won't
+     * crash on us. [Bug 3001438]
+     */
+
+    pmPtr->procPtr->cmdPtr = fdPtr->oldCmdPtr;
+
+    /*
      * Scrap the special frame data now that we're done with it. Note that we
      * are inlining DeleteProcedureMethod() here; this location is highly
      * sensitive when it comes to performance!
@@ -820,6 +835,14 @@ PushMethodCallFrame(
     }
 
     /*
+     * Save the old cmdPtr so that when this recursive call returns, we can
+     * restore it. To do otherwise causes crashes in [info frame] after we
+     * return from a recursive call. [Bug 3001438]
+     */
+
+    fdPtr->oldCmdPtr = pmPtr->procPtr->cmdPtr;
+
+    /*
      * Compile the body. This operation may fail.
      */
 
@@ -845,7 +868,7 @@ PushMethodCallFrame(
     result = TclProcCompileProc(interp, pmPtr->procPtr,
 	    pmPtr->procPtr->bodyPtr, nsPtr, "body of method", namePtr);
     if (result != TCL_OK) {
-	return result;
+	goto failureReturn;
     }
 
     /*
@@ -856,7 +879,7 @@ PushMethodCallFrame(
     result = TclPushStackFrame(interp, (Tcl_CallFrame **) framePtrPtr,
 	    (Tcl_Namespace *) nsPtr, FRAME_IS_PROC|FRAME_IS_METHOD);
     if (result != TCL_OK) {
-	return result;
+	goto failureReturn;
     }
 
     fdPtr->framePtr->clientData = contextPtr;
@@ -891,6 +914,15 @@ PushMethodCallFrame(
     }
 
     return TCL_OK;
+
+    /*
+     * Restore the old cmdPtr so that a subsequent use of [info frame] won't
+     * crash on us. [Bug 3001438]
+     */
+
+  failureReturn:
+    pmPtr->procPtr->cmdPtr = fdPtr->oldCmdPtr;
+    return result;
 }
 
 /*
diff --git a/tests/oo.test b/tests/oo.test
index fbeecc6..1954d1b 100644
--- a/tests/oo.test
+++ b/tests/oo.test
@@ -7,7 +7,7 @@
 # See the file "license.terms" for information on usage and redistribution of
 # this file, and for a DISCLAIMER OF ALL WARRANTIES.
 #
-# RCS: @(#) $Id: oo.test,v 1.43 2011/01/01 15:14:43 dkf Exp $
+# RCS: @(#) $Id: oo.test,v 1.44 2011/01/18 13:50:03 dkf Exp $
 
 package require -exact TclOO 0.6.2 ;# Must match value in generic/tclOO.h
 package require tcltest 2
@@ -2235,6 +2235,18 @@ test oo-22.1 {OO and info frame} -setup {
 } -cleanup {
     c destroy
 } -result {1 {{type source line * file * cmd {info frame 0} method frames class ::c level 0} {type source line * file * cmd {info frame 0} method frames object ::i level 0}} ::c}
+test oo-22.2 {OO and info frame: Bug 3001438} -setup {
+    oo::class create c
+} -body {
+    oo::define c method test {{x 1}} {
+	if {$x} {my test 0}
+	lsort {q w e r t y u i o p}; # Overwrite the Tcl stack
+	info frame 0
+    }
+    [c new] test
+} -match glob -cleanup {
+    c destroy
+} -result {* cmd {info frame 0} method test class ::c level 0}
 
 # Prove that the issue in [Bug 1865054] isn't an issue any more
 test oo-23.1 {Self-like derivation; complex case!} -setup {