From fd6cead82a2f2f559fa5376d1e8cf520ef79da95 Mon Sep 17 00:00:00 2001
From: dkf <donal.k.fellows@manchester.ac.uk>
Date: Mon, 4 May 2009 17:39:50 +0000
Subject: Stop deletion of support namespaces leading to a potential crash.

---
 ChangeLog                 |  7 +++++
 generic/tclOO.c           | 68 ++++++++++++++++++++++++++++++++++++++++-------
 generic/tclOODefineCmds.c |  9 ++++++-
 3 files changed, 73 insertions(+), 11 deletions(-)

diff --git a/ChangeLog b/ChangeLog
index 91c6ff7..d81ce5d 100644
--- a/ChangeLog
+++ b/ChangeLog
@@ -1,3 +1,10 @@
+2009-05-04  Donal K. Fellows  <dkf@users.sf.net>
+
+	* generic/tclOO.c (InitFoundation, Deleted*Namespace, AllocClass):
+	* generic/tclOODefineCmds.c (InitDefineContext): Make sure that when
+	support namespaces are deleted, nothing bad can subsequently happen.
+	Issue spotted by Don Porter.
+
 2009-05-03  Donal K. Fellows  <dkf@users.sf.net>
 
 	* doc/Tcl.n: [Bug 2538432]: Clarified exact treatment of ${arr(idx)}
diff --git a/generic/tclOO.c b/generic/tclOO.c
index 430e1cc..4c0b253 100644
--- a/generic/tclOO.c
+++ b/generic/tclOO.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: tclOO.c,v 1.19 2009/01/06 10:20:54 dkf Exp $
+ * RCS: @(#) $Id: tclOO.c,v 1.20 2009/05/04 17:39:51 dkf Exp $
  */
 
 #ifdef HAVE_CONFIG_H
@@ -72,6 +72,9 @@ static int		CloneClassMethod(Tcl_Interp *interp, Class *clsPtr,
 			    Method **newMPtrPtr);
 static int		CloneObjectMethod(Tcl_Interp *interp, Object *oPtr,
 			    Method *mPtr, Tcl_Obj *namePtr);
+static void		DeletedDefineNamespace(ClientData clientData);
+static void		DeletedObjdefNamespace(ClientData clientData);
+static void		DeletedHelpersNamespace(ClientData clientData);
 static int		FinalizeAlloc(ClientData data[],
 			    Tcl_Interp *interp, int result);
 static int		FinalizeNext(ClientData data[],
@@ -233,11 +236,12 @@ InitFoundation(
     fPtr->interp = interp;
     fPtr->ooNs = Tcl_CreateNamespace(interp, "::oo", fPtr, NULL);
     Tcl_Export(interp, fPtr->ooNs, "[a-z]*", 1);
-    fPtr->defineNs = Tcl_CreateNamespace(interp, "::oo::define", NULL, NULL);
-    fPtr->objdefNs = Tcl_CreateNamespace(interp, "::oo::objdefine", NULL,
-	    NULL);
-    fPtr->helpersNs = Tcl_CreateNamespace(interp, "::oo::Helpers", NULL,
-	    NULL);
+    fPtr->defineNs = Tcl_CreateNamespace(interp, "::oo::define", fPtr,
+	    DeletedDefineNamespace);
+    fPtr->objdefNs = Tcl_CreateNamespace(interp, "::oo::objdefine", fPtr,
+	    DeletedObjdefNamespace);
+    fPtr->helpersNs = Tcl_CreateNamespace(interp, "::oo::Helpers", fPtr,
+	    DeletedHelpersNamespace);
     fPtr->epoch = 0;
     fPtr->tsdPtr = tsdPtr;
     fPtr->unknownMethodNameObj = Tcl_NewStringObj("unknown", -1);
@@ -354,6 +358,44 @@ InitFoundation(
 /*
  * ----------------------------------------------------------------------
  *
+ * DeletedDefineNamespace, DeletedObjdefNamespace, DeletedHelpersNamespace --
+ *
+ *	Simple helpers used to clear fields of the foundation when they no
+ *	longer hold useful information.
+ *
+ * ----------------------------------------------------------------------
+ */
+
+static void
+DeletedDefineNamespace(
+    ClientData clientData)
+{
+    Foundation *fPtr = clientData;
+
+    fPtr->defineNs = NULL;
+}
+
+static void
+DeletedObjdefNamespace(
+    ClientData clientData)
+{
+    Foundation *fPtr = clientData;
+
+    fPtr->objdefNs = NULL;
+}
+
+static void
+DeletedHelpersNamespace(
+    ClientData clientData)
+{
+    Foundation *fPtr = clientData;
+
+    fPtr->helpersNs = NULL;
+}
+
+/*
+ * ----------------------------------------------------------------------
+ *
  * KillFoundation --
  *
  *	Delete those parts of the OO core that are not deleted automatically
@@ -1154,7 +1196,6 @@ AllocClass(
 {
     Foundation *fPtr = GetFoundation(interp);
     Class *clsPtr = (Class *) ckalloc(sizeof(Class));
-    Tcl_Namespace *path[2];
 
     /*
      * Make an object if we haven't been given one.
@@ -1171,9 +1212,16 @@ AllocClass(
      * Configure the namespace path for the class's object.
      */
 
-    path[0] = fPtr->helpersNs;
-    path[1] = fPtr->ooNs;
-    TclSetNsPath((Namespace *) clsPtr->thisPtr->namespacePtr, 2, path);
+    if (fPtr->helpersNs != NULL) {
+	Tcl_Namespace *path[2];
+
+	path[0] = fPtr->helpersNs;
+	path[1] = fPtr->ooNs;
+	TclSetNsPath((Namespace *) clsPtr->thisPtr->namespacePtr, 2, path);
+    } else {
+	TclSetNsPath((Namespace *) clsPtr->thisPtr->namespacePtr, 1,
+		&fPtr->ooNs);
+    }
 
     /*
      * Class objects inherit from the class of classes unless they inherit
diff --git a/generic/tclOODefineCmds.c b/generic/tclOODefineCmds.c
index b732eec..2fb9ce5 100644
--- a/generic/tclOODefineCmds.c
+++ b/generic/tclOODefineCmds.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: tclOODefineCmds.c,v 1.10 2009/02/12 09:27:43 dkf Exp $
+ * RCS: @(#) $Id: tclOODefineCmds.c,v 1.11 2009/05/04 17:39:51 dkf Exp $
  */
 
 #ifdef HAVE_CONFIG_H
@@ -564,6 +564,13 @@ InitDefineContext(
     CallFrame *framePtr, **framePtrPtr = &framePtr;
     int result;
 
+    if (namespacePtr == NULL) {
+	Tcl_AppendResult(interp,
+		"cannot process definitions; support namespace deleted",
+		NULL);
+	return TCL_ERROR;
+    }
+
     /* framePtrPtr is needed to satisfy GCC 3.3's strict aliasing rules */
 
     result = TclPushStackFrame(interp, (Tcl_CallFrame **) framePtrPtr,
-- 
cgit v0.12