Added TIP #100 support to the registry package (patch #903831)

This provides a Windows test of the TIP #100 mechanism and
a sample to show how unloading an extension can be done.

3 files changed, 90 insertions, 6 deletions

diff --git a/ChangeLog b/ChangeLog
index e38ade4..79e64db 100644
--- a/ChangeLog
+++ b/ChangeLog
@@ -1,3 +1,10 @@
+2004-03-04  Pat Thoyts  <patthoyts@users.sourceforge.net>
+
+	* library/reg/pkgIndex.tcl:  Added TIP #100 support to the
+	* win/tclWinReg.c:           registry package (patch #903831)
+	This provides a Windows test of the TIP #100 mechanism and 
+	a sample to show how unloading an extension can be done.
+
 2004-03-04  Donal K. Fellows  <donal.k.fellows@man.ac.uk>
 
 	* unix/dltest/pkgua.c: Fix minor syntax problems. [Bug 909288]
diff --git a/library/reg/pkgIndex.tcl b/library/reg/pkgIndex.tcl
index 55775f2..61c1d94 100755
--- a/library/reg/pkgIndex.tcl
+++ b/library/reg/pkgIndex.tcl
@@ -1,9 +1,9 @@
 if {![package vsatisfies [package provide Tcl] 8]} {return}
 if {[string compare $::tcl_platform(platform) windows]} {return}
 if {[info exists ::tcl_platform(debug)]} {
-    package ifneeded registry 1.1.3 \
+    package ifneeded registry 1.1.4 \
             [list load [file join $dir tclreg11g.dll] registry]
 } else {
-    package ifneeded registry 1.1.3 \
+    package ifneeded registry 1.1.4 \
             [list load [file join $dir tclreg11.dll] registry]
 }
diff --git a/win/tclWinReg.c b/win/tclWinReg.c
index 32aa940..29534c8 100644
--- a/win/tclWinReg.c
+++ b/win/tclWinReg.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: tclWinReg.c,v 1.25 2004/01/15 22:20:38 davygrvy Exp $
+ * RCS: @(#) $Id: tclWinReg.c,v 1.26 2004/03/04 15:10:42 patthoyts Exp $
  */
 
 #include <tclPort.h>
@@ -59,6 +59,8 @@ static HKEY rootKeys[] = {
     HKEY_CURRENT_CONFIG, HKEY_PERFORMANCE_DATA, HKEY_DYN_DATA
 };
 
+static CONST char REGISTRY_ASSOC_KEY[] = "registry::command";
+
 /*
  * The following table maps from registry types to strings.  Note that
  * the indices for this array are the same as the constants for the
@@ -165,6 +167,7 @@ static void		AppendSystemError(Tcl_Interp *interp, DWORD error);
 static int		BroadcastValue(Tcl_Interp *interp, int objc,
 			    Tcl_Obj * CONST objv[]);
 static DWORD		ConvertDWORD(DWORD type, DWORD value);
+static void		DeleteCmd(ClientData clientData);
 static int		DeleteKey(Tcl_Interp *interp, Tcl_Obj *keyNameObj);
 static int		DeleteValue(Tcl_Interp *interp, Tcl_Obj *keyNameObj,
 			    Tcl_Obj *valueNameObj);
@@ -194,6 +197,7 @@ static int		SetValue(Tcl_Interp *interp, Tcl_Obj *keyNameObj,
 			    Tcl_Obj *typeObj);
 
 EXTERN int Registry_Init(Tcl_Interp *interp);
+EXTERN int Registry_Unload(Tcl_Interp *interp, int flags);
 
 /*
  *----------------------------------------------------------------------
@@ -215,6 +219,8 @@ int
 Registry_Init(
     Tcl_Interp *interp)
 {
+    Tcl_Command cmd;
+
     if (Tcl_InitStubs(interp, "8.1", 0) == NULL) {
 	return TCL_ERROR;
     }
@@ -230,8 +236,79 @@ Registry_Init(
 	regWinProcs = &asciiProcs;
     }
 
-    Tcl_CreateObjCommand(interp, "registry", RegistryObjCmd, NULL, NULL);
-    return Tcl_PkgProvide(interp, "registry", "1.1.3");
+    cmd = Tcl_CreateObjCommand(interp, "registry", RegistryObjCmd,
+	(ClientData)interp, DeleteCmd);
+    Tcl_SetAssocData(interp, REGISTRY_ASSOC_KEY, NULL, (ClientData)cmd);
+    return Tcl_PkgProvide(interp, "registry", "1.1.4");
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * Registry_Unload --
+ *
+ *	This procedure removes the registry command.
+ *
+ * Results:
+ *	A standard Tcl result.
+ *
+ * Side effects:
+ *	The registry command is deleted and the dll may be unloaded.
+ *
+ *----------------------------------------------------------------------
+ */
+
+int
+Registry_Unload(
+    Tcl_Interp *interp,		/* Interpreter for unloading */
+    int flags)			/* Flags passed by the unload system */
+{
+    Tcl_Command cmd;
+    Tcl_Obj *objv[3];
+
+    /* 
+     * Unregister the registry package. There is no Tcl_PkgForget()
+     */
+
+    objv[0] = Tcl_NewStringObj("package", -1);
+    objv[1] = Tcl_NewStringObj("forget", -1);
+    objv[2] = Tcl_NewStringObj("registry", -1);
+    Tcl_EvalObjv(interp, 3, objv, TCL_EVAL_GLOBAL);
+
+    /*
+     * Delete the originally registered command.
+     */
+
+    cmd = (Tcl_Command)Tcl_GetAssocData(interp, REGISTRY_ASSOC_KEY, NULL);
+    if (cmd != NULL) {
+	Tcl_DeleteCommandFromToken(interp, cmd);
+    }
+
+    return TCL_OK;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * DeleteCmd --
+ *
+ *	Cleanup the interp command token so that unloading doesn't try
+ *	to re-delete the command (which will crash).
+ *
+ * Results:
+ *	None.
+ *
+ * Side effects:
+ *	The unload command will not attempt to delete this command.
+ *
+ *----------------------------------------------------------------------
+ */
+
+static void
+DeleteCmd(ClientData clientData)
+{
+    Tcl_Interp *interp = clientData;
+    Tcl_SetAssocData(interp, REGISTRY_ASSOC_KEY, NULL, (ClientData)NULL);
 }
 
 /*
@@ -258,7 +335,7 @@ RegistryObjCmd(
     Tcl_Obj * CONST objv[])	/* Argument values. */
 {
     int index;
-    char *errString;
+    char *errString = NULL;
 
     static CONST char *subcommands[] = {
 	"broadcast", "delete", "get", "keys", "set", "type", "values",