From c5e44485d15e28508cd8e8a7c7d6da2a6e777888 Mon Sep 17 00:00:00 2001 From: patthoyts Date: Thu, 4 Mar 2004 15:10:41 +0000 Subject: 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. --- ChangeLog | 7 ++++ library/reg/pkgIndex.tcl | 4 +-- win/tclWinReg.c | 85 +++++++++++++++++++++++++++++++++++++++++++++--- 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 + + * 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 * 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 @@ -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", -- cgit v0.12