A better fix for #120819 (all it needed was some Tcl_Preserve()s)

which also requires no documentation changes - the behaviour is now
what you would predict from existing docs (as opposed to a crash!)

3 files changed, 65 insertions, 28 deletions

diff --git a/ChangeLog b/ChangeLog
index a478471..2c7db61 100644
--- a/ChangeLog
+++ b/ChangeLog
@@ -1,3 +1,12 @@
+2000-11-29  Donal K. Fellows  <fellowsd@cs.man.ac.uk>
+
+	* tests/image.test (image-1.10): Improved this test, which
+	  previously only worked if the command failed to delete the root
+	  window, and caused *major* trouble otherwise...
+	* generic/tkImage.c (EventuallyDeleteImage): Created this function
+	  so that images that get deleted during the creation of an image
+	  won't cause a nasty core dump.  Properly fixes bug #120819.
+
 2000-11-28  Donal K. Fellows  <fellowsd@cs.man.ac.uk>
 
 	* doc/image.n: 
diff --git a/generic/tkImage.c b/generic/tkImage.c
index 7952108..f8d5388 100644
--- a/generic/tkImage.c
+++ b/generic/tkImage.c
@@ -11,7 +11,7 @@
  * See the file "license.terms" for information on usage and redistribution
  * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
  *
- * RCS: @(#) $Id: tkImage.c,v 1.9 2000/11/28 11:16:04 dkf Exp $
+ * RCS: @(#) $Id: tkImage.c,v 1.10 2000/11/29 15:47:05 dkf Exp $
  */
 
 #include "tkInt.h"
@@ -69,6 +69,7 @@ typedef struct ImageMaster {
 				 * entry). */
     Image *instancePtr;		/* Pointer to first in list of instances
 				 * derived from this name. */
+    int deleted;		/* Flag set when image is being deleted */
 } ImageMaster;
 
 typedef struct ThreadSpecificData {
@@ -83,7 +84,8 @@ static Tcl_ThreadDataKey dataKey;
  * Prototypes for local procedures:
  */
 
-static void		DeleteImage _ANSI_ARGS_((ImageMaster *masterPtr));
+static void	DeleteImage _ANSI_ARGS_((ImageMaster *masterPtr));
+static void	EventuallyDeleteImage _ANSI_ARGS_((ImageMaster *masterPtr));
 
 /*
  *----------------------------------------------------------------------
@@ -251,6 +253,7 @@ Tk_ImageObjCmd(clientData, interp, objc, objv)
 		masterPtr->tablePtr = &winPtr->mainPtr->imageTable;
 		masterPtr->hPtr = hPtr;
 		masterPtr->instancePtr = NULL;
+		masterPtr->deleted = 0;
 		Tcl_SetHashValue(hPtr, masterPtr);
 	    } else {
 		/*
@@ -290,15 +293,18 @@ Tk_ImageObjCmd(clientData, interp, objc, objv)
 		}
 		args[objc] = NULL;
 	    }
+	    Tcl_Preserve(masterPtr);
 	    if ((*typePtr->createProc)(interp, name, objc,
 		    args, typePtr, (Tk_ImageMaster) masterPtr,
 		    &masterPtr->masterData) != TCL_OK) {
-		DeleteImage(masterPtr);
+		EventuallyDeleteImage(masterPtr);
+		Tcl_Release(masterPtr);
 		if (oldimage) {
 		    ckfree((char *) args);
 		}
 		return TCL_ERROR;
 	    }
+	    Tcl_Release(masterPtr);
 	    if (oldimage) {
 		ckfree((char *) args);
 	    }
@@ -322,8 +328,7 @@ Tk_ImageObjCmd(clientData, interp, objc, objv)
 			    "\" doesn't exist", (char *) NULL);
 		    return TCL_ERROR;
 		}
-		masterPtr = (ImageMaster *) Tcl_GetHashValue(hPtr);
-		DeleteImage(masterPtr);
+		DeleteImage((ImageMaster *) Tcl_GetHashValue(hPtr));
 	    }
 	    break;
 	}
@@ -861,7 +866,7 @@ Tk_DeleteImage(interp, name)
     if (hPtr == NULL) {
 	return;
     }
-    DeleteImage((ImageMaster *) Tcl_GetHashValue(hPtr));
+    DeleteImage((ImageMaster *)Tcl_GetHashValue(hPtr));
 }
 
 /*
@@ -911,6 +916,34 @@ DeleteImage(masterPtr)
 /*
  *----------------------------------------------------------------------
  *
+ * EventuallyDeleteImage --
+ *
+ *	Arrange for an image to be deleted when it is safe to do so.
+ *
+ * Results:
+ *	None.
+ *
+ * Side effects:
+ *	Image will get freed, though not until it is no longer
+ *	Tcl_Preserve()d by anything.  May be called multiple times on
+ *	the same image without ill effects.
+ *
+ *----------------------------------------------------------------------
+ */
+
+static void
+EventuallyDeleteImage(masterPtr)
+    ImageMaster *masterPtr;	/* Pointer to main data structure for image. */
+{
+    if (!masterPtr->deleted) {
+	masterPtr->deleted = 1;
+	Tcl_EventuallyFree(masterPtr, (Tcl_FreeProc *)DeleteImage);
+    }
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
  * TkDeleteAllImages --
  *
  *	This procedure is called when an application is deleted.  It
@@ -934,12 +967,10 @@ TkDeleteAllImages(mainPtr)
 {
     Tcl_HashSearch search;
     Tcl_HashEntry *hPtr;
-    ImageMaster *masterPtr;
 
     for (hPtr = Tcl_FirstHashEntry(&mainPtr->imageTable, &search);
 	    hPtr != NULL; hPtr = Tcl_NextHashEntry(&search)) {
-	masterPtr = (ImageMaster *) Tcl_GetHashValue(hPtr);
-	DeleteImage(masterPtr);
+	EventuallyDeleteImage((ImageMaster *) Tcl_GetHashValue(hPtr));
     }
     Tcl_DeleteHashTable(&mainPtr->imageTable);
 }
diff --git a/tests/image.test b/tests/image.test
index 296eedf..cd6cb21 100644
--- a/tests/image.test
+++ b/tests/image.test
@@ -7,7 +7,7 @@
 # Copyright (c) 1998-1999 by Scriptics Corporation.
 # All rights reserved.
 #
-# RCS: @(#) $Id: image.test,v 1.5 2000/11/23 13:50:10 dkf Exp $
+# RCS: @(#) $Id: image.test,v 1.6 2000/11/29 15:47:05 dkf Exp $
 
 if {[lsearch [namespace children] ::tcltest] == -1} {
     source [file join [pwd] [file dirname [info script]] defs.tcl]
@@ -80,9 +80,20 @@ test image-1.9 {Tk_ImageCmd procedure, "create" option} {
     eval image delete [image names]
     list [catch {image create test -badName foo} msg] $msg [image names]
 } {1 {bad option name "-badName"} {}}
-test image-1.10 {Tk_ImageCmd procedure, "create" option} {
-    list [catch {image create test .} msg] $msg
-} {1 {image names cannot start with period symbols: "." is illegal}}
+test image-1.10 {Tk_ImageCmd procedure, "create" option with "." as name} {
+    catch {removeFile script}
+    set fd [open script w]
+    puts $fd {
+	update
+	puts [list [catch {image create photo .} msg] $msg]
+	exit
+    }
+    close $fd
+    set x [list [catch {exec $::tcltest::tktest <script} msg] $msg]
+    file delete -force script
+    set x
+} {0 {1 {this isn't a Tk applicationNULL main window}}}
+# I don't like the error message!
 
 test image-2.1 {Tk_ImageCmd procedure, "delete" option} {
     list [catch {image delete} msg] $msg
@@ -374,20 +385,6 @@ destroy .c
 eval image delete [image names]
 
 # cleanup
+catch {removeFile script}
 ::tcltest::cleanupTests
 return
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-