/[dtapublic]/projs/dtats/trunk/shared_source/c_tcl_base_7_5_w_mods/tclwinreg.c
ViewVC logotype

Diff of /projs/dtats/trunk/shared_source/c_tcl_base_7_5_w_mods/tclwinreg.c

Parent Directory Parent Directory | Revision Log Revision Log | View Patch Patch

revision 67 by dashley, Mon Oct 31 00:57:34 2016 UTC revision 71 by dashley, Sat Nov 5 11:07:06 2016 UTC
# Line 1  Line 1 
1  /* $Header$ */  /* $Header$ */
2  /*  /*
3   * tclWinReg.c --   * tclWinReg.c --
4   *   *
5   *      This file contains the implementation of the "registry" Tcl   *      This file contains the implementation of the "registry" Tcl
6   *      built-in command.  This command is built as a dynamically   *      built-in command.  This command is built as a dynamically
7   *      loadable extension in a separate DLL.   *      loadable extension in a separate DLL.
8   *   *
9   * Copyright (c) 1997 by Sun Microsystems, Inc.   * Copyright (c) 1997 by Sun Microsystems, Inc.
10   * Copyright (c) 1998-1999 by Scriptics Corporation.   * Copyright (c) 1998-1999 by Scriptics Corporation.
11   *   *
12   * See the file "license.terms" for information on usage and redistribution   * See the file "license.terms" for information on usage and redistribution
13   * of this file, and for a DISCLAIMER OF ALL WARRANTIES.   * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
14   *   *
15   * RCS: @(#) $Id: tclwinreg.c,v 1.1.1.1 2001/06/13 04:50:03 dtashley Exp $   * RCS: @(#) $Id: tclwinreg.c,v 1.1.1.1 2001/06/13 04:50:03 dtashley Exp $
16   */   */
17    
18  #include <tclPort.h>  #include <tclPort.h>
19  #include <stdlib.h>  #include <stdlib.h>
20    
21  #define WIN32_LEAN_AND_MEAN  #define WIN32_LEAN_AND_MEAN
22  #include <windows.h>  #include <windows.h>
23  #undef WIN32_LEAN_AND_MEAN  #undef WIN32_LEAN_AND_MEAN
24    
25  /*  /*
26   * TCL_STORAGE_CLASS is set unconditionally to DLLEXPORT because the   * TCL_STORAGE_CLASS is set unconditionally to DLLEXPORT because the
27   * Registry_Init declaration is in the source file itself, which is only   * Registry_Init declaration is in the source file itself, which is only
28   * accessed when we are building a library.   * accessed when we are building a library.
29   */   */
30    
31  #undef TCL_STORAGE_CLASS  #undef TCL_STORAGE_CLASS
32  #define TCL_STORAGE_CLASS DLLEXPORT  #define TCL_STORAGE_CLASS DLLEXPORT
33    
34  /*  /*
35   * The following macros convert between different endian ints.   * The following macros convert between different endian ints.
36   */   */
37    
38  #define SWAPWORD(x) MAKEWORD(HIBYTE(x), LOBYTE(x))  #define SWAPWORD(x) MAKEWORD(HIBYTE(x), LOBYTE(x))
39  #define SWAPLONG(x) MAKELONG(SWAPWORD(HIWORD(x)), SWAPWORD(LOWORD(x)))  #define SWAPLONG(x) MAKELONG(SWAPWORD(HIWORD(x)), SWAPWORD(LOWORD(x)))
40    
41  /*  /*
42   * The following flag is used in OpenKeys to indicate that the specified   * The following flag is used in OpenKeys to indicate that the specified
43   * key should be created if it doesn't currently exist.   * key should be created if it doesn't currently exist.
44   */   */
45    
46  #define REG_CREATE 1  #define REG_CREATE 1
47    
48  /*  /*
49   * The following tables contain the mapping from registry root names   * The following tables contain the mapping from registry root names
50   * to the system predefined keys.   * to the system predefined keys.
51   */   */
52    
53  static char *rootKeyNames[] = {  static char *rootKeyNames[] = {
54      "HKEY_LOCAL_MACHINE", "HKEY_USERS", "HKEY_CLASSES_ROOT",      "HKEY_LOCAL_MACHINE", "HKEY_USERS", "HKEY_CLASSES_ROOT",
55      "HKEY_CURRENT_USER", "HKEY_CURRENT_CONFIG",      "HKEY_CURRENT_USER", "HKEY_CURRENT_CONFIG",
56      "HKEY_PERFORMANCE_DATA", "HKEY_DYN_DATA", NULL      "HKEY_PERFORMANCE_DATA", "HKEY_DYN_DATA", NULL
57  };  };
58    
59  static HKEY rootKeys[] = {  static HKEY rootKeys[] = {
60      HKEY_LOCAL_MACHINE, HKEY_USERS, HKEY_CLASSES_ROOT, HKEY_CURRENT_USER,      HKEY_LOCAL_MACHINE, HKEY_USERS, HKEY_CLASSES_ROOT, HKEY_CURRENT_USER,
61      HKEY_CURRENT_CONFIG, HKEY_PERFORMANCE_DATA, HKEY_DYN_DATA      HKEY_CURRENT_CONFIG, HKEY_PERFORMANCE_DATA, HKEY_DYN_DATA
62  };  };
63    
64  /*  /*
65   * The following table maps from registry types to strings.  Note that   * The following table maps from registry types to strings.  Note that
66   * the indices for this array are the same as the constants for the   * the indices for this array are the same as the constants for the
67   * known registry types so we don't need a separate table to hold the   * known registry types so we don't need a separate table to hold the
68   * mapping.   * mapping.
69   */   */
70    
71  static char *typeNames[] = {  static char *typeNames[] = {
72      "none", "sz", "expand_sz", "binary", "dword",      "none", "sz", "expand_sz", "binary", "dword",
73      "dword_big_endian", "link", "multi_sz", "resource_list", NULL      "dword_big_endian", "link", "multi_sz", "resource_list", NULL
74  };  };
75    
76  static DWORD lastType = REG_RESOURCE_LIST;  static DWORD lastType = REG_RESOURCE_LIST;
77    
78  /*  /*
79   * The following structures allow us to select between the Unicode and ASCII   * The following structures allow us to select between the Unicode and ASCII
80   * interfaces at run time based on whether Unicode APIs are available.  The   * interfaces at run time based on whether Unicode APIs are available.  The
81   * Unicode APIs are preferable because they will handle characters outside   * Unicode APIs are preferable because they will handle characters outside
82   * of the current code page.   * of the current code page.
83   */   */
84    
85  typedef struct RegWinProcs {  typedef struct RegWinProcs {
86      int useWide;      int useWide;
87    
88      LONG (WINAPI *regConnectRegistryProc)(TCHAR *, HKEY, PHKEY);      LONG (WINAPI *regConnectRegistryProc)(TCHAR *, HKEY, PHKEY);
89      LONG (WINAPI *regCreateKeyExProc)(HKEY, CONST TCHAR *, DWORD, TCHAR *,      LONG (WINAPI *regCreateKeyExProc)(HKEY, CONST TCHAR *, DWORD, TCHAR *,
90              DWORD, REGSAM, SECURITY_ATTRIBUTES *, HKEY *, DWORD *);              DWORD, REGSAM, SECURITY_ATTRIBUTES *, HKEY *, DWORD *);
91      LONG (WINAPI *regDeleteKeyProc)(HKEY, CONST TCHAR *);      LONG (WINAPI *regDeleteKeyProc)(HKEY, CONST TCHAR *);
92      LONG (WINAPI *regDeleteValueProc)(HKEY, CONST TCHAR *);      LONG (WINAPI *regDeleteValueProc)(HKEY, CONST TCHAR *);
93      LONG (WINAPI *regEnumKeyProc)(HKEY, DWORD, TCHAR *, DWORD);      LONG (WINAPI *regEnumKeyProc)(HKEY, DWORD, TCHAR *, DWORD);
94      LONG (WINAPI *regEnumKeyExProc)(HKEY, DWORD, TCHAR *, DWORD *, DWORD *,      LONG (WINAPI *regEnumKeyExProc)(HKEY, DWORD, TCHAR *, DWORD *, DWORD *,
95              TCHAR *, DWORD *, FILETIME *);              TCHAR *, DWORD *, FILETIME *);
96      LONG (WINAPI *regEnumValueProc)(HKEY, DWORD, TCHAR *, DWORD *, DWORD *,      LONG (WINAPI *regEnumValueProc)(HKEY, DWORD, TCHAR *, DWORD *, DWORD *,
97              DWORD *, BYTE *, DWORD *);              DWORD *, BYTE *, DWORD *);
98      LONG (WINAPI *regOpenKeyExProc)(HKEY, CONST TCHAR *, DWORD, REGSAM,      LONG (WINAPI *regOpenKeyExProc)(HKEY, CONST TCHAR *, DWORD, REGSAM,
99              HKEY *);              HKEY *);
100      LONG (WINAPI *regQueryInfoKeyProc)(HKEY, TCHAR *, DWORD *, DWORD *,      LONG (WINAPI *regQueryInfoKeyProc)(HKEY, TCHAR *, DWORD *, DWORD *,
101              DWORD *, DWORD *, DWORD *, DWORD *, DWORD *, DWORD *, DWORD *,              DWORD *, DWORD *, DWORD *, DWORD *, DWORD *, DWORD *, DWORD *,
102              FILETIME *);              FILETIME *);
103      LONG (WINAPI *regQueryValueExProc)(HKEY, CONST TCHAR *, DWORD *, DWORD *,      LONG (WINAPI *regQueryValueExProc)(HKEY, CONST TCHAR *, DWORD *, DWORD *,
104              BYTE *, DWORD *);              BYTE *, DWORD *);
105      LONG (WINAPI *regSetValueExProc)(HKEY, CONST TCHAR *, DWORD, DWORD,      LONG (WINAPI *regSetValueExProc)(HKEY, CONST TCHAR *, DWORD, DWORD,
106              CONST BYTE*, DWORD);              CONST BYTE*, DWORD);
107  } RegWinProcs;  } RegWinProcs;
108    
109  static RegWinProcs *regWinProcs;  static RegWinProcs *regWinProcs;
110    
111  static RegWinProcs asciiProcs = {  static RegWinProcs asciiProcs = {
112      0,      0,
113    
114      (LONG (WINAPI *)(TCHAR *, HKEY, PHKEY)) RegConnectRegistryA,      (LONG (WINAPI *)(TCHAR *, HKEY, PHKEY)) RegConnectRegistryA,
115      (LONG (WINAPI *)(HKEY, CONST TCHAR *, DWORD, TCHAR *,      (LONG (WINAPI *)(HKEY, CONST TCHAR *, DWORD, TCHAR *,
116              DWORD, REGSAM, SECURITY_ATTRIBUTES *, HKEY *,              DWORD, REGSAM, SECURITY_ATTRIBUTES *, HKEY *,
117              DWORD *)) RegCreateKeyExA,              DWORD *)) RegCreateKeyExA,
118      (LONG (WINAPI *)(HKEY, CONST TCHAR *)) RegDeleteKeyA,      (LONG (WINAPI *)(HKEY, CONST TCHAR *)) RegDeleteKeyA,
119      (LONG (WINAPI *)(HKEY, CONST TCHAR *)) RegDeleteValueA,      (LONG (WINAPI *)(HKEY, CONST TCHAR *)) RegDeleteValueA,
120      (LONG (WINAPI *)(HKEY, DWORD, TCHAR *, DWORD)) RegEnumKeyA,      (LONG (WINAPI *)(HKEY, DWORD, TCHAR *, DWORD)) RegEnumKeyA,
121      (LONG (WINAPI *)(HKEY, DWORD, TCHAR *, DWORD *, DWORD *,      (LONG (WINAPI *)(HKEY, DWORD, TCHAR *, DWORD *, DWORD *,
122              TCHAR *, DWORD *, FILETIME *)) RegEnumKeyExA,              TCHAR *, DWORD *, FILETIME *)) RegEnumKeyExA,
123      (LONG (WINAPI *)(HKEY, DWORD, TCHAR *, DWORD *, DWORD *,      (LONG (WINAPI *)(HKEY, DWORD, TCHAR *, DWORD *, DWORD *,
124              DWORD *, BYTE *, DWORD *)) RegEnumValueA,              DWORD *, BYTE *, DWORD *)) RegEnumValueA,
125      (LONG (WINAPI *)(HKEY, CONST TCHAR *, DWORD, REGSAM,      (LONG (WINAPI *)(HKEY, CONST TCHAR *, DWORD, REGSAM,
126              HKEY *)) RegOpenKeyExA,              HKEY *)) RegOpenKeyExA,
127      (LONG (WINAPI *)(HKEY, TCHAR *, DWORD *, DWORD *,      (LONG (WINAPI *)(HKEY, TCHAR *, DWORD *, DWORD *,
128              DWORD *, DWORD *, DWORD *, DWORD *, DWORD *, DWORD *, DWORD *,              DWORD *, DWORD *, DWORD *, DWORD *, DWORD *, DWORD *, DWORD *,
129              FILETIME *)) RegQueryInfoKeyA,              FILETIME *)) RegQueryInfoKeyA,
130      (LONG (WINAPI *)(HKEY, CONST TCHAR *, DWORD *, DWORD *,      (LONG (WINAPI *)(HKEY, CONST TCHAR *, DWORD *, DWORD *,
131              BYTE *, DWORD *)) RegQueryValueExA,              BYTE *, DWORD *)) RegQueryValueExA,
132      (LONG (WINAPI *)(HKEY, CONST TCHAR *, DWORD, DWORD,      (LONG (WINAPI *)(HKEY, CONST TCHAR *, DWORD, DWORD,
133              CONST BYTE*, DWORD)) RegSetValueExA,              CONST BYTE*, DWORD)) RegSetValueExA,
134  };  };
135    
136  static RegWinProcs unicodeProcs = {  static RegWinProcs unicodeProcs = {
137      1,      1,
138    
139      (LONG (WINAPI *)(TCHAR *, HKEY, PHKEY)) RegConnectRegistryW,      (LONG (WINAPI *)(TCHAR *, HKEY, PHKEY)) RegConnectRegistryW,
140      (LONG (WINAPI *)(HKEY, CONST TCHAR *, DWORD, TCHAR *,      (LONG (WINAPI *)(HKEY, CONST TCHAR *, DWORD, TCHAR *,
141              DWORD, REGSAM, SECURITY_ATTRIBUTES *, HKEY *,              DWORD, REGSAM, SECURITY_ATTRIBUTES *, HKEY *,
142              DWORD *)) RegCreateKeyExW,              DWORD *)) RegCreateKeyExW,
143      (LONG (WINAPI *)(HKEY, CONST TCHAR *)) RegDeleteKeyW,      (LONG (WINAPI *)(HKEY, CONST TCHAR *)) RegDeleteKeyW,
144      (LONG (WINAPI *)(HKEY, CONST TCHAR *)) RegDeleteValueW,      (LONG (WINAPI *)(HKEY, CONST TCHAR *)) RegDeleteValueW,
145      (LONG (WINAPI *)(HKEY, DWORD, TCHAR *, DWORD)) RegEnumKeyW,      (LONG (WINAPI *)(HKEY, DWORD, TCHAR *, DWORD)) RegEnumKeyW,
146      (LONG (WINAPI *)(HKEY, DWORD, TCHAR *, DWORD *, DWORD *,      (LONG (WINAPI *)(HKEY, DWORD, TCHAR *, DWORD *, DWORD *,
147              TCHAR *, DWORD *, FILETIME *)) RegEnumKeyExW,              TCHAR *, DWORD *, FILETIME *)) RegEnumKeyExW,
148      (LONG (WINAPI *)(HKEY, DWORD, TCHAR *, DWORD *, DWORD *,      (LONG (WINAPI *)(HKEY, DWORD, TCHAR *, DWORD *, DWORD *,
149              DWORD *, BYTE *, DWORD *)) RegEnumValueW,              DWORD *, BYTE *, DWORD *)) RegEnumValueW,
150      (LONG (WINAPI *)(HKEY, CONST TCHAR *, DWORD, REGSAM,      (LONG (WINAPI *)(HKEY, CONST TCHAR *, DWORD, REGSAM,
151              HKEY *)) RegOpenKeyExW,              HKEY *)) RegOpenKeyExW,
152      (LONG (WINAPI *)(HKEY, TCHAR *, DWORD *, DWORD *,      (LONG (WINAPI *)(HKEY, TCHAR *, DWORD *, DWORD *,
153              DWORD *, DWORD *, DWORD *, DWORD *, DWORD *, DWORD *, DWORD *,              DWORD *, DWORD *, DWORD *, DWORD *, DWORD *, DWORD *, DWORD *,
154              FILETIME *)) RegQueryInfoKeyW,              FILETIME *)) RegQueryInfoKeyW,
155      (LONG (WINAPI *)(HKEY, CONST TCHAR *, DWORD *, DWORD *,      (LONG (WINAPI *)(HKEY, CONST TCHAR *, DWORD *, DWORD *,
156              BYTE *, DWORD *)) RegQueryValueExW,              BYTE *, DWORD *)) RegQueryValueExW,
157      (LONG (WINAPI *)(HKEY, CONST TCHAR *, DWORD, DWORD,      (LONG (WINAPI *)(HKEY, CONST TCHAR *, DWORD, DWORD,
158              CONST BYTE*, DWORD)) RegSetValueExW,              CONST BYTE*, DWORD)) RegSetValueExW,
159  };  };
160    
161    
162  /*  /*
163   * Declarations for functions defined in this file.   * Declarations for functions defined in this file.
164   */   */
165    
166  static void             AppendSystemError(Tcl_Interp *interp, DWORD error);  static void             AppendSystemError(Tcl_Interp *interp, DWORD error);
167  static DWORD            ConvertDWORD(DWORD type, DWORD value);  static DWORD            ConvertDWORD(DWORD type, DWORD value);
168  static int              DeleteKey(Tcl_Interp *interp, Tcl_Obj *keyNameObj);  static int              DeleteKey(Tcl_Interp *interp, Tcl_Obj *keyNameObj);
169  static int              DeleteValue(Tcl_Interp *interp, Tcl_Obj *keyNameObj,  static int              DeleteValue(Tcl_Interp *interp, Tcl_Obj *keyNameObj,
170                              Tcl_Obj *valueNameObj);                              Tcl_Obj *valueNameObj);
171  static int              GetKeyNames(Tcl_Interp *interp, Tcl_Obj *keyNameObj,  static int              GetKeyNames(Tcl_Interp *interp, Tcl_Obj *keyNameObj,
172                              Tcl_Obj *patternObj);                              Tcl_Obj *patternObj);
173  static int              GetType(Tcl_Interp *interp, Tcl_Obj *keyNameObj,  static int              GetType(Tcl_Interp *interp, Tcl_Obj *keyNameObj,
174                              Tcl_Obj *valueNameObj);                              Tcl_Obj *valueNameObj);
175  static int              GetValue(Tcl_Interp *interp, Tcl_Obj *keyNameObj,  static int              GetValue(Tcl_Interp *interp, Tcl_Obj *keyNameObj,
176                              Tcl_Obj *valueNameObj);                              Tcl_Obj *valueNameObj);
177  static int              GetValueNames(Tcl_Interp *interp, Tcl_Obj *keyNameObj,  static int              GetValueNames(Tcl_Interp *interp, Tcl_Obj *keyNameObj,
178                              Tcl_Obj *patternObj);                              Tcl_Obj *patternObj);
179  static int              OpenKey(Tcl_Interp *interp, Tcl_Obj *keyNameObj,  static int              OpenKey(Tcl_Interp *interp, Tcl_Obj *keyNameObj,
180                              REGSAM mode, int flags, HKEY *keyPtr);                              REGSAM mode, int flags, HKEY *keyPtr);
181  static DWORD            OpenSubKey(char *hostName, HKEY rootKey,  static DWORD            OpenSubKey(char *hostName, HKEY rootKey,
182                              char *keyName, REGSAM mode, int flags,                              char *keyName, REGSAM mode, int flags,
183                              HKEY *keyPtr);                              HKEY *keyPtr);
184  static int              ParseKeyName(Tcl_Interp *interp, char *name,  static int              ParseKeyName(Tcl_Interp *interp, char *name,
185                              char **hostNamePtr, HKEY *rootKeyPtr,                              char **hostNamePtr, HKEY *rootKeyPtr,
186                              char **keyNamePtr);                              char **keyNamePtr);
187  static DWORD            RecursiveDeleteKey(HKEY hStartKey, TCHAR * pKeyName);  static DWORD            RecursiveDeleteKey(HKEY hStartKey, TCHAR * pKeyName);
188  static int              RegistryObjCmd(ClientData clientData,  static int              RegistryObjCmd(ClientData clientData,
189                              Tcl_Interp *interp, int objc,                              Tcl_Interp *interp, int objc,
190                              Tcl_Obj * CONST objv[]);                              Tcl_Obj * CONST objv[]);
191  static int              SetValue(Tcl_Interp *interp, Tcl_Obj *keyNameObj,  static int              SetValue(Tcl_Interp *interp, Tcl_Obj *keyNameObj,
192                              Tcl_Obj *valueNameObj, Tcl_Obj *dataObj,                              Tcl_Obj *valueNameObj, Tcl_Obj *dataObj,
193                              Tcl_Obj *typeObj);                              Tcl_Obj *typeObj);
194    
195  EXTERN int Registry_Init(Tcl_Interp *interp);  EXTERN int Registry_Init(Tcl_Interp *interp);
196    
197  /*  /*
198   *----------------------------------------------------------------------   *----------------------------------------------------------------------
199   *   *
200   * Registry_Init --   * Registry_Init --
201   *   *
202   *      This procedure initializes the registry command.   *      This procedure initializes the registry command.
203   *   *
204   * Results:   * Results:
205   *      A standard Tcl result.   *      A standard Tcl result.
206   *   *
207   * Side effects:   * Side effects:
208   *      None.   *      None.
209   *   *
210   *----------------------------------------------------------------------   *----------------------------------------------------------------------
211   */   */
212    
213  int  int
214  Registry_Init(  Registry_Init(
215      Tcl_Interp *interp)      Tcl_Interp *interp)
216  {  {
217      if (!Tcl_InitStubs(interp, "8.0", 0)) {      if (!Tcl_InitStubs(interp, "8.0", 0)) {
218          return TCL_ERROR;          return TCL_ERROR;
219      }      }
220    
221      /*      /*
222       * Determine if the unicode interfaces are available and select the       * Determine if the unicode interfaces are available and select the
223       * appropriate registry function table.       * appropriate registry function table.
224       */       */
225    
226      if (TclWinGetPlatformId() == VER_PLATFORM_WIN32_NT) {      if (TclWinGetPlatformId() == VER_PLATFORM_WIN32_NT) {
227          regWinProcs = &unicodeProcs;          regWinProcs = &unicodeProcs;
228      } else {      } else {
229          regWinProcs = &asciiProcs;          regWinProcs = &asciiProcs;
230      }      }
231    
232      Tcl_CreateObjCommand(interp, "registry", RegistryObjCmd, NULL, NULL);      Tcl_CreateObjCommand(interp, "registry", RegistryObjCmd, NULL, NULL);
233      return Tcl_PkgProvide(interp, "registry", "1.0");      return Tcl_PkgProvide(interp, "registry", "1.0");
234  }  }
235    
236  /*  /*
237   *----------------------------------------------------------------------   *----------------------------------------------------------------------
238   *   *
239   * RegistryObjCmd --   * RegistryObjCmd --
240   *   *
241   *      This function implements the Tcl "registry" command.   *      This function implements the Tcl "registry" command.
242   *   *
243   * Results:   * Results:
244   *      A standard Tcl result.   *      A standard Tcl result.
245   *   *
246   * Side effects:   * Side effects:
247   *      None.   *      None.
248   *   *
249   *----------------------------------------------------------------------   *----------------------------------------------------------------------
250   */   */
251    
252  static int  static int
253  RegistryObjCmd(  RegistryObjCmd(
254      ClientData clientData,      /* Not used. */      ClientData clientData,      /* Not used. */
255      Tcl_Interp *interp,         /* Current interpreter. */      Tcl_Interp *interp,         /* Current interpreter. */
256      int objc,                   /* Number of arguments. */      int objc,                   /* Number of arguments. */
257      Tcl_Obj * CONST objv[])     /* Argument values. */      Tcl_Obj * CONST objv[])     /* Argument values. */
258  {  {
259      int index;      int index;
260      char *errString;      char *errString;
261    
262      static char *subcommands[] = { "delete", "get", "keys", "set", "type",      static char *subcommands[] = { "delete", "get", "keys", "set", "type",
263                                     "values", (char *) NULL };                                     "values", (char *) NULL };
264      enum SubCmdIdx { DeleteIdx, GetIdx, KeysIdx, SetIdx, TypeIdx, ValuesIdx };      enum SubCmdIdx { DeleteIdx, GetIdx, KeysIdx, SetIdx, TypeIdx, ValuesIdx };
265    
266      if (objc < 2) {      if (objc < 2) {
267          Tcl_WrongNumArgs(interp, objc, objv, "option ?arg arg ...?");          Tcl_WrongNumArgs(interp, objc, objv, "option ?arg arg ...?");
268          return TCL_ERROR;          return TCL_ERROR;
269      }      }
270    
271      if (Tcl_GetIndexFromObj(interp, objv[1], subcommands, "option", 0, &index)      if (Tcl_GetIndexFromObj(interp, objv[1], subcommands, "option", 0, &index)
272              != TCL_OK) {              != TCL_OK) {
273          return TCL_ERROR;          return TCL_ERROR;
274      }      }
275    
276      switch (index) {      switch (index) {
277          case DeleteIdx:                 /* delete */          case DeleteIdx:                 /* delete */
278              if (objc == 3) {              if (objc == 3) {
279                  return DeleteKey(interp, objv[2]);                  return DeleteKey(interp, objv[2]);
280              } else if (objc == 4) {              } else if (objc == 4) {
281                  return DeleteValue(interp, objv[2], objv[3]);                  return DeleteValue(interp, objv[2], objv[3]);
282              }              }
283              errString = "keyName ?valueName?";              errString = "keyName ?valueName?";
284              break;              break;
285          case GetIdx:                    /* get */          case GetIdx:                    /* get */
286              if (objc == 4) {              if (objc == 4) {
287                  return GetValue(interp, objv[2], objv[3]);                  return GetValue(interp, objv[2], objv[3]);
288              }              }
289              errString = "keyName valueName";              errString = "keyName valueName";
290              break;              break;
291          case KeysIdx:                   /* keys */          case KeysIdx:                   /* keys */
292              if (objc == 3) {              if (objc == 3) {
293                  return GetKeyNames(interp, objv[2], NULL);                  return GetKeyNames(interp, objv[2], NULL);
294              } else if (objc == 4) {              } else if (objc == 4) {
295                  return GetKeyNames(interp, objv[2], objv[3]);                  return GetKeyNames(interp, objv[2], objv[3]);
296              }              }
297              errString = "keyName ?pattern?";              errString = "keyName ?pattern?";
298              break;              break;
299          case SetIdx:                    /* set */          case SetIdx:                    /* set */
300              if (objc == 3) {              if (objc == 3) {
301                  HKEY key;                  HKEY key;
302    
303                  /*                  /*
304                   * Create the key and then close it immediately.                   * Create the key and then close it immediately.
305                   */                   */
306    
307                  if (OpenKey(interp, objv[2], KEY_ALL_ACCESS, 1, &key)                  if (OpenKey(interp, objv[2], KEY_ALL_ACCESS, 1, &key)
308                          != TCL_OK) {                          != TCL_OK) {
309                      return TCL_ERROR;                      return TCL_ERROR;
310                  }                  }
311                  RegCloseKey(key);                  RegCloseKey(key);
312                  return TCL_OK;                  return TCL_OK;
313              } else if (objc == 5 || objc == 6) {              } else if (objc == 5 || objc == 6) {
314                  Tcl_Obj *typeObj = (objc == 5) ? NULL : objv[5];                  Tcl_Obj *typeObj = (objc == 5) ? NULL : objv[5];
315                  return SetValue(interp, objv[2], objv[3], objv[4], typeObj);                  return SetValue(interp, objv[2], objv[3], objv[4], typeObj);
316              }              }
317              errString = "keyName ?valueName data ?type??";              errString = "keyName ?valueName data ?type??";
318              break;              break;
319          case TypeIdx:                   /* type */          case TypeIdx:                   /* type */
320              if (objc == 4) {              if (objc == 4) {
321                  return GetType(interp, objv[2], objv[3]);                  return GetType(interp, objv[2], objv[3]);
322              }              }
323              errString = "keyName valueName";              errString = "keyName valueName";
324              break;              break;
325          case ValuesIdx:                 /* values */          case ValuesIdx:                 /* values */
326              if (objc == 3) {              if (objc == 3) {
327                  return GetValueNames(interp, objv[2], NULL);                  return GetValueNames(interp, objv[2], NULL);
328              } else if (objc == 4) {              } else if (objc == 4) {
329                  return GetValueNames(interp, objv[2], objv[3]);                  return GetValueNames(interp, objv[2], objv[3]);
330              }              }
331              errString = "keyName ?pattern?";              errString = "keyName ?pattern?";
332              break;              break;
333      }      }
334      Tcl_WrongNumArgs(interp, 2, objv, errString);      Tcl_WrongNumArgs(interp, 2, objv, errString);
335      return TCL_ERROR;      return TCL_ERROR;
336  }  }
337    
338  /*  /*
339   *----------------------------------------------------------------------   *----------------------------------------------------------------------
340   *   *
341   * DeleteKey --   * DeleteKey --
342   *   *
343   *      This function deletes a registry key.   *      This function deletes a registry key.
344   *   *
345   * Results:   * Results:
346   *      A standard Tcl result.   *      A standard Tcl result.
347   *   *
348   * Side effects:   * Side effects:
349   *      None.   *      None.
350   *   *
351   *----------------------------------------------------------------------   *----------------------------------------------------------------------
352   */   */
353    
354  static int  static int
355  DeleteKey(  DeleteKey(
356      Tcl_Interp *interp,         /* Current interpreter. */      Tcl_Interp *interp,         /* Current interpreter. */
357      Tcl_Obj *keyNameObj)        /* Name of key to delete. */      Tcl_Obj *keyNameObj)        /* Name of key to delete. */
358  {  {
359      char *tail, *buffer, *hostName, *keyName;      char *tail, *buffer, *hostName, *keyName;
360      HKEY rootKey, subkey;      HKEY rootKey, subkey;
361      DWORD result;      DWORD result;
362      int length;      int length;
363      Tcl_Obj *resultPtr;      Tcl_Obj *resultPtr;
364      Tcl_DString buf;      Tcl_DString buf;
365    
366      /*      /*
367       * Find the parent of the key being deleted and open it.       * Find the parent of the key being deleted and open it.
368       */       */
369    
370      keyName = Tcl_GetStringFromObj(keyNameObj, &length);      keyName = Tcl_GetStringFromObj(keyNameObj, &length);
371      buffer = ckalloc(length + 1);      buffer = ckalloc(length + 1);
372      strcpy(buffer, keyName);      strcpy(buffer, keyName);
373    
374      if (ParseKeyName(interp, buffer, &hostName, &rootKey, &keyName)      if (ParseKeyName(interp, buffer, &hostName, &rootKey, &keyName)
375              != TCL_OK) {              != TCL_OK) {
376          ckfree(buffer);          ckfree(buffer);
377          return TCL_ERROR;          return TCL_ERROR;
378      }      }
379    
380      resultPtr = Tcl_GetObjResult(interp);      resultPtr = Tcl_GetObjResult(interp);
381      if (*keyName == '\0') {      if (*keyName == '\0') {
382          Tcl_AppendToObj(resultPtr, "bad key: cannot delete root keys", -1);          Tcl_AppendToObj(resultPtr, "bad key: cannot delete root keys", -1);
383          ckfree(buffer);          ckfree(buffer);
384          return TCL_ERROR;          return TCL_ERROR;
385      }      }
386    
387      tail = strrchr(keyName, '\\');      tail = strrchr(keyName, '\\');
388      if (tail) {      if (tail) {
389          *tail++ = '\0';          *tail++ = '\0';
390      } else {      } else {
391          tail = keyName;          tail = keyName;
392          keyName = NULL;          keyName = NULL;
393      }      }
394    
395      result = OpenSubKey(hostName, rootKey, keyName,      result = OpenSubKey(hostName, rootKey, keyName,
396              KEY_ENUMERATE_SUB_KEYS | DELETE, 0, &subkey);              KEY_ENUMERATE_SUB_KEYS | DELETE, 0, &subkey);
397      if (result != ERROR_SUCCESS) {      if (result != ERROR_SUCCESS) {
398          ckfree(buffer);          ckfree(buffer);
399          if (result == ERROR_FILE_NOT_FOUND) {          if (result == ERROR_FILE_NOT_FOUND) {
400              return TCL_OK;              return TCL_OK;
401          } else {          } else {
402              Tcl_AppendToObj(resultPtr, "unable to delete key: ", -1);              Tcl_AppendToObj(resultPtr, "unable to delete key: ", -1);
403              AppendSystemError(interp, result);              AppendSystemError(interp, result);
404              return TCL_ERROR;              return TCL_ERROR;
405          }          }
406      }      }
407    
408      /*      /*
409       * Now we recursively delete the key and everything below it.       * Now we recursively delete the key and everything below it.
410       */       */
411    
412      tail = Tcl_WinUtfToTChar(tail, -1, &buf);      tail = Tcl_WinUtfToTChar(tail, -1, &buf);
413      result = RecursiveDeleteKey(subkey, tail);      result = RecursiveDeleteKey(subkey, tail);
414      Tcl_DStringFree(&buf);      Tcl_DStringFree(&buf);
415    
416      if (result != ERROR_SUCCESS && result != ERROR_FILE_NOT_FOUND) {      if (result != ERROR_SUCCESS && result != ERROR_FILE_NOT_FOUND) {
417          Tcl_AppendToObj(resultPtr, "unable to delete key: ", -1);          Tcl_AppendToObj(resultPtr, "unable to delete key: ", -1);
418          AppendSystemError(interp, result);          AppendSystemError(interp, result);
419          result = TCL_ERROR;          result = TCL_ERROR;
420      } else {      } else {
421          result = TCL_OK;          result = TCL_OK;
422      }      }
423    
424      RegCloseKey(subkey);      RegCloseKey(subkey);
425      ckfree(buffer);      ckfree(buffer);
426      return result;      return result;
427  }  }
428    
429  /*  /*
430   *----------------------------------------------------------------------   *----------------------------------------------------------------------
431   *   *
432   * DeleteValue --   * DeleteValue --
433   *   *
434   *      This function deletes a value from a registry key.   *      This function deletes a value from a registry key.
435   *   *
436   * Results:   * Results:
437   *      A standard Tcl result.   *      A standard Tcl result.
438   *   *
439   * Side effects:   * Side effects:
440   *      None.   *      None.
441   *   *
442   *----------------------------------------------------------------------   *----------------------------------------------------------------------
443   */   */
444    
445  static int  static int
446  DeleteValue(  DeleteValue(
447      Tcl_Interp *interp,         /* Current interpreter. */      Tcl_Interp *interp,         /* Current interpreter. */
448      Tcl_Obj *keyNameObj,        /* Name of key. */      Tcl_Obj *keyNameObj,        /* Name of key. */
449      Tcl_Obj *valueNameObj)      /* Name of value to delete. */      Tcl_Obj *valueNameObj)      /* Name of value to delete. */
450  {  {
451      HKEY key;      HKEY key;
452      char *valueName;      char *valueName;
453      int length;      int length;
454      DWORD result;      DWORD result;
455      Tcl_Obj *resultPtr;      Tcl_Obj *resultPtr;
456      Tcl_DString ds;      Tcl_DString ds;
457    
458      /*      /*
459       * Attempt to open the key for deletion.       * Attempt to open the key for deletion.
460       */       */
461    
462      if (OpenKey(interp, keyNameObj, KEY_SET_VALUE, 0, &key)      if (OpenKey(interp, keyNameObj, KEY_SET_VALUE, 0, &key)
463              != TCL_OK) {              != TCL_OK) {
464          return TCL_ERROR;          return TCL_ERROR;
465      }      }
466    
467      resultPtr = Tcl_GetObjResult(interp);      resultPtr = Tcl_GetObjResult(interp);
468      valueName = Tcl_GetStringFromObj(valueNameObj, &length);      valueName = Tcl_GetStringFromObj(valueNameObj, &length);
469      Tcl_WinUtfToTChar(valueName, length, &ds);      Tcl_WinUtfToTChar(valueName, length, &ds);
470      result = (*regWinProcs->regDeleteValueProc)(key, Tcl_DStringValue(&ds));      result = (*regWinProcs->regDeleteValueProc)(key, Tcl_DStringValue(&ds));
471      Tcl_DStringFree(&ds);      Tcl_DStringFree(&ds);
472      if (result != ERROR_SUCCESS) {      if (result != ERROR_SUCCESS) {
473          Tcl_AppendStringsToObj(resultPtr, "unable to delete value \"",          Tcl_AppendStringsToObj(resultPtr, "unable to delete value \"",
474                  Tcl_GetString(valueNameObj), "\" from key \"",                  Tcl_GetString(valueNameObj), "\" from key \"",
475                  Tcl_GetString(keyNameObj), "\": ", NULL);                  Tcl_GetString(keyNameObj), "\": ", NULL);
476          AppendSystemError(interp, result);          AppendSystemError(interp, result);
477          result = TCL_ERROR;          result = TCL_ERROR;
478      } else {      } else {
479          result = TCL_OK;          result = TCL_OK;
480      }      }
481      RegCloseKey(key);      RegCloseKey(key);
482      return result;      return result;
483  }  }
484    
485  /*  /*
486   *----------------------------------------------------------------------   *----------------------------------------------------------------------
487   *   *
488   * GetKeyNames --   * GetKeyNames --
489   *   *
490   *      This function enumerates the subkeys of a given key.  If the   *      This function enumerates the subkeys of a given key.  If the
491   *      optional pattern is supplied, then only keys that match the   *      optional pattern is supplied, then only keys that match the
492   *      pattern will be returned.   *      pattern will be returned.
493   *   *
494   * Results:   * Results:
495   *      Returns the list of subkeys in the result object of the   *      Returns the list of subkeys in the result object of the
496   *      interpreter, or an error message on failure.   *      interpreter, or an error message on failure.
497   *   *
498   * Side effects:   * Side effects:
499   *      None.   *      None.
500   *   *
501   *----------------------------------------------------------------------   *----------------------------------------------------------------------
502   */   */
503    
504  static int  static int
505  GetKeyNames(  GetKeyNames(
506      Tcl_Interp *interp,         /* Current interpreter. */      Tcl_Interp *interp,         /* Current interpreter. */
507      Tcl_Obj *keyNameObj,        /* Key to enumerate. */      Tcl_Obj *keyNameObj,        /* Key to enumerate. */
508      Tcl_Obj *patternObj)        /* Optional match pattern. */      Tcl_Obj *patternObj)        /* Optional match pattern. */
509  {  {
510      HKEY key;      HKEY key;
511      DWORD index;      DWORD index;
512      char buffer[MAX_PATH+1], *pattern, *name;      char buffer[MAX_PATH+1], *pattern, *name;
513      Tcl_Obj *resultPtr;      Tcl_Obj *resultPtr;
514      int result = TCL_OK;      int result = TCL_OK;
515      Tcl_DString ds;      Tcl_DString ds;
516    
517      /*      /*
518       * Attempt to open the key for enumeration.       * Attempt to open the key for enumeration.
519       */       */
520    
521      if (OpenKey(interp, keyNameObj, KEY_ENUMERATE_SUB_KEYS, 0, &key)      if (OpenKey(interp, keyNameObj, KEY_ENUMERATE_SUB_KEYS, 0, &key)
522              != TCL_OK) {              != TCL_OK) {
523          return TCL_ERROR;          return TCL_ERROR;
524      }      }
525    
526      if (patternObj) {      if (patternObj) {
527          pattern = Tcl_GetString(patternObj);          pattern = Tcl_GetString(patternObj);
528      } else {      } else {
529          pattern = NULL;          pattern = NULL;
530      }      }
531    
532      /*      /*
533       * Enumerate over the subkeys until we get an error, indicating the       * Enumerate over the subkeys until we get an error, indicating the
534       * end of the list.       * end of the list.
535       */       */
536    
537      resultPtr = Tcl_GetObjResult(interp);      resultPtr = Tcl_GetObjResult(interp);
538      for (index = 0; (*regWinProcs->regEnumKeyProc)(key, index, buffer,      for (index = 0; (*regWinProcs->regEnumKeyProc)(key, index, buffer,
539              MAX_PATH+1) == ERROR_SUCCESS; index++) {              MAX_PATH+1) == ERROR_SUCCESS; index++) {
540          Tcl_WinTCharToUtf((TCHAR *) buffer, -1, &ds);          Tcl_WinTCharToUtf((TCHAR *) buffer, -1, &ds);
541          name = Tcl_DStringValue(&ds);          name = Tcl_DStringValue(&ds);
542          if (pattern && !Tcl_StringMatch(name, pattern)) {          if (pattern && !Tcl_StringMatch(name, pattern)) {
543              Tcl_DStringFree(&ds);              Tcl_DStringFree(&ds);
544              continue;              continue;
545          }          }
546          result = Tcl_ListObjAppendElement(interp, resultPtr,          result = Tcl_ListObjAppendElement(interp, resultPtr,
547                  Tcl_NewStringObj(name, Tcl_DStringLength(&ds)));                  Tcl_NewStringObj(name, Tcl_DStringLength(&ds)));
548          Tcl_DStringFree(&ds);          Tcl_DStringFree(&ds);
549          if (result != TCL_OK) {          if (result != TCL_OK) {
550              break;              break;
551          }          }
552      }      }
553    
554      RegCloseKey(key);      RegCloseKey(key);
555      return result;      return result;
556  }  }
557    
558  /*  /*
559   *----------------------------------------------------------------------   *----------------------------------------------------------------------
560   *   *
561   * GetType --   * GetType --
562   *   *
563   *      This function gets the type of a given registry value and   *      This function gets the type of a given registry value and
564   *      places it in the interpreter result.   *      places it in the interpreter result.
565   *   *
566   * Results:   * Results:
567   *      Returns a normal Tcl result.   *      Returns a normal Tcl result.
568   *   *
569   * Side effects:   * Side effects:
570   *      None.   *      None.
571   *   *
572   *----------------------------------------------------------------------   *----------------------------------------------------------------------
573   */   */
574    
575  static int  static int
576  GetType(  GetType(
577      Tcl_Interp *interp,         /* Current interpreter. */      Tcl_Interp *interp,         /* Current interpreter. */
578      Tcl_Obj *keyNameObj,        /* Name of key. */      Tcl_Obj *keyNameObj,        /* Name of key. */
579      Tcl_Obj *valueNameObj)      /* Name of value to get. */      Tcl_Obj *valueNameObj)      /* Name of value to get. */
580  {  {
581      HKEY key;      HKEY key;
582      Tcl_Obj *resultPtr;      Tcl_Obj *resultPtr;
583      DWORD result;      DWORD result;
584      DWORD type;      DWORD type;
585      Tcl_DString ds;      Tcl_DString ds;
586      char *valueName;      char *valueName;
587      int length;      int length;
588    
589      /*      /*
590       * Attempt to open the key for reading.       * Attempt to open the key for reading.
591       */       */
592    
593      if (OpenKey(interp, keyNameObj, KEY_QUERY_VALUE, 0, &key)      if (OpenKey(interp, keyNameObj, KEY_QUERY_VALUE, 0, &key)
594              != TCL_OK) {              != TCL_OK) {
595          return TCL_ERROR;          return TCL_ERROR;
596      }      }
597    
598      /*      /*
599       * Get the type of the value.       * Get the type of the value.
600       */       */
601    
602      resultPtr = Tcl_GetObjResult(interp);      resultPtr = Tcl_GetObjResult(interp);
603    
604      valueName = Tcl_GetStringFromObj(valueNameObj, &length);      valueName = Tcl_GetStringFromObj(valueNameObj, &length);
605      valueName = Tcl_WinUtfToTChar(valueName, length, &ds);      valueName = Tcl_WinUtfToTChar(valueName, length, &ds);
606      result = (*regWinProcs->regQueryValueExProc)(key, valueName, NULL, &type,      result = (*regWinProcs->regQueryValueExProc)(key, valueName, NULL, &type,
607              NULL, NULL);              NULL, NULL);
608      Tcl_DStringFree(&ds);      Tcl_DStringFree(&ds);
609      RegCloseKey(key);      RegCloseKey(key);
610    
611      if (result != ERROR_SUCCESS) {      if (result != ERROR_SUCCESS) {
612          Tcl_AppendStringsToObj(resultPtr, "unable to get type of value \"",          Tcl_AppendStringsToObj(resultPtr, "unable to get type of value \"",
613                  Tcl_GetString(valueNameObj), "\" from key \"",                  Tcl_GetString(valueNameObj), "\" from key \"",
614                  Tcl_GetString(keyNameObj), "\": ", NULL);                  Tcl_GetString(keyNameObj), "\": ", NULL);
615          AppendSystemError(interp, result);          AppendSystemError(interp, result);
616          return TCL_ERROR;          return TCL_ERROR;
617      }      }
618    
619      /*      /*
620       * Set the type into the result.  Watch out for unknown types.       * Set the type into the result.  Watch out for unknown types.
621       * If we don't know about the type, just use the numeric value.       * If we don't know about the type, just use the numeric value.
622       */       */
623    
624      if (type > lastType || type < 0) {      if (type > lastType || type < 0) {
625          Tcl_SetIntObj(resultPtr, type);          Tcl_SetIntObj(resultPtr, type);
626      } else {      } else {
627          Tcl_SetStringObj(resultPtr, typeNames[type], -1);          Tcl_SetStringObj(resultPtr, typeNames[type], -1);
628      }      }
629      return TCL_OK;      return TCL_OK;
630  }  }
631    
632  /*  /*
633   *----------------------------------------------------------------------   *----------------------------------------------------------------------
634   *   *
635   * GetValue --   * GetValue --
636   *   *
637   *      This function gets the contents of a registry value and places   *      This function gets the contents of a registry value and places
638   *      a list containing the data and the type in the interpreter   *      a list containing the data and the type in the interpreter
639   *      result.   *      result.
640   *   *
641   * Results:   * Results:
642   *      Returns a normal Tcl result.   *      Returns a normal Tcl result.
643   *   *
644   * Side effects:   * Side effects:
645   *      None.   *      None.
646   *   *
647   *----------------------------------------------------------------------   *----------------------------------------------------------------------
648   */   */
649    
650  static int  static int
651  GetValue(  GetValue(
652      Tcl_Interp *interp,         /* Current interpreter. */      Tcl_Interp *interp,         /* Current interpreter. */
653      Tcl_Obj *keyNameObj,        /* Name of key. */      Tcl_Obj *keyNameObj,        /* Name of key. */
654      Tcl_Obj *valueNameObj)      /* Name of value to get. */      Tcl_Obj *valueNameObj)      /* Name of value to get. */
655  {  {
656      HKEY key;      HKEY key;
657      char *valueName;      char *valueName;
658      DWORD result, length, type;      DWORD result, length, type;
659      Tcl_Obj *resultPtr;      Tcl_Obj *resultPtr;
660      Tcl_DString data, buf;      Tcl_DString data, buf;
661      int nameLen;      int nameLen;
662    
663      /*      /*
664       * Attempt to open the key for reading.       * Attempt to open the key for reading.
665       */       */
666    
667      if (OpenKey(interp, keyNameObj, KEY_QUERY_VALUE, 0, &key)      if (OpenKey(interp, keyNameObj, KEY_QUERY_VALUE, 0, &key)
668              != TCL_OK) {              != TCL_OK) {
669          return TCL_ERROR;          return TCL_ERROR;
670      }      }
671    
672      /*      /*
673       * Initialize a Dstring to maximum statically allocated size       * Initialize a Dstring to maximum statically allocated size
674       * we could get one more byte by avoiding Tcl_DStringSetLength()       * we could get one more byte by avoiding Tcl_DStringSetLength()
675       * and just setting length to TCL_DSTRING_STATIC_SIZE, but this       * and just setting length to TCL_DSTRING_STATIC_SIZE, but this
676       * should be safer if the implementation of Dstrings changes.       * should be safer if the implementation of Dstrings changes.
677       *       *
678       * This allows short values to be read from the registy in one call.       * This allows short values to be read from the registy in one call.
679       * Longer values need a second call with an expanded DString.       * Longer values need a second call with an expanded DString.
680       */       */
681    
682      Tcl_DStringInit(&data);      Tcl_DStringInit(&data);
683      length = TCL_DSTRING_STATIC_SIZE - 1;      length = TCL_DSTRING_STATIC_SIZE - 1;
684      Tcl_DStringSetLength(&data, length);      Tcl_DStringSetLength(&data, length);
685    
686      resultPtr = Tcl_GetObjResult(interp);      resultPtr = Tcl_GetObjResult(interp);
687    
688      valueName = Tcl_GetStringFromObj(valueNameObj, &nameLen);      valueName = Tcl_GetStringFromObj(valueNameObj, &nameLen);
689      valueName = Tcl_WinUtfToTChar(valueName, nameLen, &buf);      valueName = Tcl_WinUtfToTChar(valueName, nameLen, &buf);
690    
691      result = (*regWinProcs->regQueryValueExProc)(key, valueName, NULL, &type,      result = (*regWinProcs->regQueryValueExProc)(key, valueName, NULL, &type,
692              (BYTE *) Tcl_DStringValue(&data), &length);              (BYTE *) Tcl_DStringValue(&data), &length);
693      while (result == ERROR_MORE_DATA) {      while (result == ERROR_MORE_DATA) {
694          /*          /*
695           * The Windows docs say that in this error case, we just need           * The Windows docs say that in this error case, we just need
696           * to expand our buffer and request more data.           * to expand our buffer and request more data.
697           * Required for HKEY_PERFORMANCE_DATA           * Required for HKEY_PERFORMANCE_DATA
698           */           */
699          length *= 2;          length *= 2;
700          Tcl_DStringSetLength(&data, length);          Tcl_DStringSetLength(&data, length);
701          result = (*regWinProcs->regQueryValueExProc)(key, valueName, NULL,          result = (*regWinProcs->regQueryValueExProc)(key, valueName, NULL,
702                  &type, (BYTE *) Tcl_DStringValue(&data), &length);                  &type, (BYTE *) Tcl_DStringValue(&data), &length);
703      }      }
704      Tcl_DStringFree(&buf);      Tcl_DStringFree(&buf);
705      RegCloseKey(key);      RegCloseKey(key);
706      if (result != ERROR_SUCCESS) {      if (result != ERROR_SUCCESS) {
707          Tcl_AppendStringsToObj(resultPtr, "unable to get value \"",          Tcl_AppendStringsToObj(resultPtr, "unable to get value \"",
708                  Tcl_GetString(valueNameObj), "\" from key \"",                  Tcl_GetString(valueNameObj), "\" from key \"",
709                  Tcl_GetString(keyNameObj), "\": ", NULL);                  Tcl_GetString(keyNameObj), "\": ", NULL);
710          AppendSystemError(interp, result);          AppendSystemError(interp, result);
711          Tcl_DStringFree(&data);          Tcl_DStringFree(&data);
712          return TCL_ERROR;          return TCL_ERROR;
713      }      }
714    
715      /*      /*
716       * If the data is a 32-bit quantity, store it as an integer object.  If it       * If the data is a 32-bit quantity, store it as an integer object.  If it
717       * is a multi-string, store it as a list of strings.  For null-terminated       * is a multi-string, store it as a list of strings.  For null-terminated
718       * strings, append up the to first null.  Otherwise, store it as a binary       * strings, append up the to first null.  Otherwise, store it as a binary
719       * string.       * string.
720       */       */
721    
722      if (type == REG_DWORD || type == REG_DWORD_BIG_ENDIAN) {      if (type == REG_DWORD || type == REG_DWORD_BIG_ENDIAN) {
723          Tcl_SetIntObj(resultPtr, ConvertDWORD(type,          Tcl_SetIntObj(resultPtr, ConvertDWORD(type,
724                  *((DWORD*) Tcl_DStringValue(&data))));                  *((DWORD*) Tcl_DStringValue(&data))));
725      } else if (type == REG_MULTI_SZ) {      } else if (type == REG_MULTI_SZ) {
726          char *p = Tcl_DStringValue(&data);          char *p = Tcl_DStringValue(&data);
727          char *end = Tcl_DStringValue(&data) + length;          char *end = Tcl_DStringValue(&data) + length;
728    
729          /*          /*
730           * Multistrings are stored as an array of null-terminated strings,           * Multistrings are stored as an array of null-terminated strings,
731           * terminated by two null characters.  Also do a bounds check in           * terminated by two null characters.  Also do a bounds check in
732           * case we get bogus data.           * case we get bogus data.
733           */           */
734    
735          while (p < end  && ((regWinProcs->useWide)          while (p < end  && ((regWinProcs->useWide)
736                  ? *((Tcl_UniChar *)p) : *p) != 0) {                  ? *((Tcl_UniChar *)p) : *p) != 0) {
737              Tcl_WinTCharToUtf((TCHAR *) p, -1, &buf);              Tcl_WinTCharToUtf((TCHAR *) p, -1, &buf);
738              Tcl_ListObjAppendElement(interp, resultPtr,              Tcl_ListObjAppendElement(interp, resultPtr,
739                      Tcl_NewStringObj(Tcl_DStringValue(&buf),                      Tcl_NewStringObj(Tcl_DStringValue(&buf),
740                              Tcl_DStringLength(&buf)));                              Tcl_DStringLength(&buf)));
741              if (regWinProcs->useWide) {              if (regWinProcs->useWide) {
742                  while (*((Tcl_UniChar *)p)++ != 0) {}                  while (*((Tcl_UniChar *)p)++ != 0) {}
743              } else {              } else {
744                  while (*p++ != '\0') {}                  while (*p++ != '\0') {}
745              }              }
746              Tcl_DStringFree(&buf);              Tcl_DStringFree(&buf);
747          }          }
748      } else if ((type == REG_SZ) || (type == REG_EXPAND_SZ)) {      } else if ((type == REG_SZ) || (type == REG_EXPAND_SZ)) {
749          Tcl_WinTCharToUtf((TCHAR *) Tcl_DStringValue(&data), -1, &buf);          Tcl_WinTCharToUtf((TCHAR *) Tcl_DStringValue(&data), -1, &buf);
750          Tcl_SetStringObj(resultPtr, Tcl_DStringValue(&buf),          Tcl_SetStringObj(resultPtr, Tcl_DStringValue(&buf),
751                  Tcl_DStringLength(&buf));                  Tcl_DStringLength(&buf));
752          Tcl_DStringFree(&buf);          Tcl_DStringFree(&buf);
753      } else {      } else {
754          /*          /*
755           * Save binary data as a byte array.           * Save binary data as a byte array.
756           */           */
757    
758          Tcl_SetByteArrayObj(resultPtr, Tcl_DStringValue(&data), length);          Tcl_SetByteArrayObj(resultPtr, Tcl_DStringValue(&data), length);
759      }      }
760      Tcl_DStringFree(&data);      Tcl_DStringFree(&data);
761      return result;      return result;
762  }  }
763    
764  /*  /*
765   *----------------------------------------------------------------------   *----------------------------------------------------------------------
766   *   *
767   * GetValueNames --   * GetValueNames --
768   *   *
769   *      This function enumerates the values of the a given key.  If   *      This function enumerates the values of the a given key.  If
770   *      the optional pattern is supplied, then only value names that   *      the optional pattern is supplied, then only value names that
771   *      match the pattern will be returned.   *      match the pattern will be returned.
772   *   *
773   * Results:   * Results:
774   *      Returns the list of value names in the result object of the   *      Returns the list of value names in the result object of the
775   *      interpreter, or an error message on failure.   *      interpreter, or an error message on failure.
776   *   *
777   * Side effects:   * Side effects:
778   *      None.   *      None.
779   *   *
780   *----------------------------------------------------------------------   *----------------------------------------------------------------------
781   */   */
782    
783  static int  static int
784  GetValueNames(  GetValueNames(
785      Tcl_Interp *interp,         /* Current interpreter. */      Tcl_Interp *interp,         /* Current interpreter. */
786      Tcl_Obj *keyNameObj,        /* Key to enumerate. */      Tcl_Obj *keyNameObj,        /* Key to enumerate. */
787      Tcl_Obj *patternObj)        /* Optional match pattern. */      Tcl_Obj *patternObj)        /* Optional match pattern. */
788  {  {
789      HKEY key;      HKEY key;
790      Tcl_Obj *resultPtr;      Tcl_Obj *resultPtr;
791      DWORD index, size, maxSize, result;      DWORD index, size, maxSize, result;
792      Tcl_DString buffer, ds;      Tcl_DString buffer, ds;
793      char *pattern, *name;      char *pattern, *name;
794    
795      /*      /*
796       * Attempt to open the key for enumeration.       * Attempt to open the key for enumeration.
797       */       */
798    
799      if (OpenKey(interp, keyNameObj, KEY_QUERY_VALUE, 0, &key)      if (OpenKey(interp, keyNameObj, KEY_QUERY_VALUE, 0, &key)
800              != TCL_OK) {              != TCL_OK) {
801          return TCL_ERROR;          return TCL_ERROR;
802      }      }
803    
804      resultPtr = Tcl_GetObjResult(interp);      resultPtr = Tcl_GetObjResult(interp);
805    
806      /*      /*
807       * Query the key to determine the appropriate buffer size to hold the       * Query the key to determine the appropriate buffer size to hold the
808       * largest value name plus the terminating null.       * largest value name plus the terminating null.
809       */       */
810    
811      result = (*regWinProcs->regQueryInfoKeyProc)(key, NULL, NULL, NULL, NULL,      result = (*regWinProcs->regQueryInfoKeyProc)(key, NULL, NULL, NULL, NULL,
812              NULL, NULL, &index, &maxSize, NULL, NULL, NULL);              NULL, NULL, &index, &maxSize, NULL, NULL, NULL);
813      if (result != ERROR_SUCCESS) {      if (result != ERROR_SUCCESS) {
814          Tcl_AppendStringsToObj(resultPtr, "unable to query key \"",          Tcl_AppendStringsToObj(resultPtr, "unable to query key \"",
815                  Tcl_GetString(keyNameObj), "\": ", NULL);                  Tcl_GetString(keyNameObj), "\": ", NULL);
816          AppendSystemError(interp, result);          AppendSystemError(interp, result);
817          RegCloseKey(key);          RegCloseKey(key);
818          result = TCL_ERROR;          result = TCL_ERROR;
819          goto done;          goto done;
820      }      }
821      maxSize++;      maxSize++;
822    
823    
824      Tcl_DStringInit(&buffer);      Tcl_DStringInit(&buffer);
825      Tcl_DStringSetLength(&buffer,      Tcl_DStringSetLength(&buffer,
826              (regWinProcs->useWide) ? maxSize*2 : maxSize);              (regWinProcs->useWide) ? maxSize*2 : maxSize);
827      index = 0;      index = 0;
828      result = TCL_OK;      result = TCL_OK;
829    
830      if (patternObj) {      if (patternObj) {
831          pattern = Tcl_GetString(patternObj);          pattern = Tcl_GetString(patternObj);
832      } else {      } else {
833          pattern = NULL;          pattern = NULL;
834      }      }
835    
836      /*      /*
837       * Enumerate the values under the given subkey until we get an error,       * Enumerate the values under the given subkey until we get an error,
838       * indicating the end of the list.  Note that we need to reset size       * indicating the end of the list.  Note that we need to reset size
839       * after each iteration because RegEnumValue smashes the old value.       * after each iteration because RegEnumValue smashes the old value.
840       */       */
841    
842      size = maxSize;      size = maxSize;
843      while ((*regWinProcs->regEnumValueProc)(key, index,      while ((*regWinProcs->regEnumValueProc)(key, index,
844              Tcl_DStringValue(&buffer), &size, NULL, NULL, NULL, NULL)              Tcl_DStringValue(&buffer), &size, NULL, NULL, NULL, NULL)
845              == ERROR_SUCCESS) {              == ERROR_SUCCESS) {
846    
847          if (regWinProcs->useWide) {          if (regWinProcs->useWide) {
848              size *= 2;              size *= 2;
849          }          }
850    
851          Tcl_WinTCharToUtf((TCHAR *) Tcl_DStringValue(&buffer), size, &ds);          Tcl_WinTCharToUtf((TCHAR *) Tcl_DStringValue(&buffer), size, &ds);
852          name = Tcl_DStringValue(&ds);          name = Tcl_DStringValue(&ds);
853          if (!pattern || Tcl_StringMatch(name, pattern)) {          if (!pattern || Tcl_StringMatch(name, pattern)) {
854              result = Tcl_ListObjAppendElement(interp, resultPtr,              result = Tcl_ListObjAppendElement(interp, resultPtr,
855                      Tcl_NewStringObj(name, Tcl_DStringLength(&ds)));                      Tcl_NewStringObj(name, Tcl_DStringLength(&ds)));
856              if (result != TCL_OK) {              if (result != TCL_OK) {
857                  Tcl_DStringFree(&ds);                  Tcl_DStringFree(&ds);
858                  break;                  break;
859              }              }
860          }          }
861          Tcl_DStringFree(&ds);          Tcl_DStringFree(&ds);
862    
863          index++;          index++;
864          size = maxSize;          size = maxSize;
865      }      }
866      Tcl_DStringFree(&buffer);      Tcl_DStringFree(&buffer);
867    
868      done:      done:
869      RegCloseKey(key);      RegCloseKey(key);
870      return result;      return result;
871  }  }
872    
873  /*  /*
874   *----------------------------------------------------------------------   *----------------------------------------------------------------------
875   *   *
876   * OpenKey --   * OpenKey --
877   *   *
878   *      This function opens the specified key.  This function is a   *      This function opens the specified key.  This function is a
879   *      simple wrapper around ParseKeyName and OpenSubKey.   *      simple wrapper around ParseKeyName and OpenSubKey.
880   *   *
881   * Results:   * Results:
882   *      Returns the opened key in the keyPtr argument and a Tcl   *      Returns the opened key in the keyPtr argument and a Tcl
883   *      result code.   *      result code.
884   *   *
885   * Side effects:   * Side effects:
886   *      None.   *      None.
887   *   *
888   *----------------------------------------------------------------------   *----------------------------------------------------------------------
889   */   */
890    
891  static int  static int
892  OpenKey(  OpenKey(
893      Tcl_Interp *interp,         /* Current interpreter. */      Tcl_Interp *interp,         /* Current interpreter. */
894      Tcl_Obj *keyNameObj,        /* Key to open. */      Tcl_Obj *keyNameObj,        /* Key to open. */
895      REGSAM mode,                /* Access mode. */      REGSAM mode,                /* Access mode. */
896      int flags,                  /* 0 or REG_CREATE. */      int flags,                  /* 0 or REG_CREATE. */
897      HKEY *keyPtr)               /* Returned HKEY. */      HKEY *keyPtr)               /* Returned HKEY. */
898  {  {
899      char *keyName, *buffer, *hostName;      char *keyName, *buffer, *hostName;
900      int length;      int length;
901      HKEY rootKey;      HKEY rootKey;
902      DWORD result;      DWORD result;
903    
904      keyName = Tcl_GetStringFromObj(keyNameObj, &length);      keyName = Tcl_GetStringFromObj(keyNameObj, &length);
905      buffer = ckalloc(length + 1);      buffer = ckalloc(length + 1);
906      strcpy(buffer, keyName);      strcpy(buffer, keyName);
907    
908      result = ParseKeyName(interp, buffer, &hostName, &rootKey, &keyName);      result = ParseKeyName(interp, buffer, &hostName, &rootKey, &keyName);
909      if (result == TCL_OK) {      if (result == TCL_OK) {
910          result = OpenSubKey(hostName, rootKey, keyName, mode, flags, keyPtr);          result = OpenSubKey(hostName, rootKey, keyName, mode, flags, keyPtr);
911          if (result != ERROR_SUCCESS) {          if (result != ERROR_SUCCESS) {
912              Tcl_Obj *resultPtr = Tcl_GetObjResult(interp);              Tcl_Obj *resultPtr = Tcl_GetObjResult(interp);
913              Tcl_AppendToObj(resultPtr, "unable to open key: ", -1);              Tcl_AppendToObj(resultPtr, "unable to open key: ", -1);
914              AppendSystemError(interp, result);              AppendSystemError(interp, result);
915              result = TCL_ERROR;              result = TCL_ERROR;
916          } else {          } else {
917              result = TCL_OK;              result = TCL_OK;
918          }          }
919      }      }
920    
921      ckfree(buffer);      ckfree(buffer);
922      return result;      return result;
923  }  }
924    
925  /*  /*
926   *----------------------------------------------------------------------   *----------------------------------------------------------------------
927   *   *
928   * OpenSubKey --   * OpenSubKey --
929   *   *
930   *      This function opens a given subkey of a root key on the   *      This function opens a given subkey of a root key on the
931   *      specified host.   *      specified host.
932   *   *
933   * Results:   * Results:
934   *      Returns the opened key in the keyPtr and a Windows error code   *      Returns the opened key in the keyPtr and a Windows error code
935   *      as the return value.   *      as the return value.
936   *   *
937   * Side effects:   * Side effects:
938   *      None.   *      None.
939   *   *
940   *----------------------------------------------------------------------   *----------------------------------------------------------------------
941   */   */
942    
943  static DWORD  static DWORD
944  OpenSubKey(  OpenSubKey(
945      char *hostName,             /* Host to access, or NULL for local. */      char *hostName,             /* Host to access, or NULL for local. */
946      HKEY rootKey,               /* Root registry key. */      HKEY rootKey,               /* Root registry key. */
947      char *keyName,              /* Subkey name. */      char *keyName,              /* Subkey name. */
948      REGSAM mode,                /* Access mode. */      REGSAM mode,                /* Access mode. */
949      int flags,                  /* 0 or REG_CREATE. */      int flags,                  /* 0 or REG_CREATE. */
950      HKEY *keyPtr)               /* Returned HKEY. */      HKEY *keyPtr)               /* Returned HKEY. */
951  {  {
952      DWORD result;      DWORD result;
953      Tcl_DString buf;      Tcl_DString buf;
954    
955      /*      /*
956       * Attempt to open the root key on a remote host if necessary.       * Attempt to open the root key on a remote host if necessary.
957       */       */
958    
959      if (hostName) {      if (hostName) {
960          hostName = Tcl_WinUtfToTChar(hostName, -1, &buf);          hostName = Tcl_WinUtfToTChar(hostName, -1, &buf);
961          result = (*regWinProcs->regConnectRegistryProc)(hostName, rootKey,          result = (*regWinProcs->regConnectRegistryProc)(hostName, rootKey,
962                  &rootKey);                  &rootKey);
963          Tcl_DStringFree(&buf);          Tcl_DStringFree(&buf);
964          if (result != ERROR_SUCCESS) {          if (result != ERROR_SUCCESS) {
965              return result;              return result;
966          }          }
967      }      }
968    
969      /*      /*
970       * Now open the specified key with the requested permissions.  Note       * Now open the specified key with the requested permissions.  Note
971       * that this key must be closed by the caller.       * that this key must be closed by the caller.
972       */       */
973    
974      keyName = Tcl_WinUtfToTChar(keyName, -1, &buf);      keyName = Tcl_WinUtfToTChar(keyName, -1, &buf);
975      if (flags & REG_CREATE) {      if (flags & REG_CREATE) {
976          DWORD create;          DWORD create;
977          result = (*regWinProcs->regCreateKeyExProc)(rootKey, keyName, 0, "",          result = (*regWinProcs->regCreateKeyExProc)(rootKey, keyName, 0, "",
978                  REG_OPTION_NON_VOLATILE, mode, NULL, keyPtr, &create);                  REG_OPTION_NON_VOLATILE, mode, NULL, keyPtr, &create);
979      } else {      } else {
980          if (rootKey == HKEY_PERFORMANCE_DATA) {          if (rootKey == HKEY_PERFORMANCE_DATA) {
981              /*              /*
982               * Here we fudge it for this special root key.               * Here we fudge it for this special root key.
983               * See MSDN for more info on HKEY_PERFORMANCE_DATA and               * See MSDN for more info on HKEY_PERFORMANCE_DATA and
984               * the peculiarities surrounding it               * the peculiarities surrounding it
985               */               */
986              *keyPtr = HKEY_PERFORMANCE_DATA;              *keyPtr = HKEY_PERFORMANCE_DATA;
987              result = ERROR_SUCCESS;              result = ERROR_SUCCESS;
988          } else {          } else {
989              result = (*regWinProcs->regOpenKeyExProc)(rootKey, keyName, 0,              result = (*regWinProcs->regOpenKeyExProc)(rootKey, keyName, 0,
990                      mode, keyPtr);                      mode, keyPtr);
991          }          }
992      }      }
993      Tcl_DStringFree(&buf);      Tcl_DStringFree(&buf);
994    
995      /*      /*
996       * Be sure to close the root key since we are done with it now.       * Be sure to close the root key since we are done with it now.
997       */       */
998    
999      if (hostName) {      if (hostName) {
1000          RegCloseKey(rootKey);          RegCloseKey(rootKey);
1001      }      }
1002      return result;      return result;
1003  }  }
1004    
1005  /*  /*
1006   *----------------------------------------------------------------------   *----------------------------------------------------------------------
1007   *   *
1008   * ParseKeyName --   * ParseKeyName --
1009   *   *
1010   *      This function parses a key name into the host, root, and subkey   *      This function parses a key name into the host, root, and subkey
1011   *      parts.   *      parts.
1012   *   *
1013   * Results:   * Results:
1014   *      The pointers to the start of the host and subkey names are   *      The pointers to the start of the host and subkey names are
1015   *      returned in the hostNamePtr and keyNamePtr variables.  The   *      returned in the hostNamePtr and keyNamePtr variables.  The
1016   *      specified root HKEY is returned in rootKeyPtr.  Returns   *      specified root HKEY is returned in rootKeyPtr.  Returns
1017   *      a standard Tcl result.   *      a standard Tcl result.
1018   *   *
1019   *   *
1020   * Side effects:   * Side effects:
1021   *      Modifies the name string by inserting nulls.   *      Modifies the name string by inserting nulls.
1022   *   *
1023   *----------------------------------------------------------------------   *----------------------------------------------------------------------
1024   */   */
1025    
1026  static int  static int
1027  ParseKeyName(  ParseKeyName(
1028      Tcl_Interp *interp,         /* Current interpreter. */      Tcl_Interp *interp,         /* Current interpreter. */
1029      char *name,      char *name,
1030      char **hostNamePtr,      char **hostNamePtr,
1031      HKEY *rootKeyPtr,      HKEY *rootKeyPtr,
1032      char **keyNamePtr)      char **keyNamePtr)
1033  {  {
1034      char *rootName;      char *rootName;
1035      int result, index;      int result, index;
1036      Tcl_Obj *rootObj, *resultPtr = Tcl_GetObjResult(interp);      Tcl_Obj *rootObj, *resultPtr = Tcl_GetObjResult(interp);
1037    
1038      /*      /*
1039       * Split the key into host and root portions.       * Split the key into host and root portions.
1040       */       */
1041    
1042      *hostNamePtr = *keyNamePtr = rootName = NULL;      *hostNamePtr = *keyNamePtr = rootName = NULL;
1043      if (name[0] == '\\') {      if (name[0] == '\\') {
1044          if (name[1] == '\\') {          if (name[1] == '\\') {
1045              *hostNamePtr = name;              *hostNamePtr = name;
1046              for (rootName = name+2; *rootName != '\0'; rootName++) {              for (rootName = name+2; *rootName != '\0'; rootName++) {
1047                  if (*rootName == '\\') {                  if (*rootName == '\\') {
1048                      *rootName++ = '\0';                      *rootName++ = '\0';
1049                      break;                      break;
1050                  }                  }
1051              }              }
1052          }          }
1053      } else {      } else {
1054          rootName = name;          rootName = name;
1055      }      }
1056      if (!rootName) {      if (!rootName) {
1057          Tcl_AppendStringsToObj(resultPtr, "bad key \"", name,          Tcl_AppendStringsToObj(resultPtr, "bad key \"", name,
1058                  "\": must start with a valid root", NULL);                  "\": must start with a valid root", NULL);
1059          return TCL_ERROR;          return TCL_ERROR;
1060      }      }
1061    
1062      /*      /*
1063       * Split the root into root and subkey portions.       * Split the root into root and subkey portions.
1064       */       */
1065    
1066      for (*keyNamePtr = rootName; **keyNamePtr != '\0'; (*keyNamePtr)++) {      for (*keyNamePtr = rootName; **keyNamePtr != '\0'; (*keyNamePtr)++) {
1067          if (**keyNamePtr == '\\') {          if (**keyNamePtr == '\\') {
1068              **keyNamePtr = '\0';              **keyNamePtr = '\0';
1069              (*keyNamePtr)++;              (*keyNamePtr)++;
1070              break;              break;
1071          }          }
1072      }      }
1073    
1074      /*      /*
1075       * Look for a matching root name.       * Look for a matching root name.
1076       */       */
1077    
1078      rootObj = Tcl_NewStringObj(rootName, -1);      rootObj = Tcl_NewStringObj(rootName, -1);
1079      result = Tcl_GetIndexFromObj(interp, rootObj, rootKeyNames, "root name",      result = Tcl_GetIndexFromObj(interp, rootObj, rootKeyNames, "root name",
1080              TCL_EXACT, &index);              TCL_EXACT, &index);
1081      Tcl_DecrRefCount(rootObj);      Tcl_DecrRefCount(rootObj);
1082      if (result != TCL_OK) {      if (result != TCL_OK) {
1083          return TCL_ERROR;          return TCL_ERROR;
1084      }      }
1085      *rootKeyPtr = rootKeys[index];      *rootKeyPtr = rootKeys[index];
1086      return TCL_OK;      return TCL_OK;
1087  }  }
1088    
1089  /*  /*
1090   *----------------------------------------------------------------------   *----------------------------------------------------------------------
1091   *   *
1092   * RecursiveDeleteKey --   * RecursiveDeleteKey --
1093   *   *
1094   *      This function recursively deletes all the keys below a starting   *      This function recursively deletes all the keys below a starting
1095   *      key.  Although Windows 95 does this automatically, we still need   *      key.  Although Windows 95 does this automatically, we still need
1096   *      to do this for Windows NT.   *      to do this for Windows NT.
1097   *   *
1098   * Results:   * Results:
1099   *      Returns a Windows error code.   *      Returns a Windows error code.
1100   *   *
1101   * Side effects:   * Side effects:
1102   *      Deletes all of the keys and values below the given key.   *      Deletes all of the keys and values below the given key.
1103   *   *
1104   *----------------------------------------------------------------------   *----------------------------------------------------------------------
1105   */   */
1106    
1107  static DWORD  static DWORD
1108  RecursiveDeleteKey(  RecursiveDeleteKey(
1109      HKEY startKey,              /* Parent of key to be deleted. */      HKEY startKey,              /* Parent of key to be deleted. */
1110      char *keyName)              /* Name of key to be deleted in external      char *keyName)              /* Name of key to be deleted in external
1111                                   * encoding, not UTF. */                                   * encoding, not UTF. */
1112  {  {
1113      DWORD result, size, maxSize;      DWORD result, size, maxSize;
1114      Tcl_DString subkey;      Tcl_DString subkey;
1115      HKEY hKey;      HKEY hKey;
1116    
1117      /*      /*
1118       * Do not allow NULL or empty key name.       * Do not allow NULL or empty key name.
1119       */       */
1120    
1121      if (!keyName || *keyName == '\0') {      if (!keyName || *keyName == '\0') {
1122          return ERROR_BADKEY;          return ERROR_BADKEY;
1123      }      }
1124    
1125      result = (*regWinProcs->regOpenKeyExProc)(startKey, keyName, 0,      result = (*regWinProcs->regOpenKeyExProc)(startKey, keyName, 0,
1126              KEY_ENUMERATE_SUB_KEYS | DELETE | KEY_QUERY_VALUE, &hKey);              KEY_ENUMERATE_SUB_KEYS | DELETE | KEY_QUERY_VALUE, &hKey);
1127      if (result != ERROR_SUCCESS) {      if (result != ERROR_SUCCESS) {
1128          return result;          return result;
1129      }      }
1130      result = (*regWinProcs->regQueryInfoKeyProc)(hKey, NULL, NULL, NULL, NULL,      result = (*regWinProcs->regQueryInfoKeyProc)(hKey, NULL, NULL, NULL, NULL,
1131              &maxSize, NULL, NULL, NULL, NULL, NULL, NULL);              &maxSize, NULL, NULL, NULL, NULL, NULL, NULL);
1132      maxSize++;      maxSize++;
1133      if (result != ERROR_SUCCESS) {      if (result != ERROR_SUCCESS) {
1134          return result;          return result;
1135      }      }
1136    
1137      Tcl_DStringInit(&subkey);      Tcl_DStringInit(&subkey);
1138      Tcl_DStringSetLength(&subkey,      Tcl_DStringSetLength(&subkey,
1139              (regWinProcs->useWide) ? maxSize * 2 : maxSize);              (regWinProcs->useWide) ? maxSize * 2 : maxSize);
1140    
1141      while (result == ERROR_SUCCESS) {      while (result == ERROR_SUCCESS) {
1142          /*          /*
1143           * Always get index 0 because key deletion changes ordering.           * Always get index 0 because key deletion changes ordering.
1144           */           */
1145    
1146          size = maxSize;          size = maxSize;
1147          result=(*regWinProcs->regEnumKeyExProc)(hKey, 0,          result=(*regWinProcs->regEnumKeyExProc)(hKey, 0,
1148                  Tcl_DStringValue(&subkey), &size, NULL, NULL, NULL, NULL);                  Tcl_DStringValue(&subkey), &size, NULL, NULL, NULL, NULL);
1149          if (result == ERROR_NO_MORE_ITEMS) {          if (result == ERROR_NO_MORE_ITEMS) {
1150              result = (*regWinProcs->regDeleteKeyProc)(startKey, keyName);              result = (*regWinProcs->regDeleteKeyProc)(startKey, keyName);
1151              break;              break;
1152          } else if (result == ERROR_SUCCESS) {          } else if (result == ERROR_SUCCESS) {
1153              result = RecursiveDeleteKey(hKey, Tcl_DStringValue(&subkey));              result = RecursiveDeleteKey(hKey, Tcl_DStringValue(&subkey));
1154          }          }
1155      }      }
1156      Tcl_DStringFree(&subkey);      Tcl_DStringFree(&subkey);
1157      RegCloseKey(hKey);      RegCloseKey(hKey);
1158      return result;      return result;
1159  }  }
1160    
1161  /*  /*
1162   *----------------------------------------------------------------------   *----------------------------------------------------------------------
1163   *   *
1164   * SetValue --   * SetValue --
1165   *   *
1166   *      This function sets the contents of a registry value.  If   *      This function sets the contents of a registry value.  If
1167   *      the key or value does not exist, it will be created.  If it   *      the key or value does not exist, it will be created.  If it
1168   *      does exist, then the data and type will be replaced.   *      does exist, then the data and type will be replaced.
1169   *   *
1170   * Results:   * Results:
1171   *      Returns a normal Tcl result.   *      Returns a normal Tcl result.
1172   *   *
1173   * Side effects:   * Side effects:
1174   *      May create new keys or values.   *      May create new keys or values.
1175   *   *
1176   *----------------------------------------------------------------------   *----------------------------------------------------------------------
1177   */   */
1178    
1179  static int  static int
1180  SetValue(  SetValue(
1181      Tcl_Interp *interp,         /* Current interpreter. */      Tcl_Interp *interp,         /* Current interpreter. */
1182      Tcl_Obj *keyNameObj,        /* Name of key. */      Tcl_Obj *keyNameObj,        /* Name of key. */
1183      Tcl_Obj *valueNameObj,      /* Name of value to set. */      Tcl_Obj *valueNameObj,      /* Name of value to set. */
1184      Tcl_Obj *dataObj,           /* Data to be written. */      Tcl_Obj *dataObj,           /* Data to be written. */
1185      Tcl_Obj *typeObj)           /* Type of data to be written. */      Tcl_Obj *typeObj)           /* Type of data to be written. */
1186  {  {
1187      DWORD type, result;      DWORD type, result;
1188      HKEY key;      HKEY key;
1189      int length;      int length;
1190      char *valueName;      char *valueName;
1191      Tcl_Obj *resultPtr;      Tcl_Obj *resultPtr;
1192      Tcl_DString nameBuf;      Tcl_DString nameBuf;
1193    
1194      if (typeObj == NULL) {      if (typeObj == NULL) {
1195          type = REG_SZ;          type = REG_SZ;
1196      } else if (Tcl_GetIndexFromObj(interp, typeObj, typeNames, "type",      } else if (Tcl_GetIndexFromObj(interp, typeObj, typeNames, "type",
1197              0, (int *) &type) != TCL_OK) {              0, (int *) &type) != TCL_OK) {
1198          if (Tcl_GetIntFromObj(NULL, typeObj, (int*) &type) != TCL_OK) {          if (Tcl_GetIntFromObj(NULL, typeObj, (int*) &type) != TCL_OK) {
1199              return TCL_ERROR;              return TCL_ERROR;
1200          }          }
1201          Tcl_ResetResult(interp);          Tcl_ResetResult(interp);
1202      }      }
1203      if (OpenKey(interp, keyNameObj, KEY_ALL_ACCESS, 1, &key) != TCL_OK) {      if (OpenKey(interp, keyNameObj, KEY_ALL_ACCESS, 1, &key) != TCL_OK) {
1204          return TCL_ERROR;          return TCL_ERROR;
1205      }      }
1206    
1207      valueName = Tcl_GetStringFromObj(valueNameObj, &length);      valueName = Tcl_GetStringFromObj(valueNameObj, &length);
1208      valueName = Tcl_WinUtfToTChar(valueName, length, &nameBuf);      valueName = Tcl_WinUtfToTChar(valueName, length, &nameBuf);
1209      resultPtr = Tcl_GetObjResult(interp);      resultPtr = Tcl_GetObjResult(interp);
1210    
1211      if (type == REG_DWORD || type == REG_DWORD_BIG_ENDIAN) {      if (type == REG_DWORD || type == REG_DWORD_BIG_ENDIAN) {
1212          DWORD value;          DWORD value;
1213          if (Tcl_GetIntFromObj(interp, dataObj, (int*) &value) != TCL_OK) {          if (Tcl_GetIntFromObj(interp, dataObj, (int*) &value) != TCL_OK) {
1214              RegCloseKey(key);              RegCloseKey(key);
1215              Tcl_DStringFree(&nameBuf);              Tcl_DStringFree(&nameBuf);
1216              return TCL_ERROR;              return TCL_ERROR;
1217          }          }
1218    
1219          value = ConvertDWORD(type, value);          value = ConvertDWORD(type, value);
1220          result = (*regWinProcs->regSetValueExProc)(key, valueName, 0, type,          result = (*regWinProcs->regSetValueExProc)(key, valueName, 0, type,
1221                  (BYTE*) &value, sizeof(DWORD));                  (BYTE*) &value, sizeof(DWORD));
1222      } else if (type == REG_MULTI_SZ) {      } else if (type == REG_MULTI_SZ) {
1223          Tcl_DString data, buf;          Tcl_DString data, buf;
1224          int objc, i;          int objc, i;
1225          Tcl_Obj **objv;          Tcl_Obj **objv;
1226    
1227          if (Tcl_ListObjGetElements(interp, dataObj, &objc, &objv) != TCL_OK) {          if (Tcl_ListObjGetElements(interp, dataObj, &objc, &objv) != TCL_OK) {
1228              RegCloseKey(key);              RegCloseKey(key);
1229              Tcl_DStringFree(&nameBuf);              Tcl_DStringFree(&nameBuf);
1230              return TCL_ERROR;              return TCL_ERROR;
1231          }          }
1232    
1233          /*          /*
1234           * Append the elements as null terminated strings.  Note that           * Append the elements as null terminated strings.  Note that
1235           * we must not assume the length of the string in case there are           * we must not assume the length of the string in case there are
1236           * embedded nulls, which aren't allowed in REG_MULTI_SZ values.           * embedded nulls, which aren't allowed in REG_MULTI_SZ values.
1237           */           */
1238    
1239          Tcl_DStringInit(&data);          Tcl_DStringInit(&data);
1240          for (i = 0; i < objc; i++) {          for (i = 0; i < objc; i++) {
1241              Tcl_DStringAppend(&data, Tcl_GetString(objv[i]), -1);              Tcl_DStringAppend(&data, Tcl_GetString(objv[i]), -1);
1242    
1243              /*              /*
1244               * Add a null character to separate this value from the next.               * Add a null character to separate this value from the next.
1245               * We accomplish this by growing the string by one byte.  Since the               * We accomplish this by growing the string by one byte.  Since the
1246               * DString always tacks on an extra null byte, the new byte will               * DString always tacks on an extra null byte, the new byte will
1247               * already be set to null.               * already be set to null.
1248               */               */
1249    
1250              Tcl_DStringSetLength(&data, Tcl_DStringLength(&data)+1);              Tcl_DStringSetLength(&data, Tcl_DStringLength(&data)+1);
1251          }          }
1252    
1253          Tcl_WinUtfToTChar(Tcl_DStringValue(&data), Tcl_DStringLength(&data)+1,          Tcl_WinUtfToTChar(Tcl_DStringValue(&data), Tcl_DStringLength(&data)+1,
1254                  &buf);                  &buf);
1255          result = (*regWinProcs->regSetValueExProc)(key, valueName, 0, type,          result = (*regWinProcs->regSetValueExProc)(key, valueName, 0, type,
1256                  (BYTE *) Tcl_DStringValue(&buf),                  (BYTE *) Tcl_DStringValue(&buf),
1257                  (DWORD) Tcl_DStringLength(&buf));                  (DWORD) Tcl_DStringLength(&buf));
1258          Tcl_DStringFree(&data);          Tcl_DStringFree(&data);
1259          Tcl_DStringFree(&buf);          Tcl_DStringFree(&buf);
1260      } else if (type == REG_SZ || type == REG_EXPAND_SZ) {      } else if (type == REG_SZ || type == REG_EXPAND_SZ) {
1261          Tcl_DString buf;          Tcl_DString buf;
1262          char *data = Tcl_GetStringFromObj(dataObj, &length);          char *data = Tcl_GetStringFromObj(dataObj, &length);
1263    
1264          data = Tcl_WinUtfToTChar(data, length, &buf);          data = Tcl_WinUtfToTChar(data, length, &buf);
1265    
1266          /*          /*
1267           * Include the null in the length, padding if needed for Unicode.           * Include the null in the length, padding if needed for Unicode.
1268           */           */
1269    
1270          if (regWinProcs->useWide) {          if (regWinProcs->useWide) {
1271              Tcl_DStringSetLength(&buf, Tcl_DStringLength(&buf)+1);              Tcl_DStringSetLength(&buf, Tcl_DStringLength(&buf)+1);
1272          }          }
1273          length = Tcl_DStringLength(&buf) + 1;          length = Tcl_DStringLength(&buf) + 1;
1274    
1275          result = (*regWinProcs->regSetValueExProc)(key, valueName, 0, type,          result = (*regWinProcs->regSetValueExProc)(key, valueName, 0, type,
1276                  (BYTE*)data, length);                  (BYTE*)data, length);
1277          Tcl_DStringFree(&buf);          Tcl_DStringFree(&buf);
1278      } else {      } else {
1279          char *data;          char *data;
1280    
1281          /*          /*
1282           * Store binary data in the registry.           * Store binary data in the registry.
1283           */           */
1284    
1285          data = Tcl_GetByteArrayFromObj(dataObj, &length);          data = Tcl_GetByteArrayFromObj(dataObj, &length);
1286          result = (*regWinProcs->regSetValueExProc)(key, valueName, 0, type,          result = (*regWinProcs->regSetValueExProc)(key, valueName, 0, type,
1287                  (BYTE *)data, length);                  (BYTE *)data, length);
1288      }      }
1289      Tcl_DStringFree(&nameBuf);      Tcl_DStringFree(&nameBuf);
1290      RegCloseKey(key);      RegCloseKey(key);
1291      if (result != ERROR_SUCCESS) {      if (result != ERROR_SUCCESS) {
1292          Tcl_AppendToObj(resultPtr, "unable to set value: ", -1);          Tcl_AppendToObj(resultPtr, "unable to set value: ", -1);
1293          AppendSystemError(interp, result);          AppendSystemError(interp, result);
1294          return TCL_ERROR;          return TCL_ERROR;
1295      }      }
1296      return TCL_OK;      return TCL_OK;
1297  }  }
1298    
1299  /*  /*
1300   *----------------------------------------------------------------------   *----------------------------------------------------------------------
1301   *   *
1302   * AppendSystemError --   * AppendSystemError --
1303   *   *
1304   *      This routine formats a Windows system error message and places   *      This routine formats a Windows system error message and places
1305   *      it into the interpreter result.   *      it into the interpreter result.
1306   *   *
1307   * Results:   * Results:
1308   *      None.   *      None.
1309   *   *
1310   * Side effects:   * Side effects:
1311   *      None.   *      None.
1312   *   *
1313   *----------------------------------------------------------------------   *----------------------------------------------------------------------
1314   */   */
1315    
1316  static void  static void
1317  AppendSystemError(  AppendSystemError(
1318      Tcl_Interp *interp,         /* Current interpreter. */      Tcl_Interp *interp,         /* Current interpreter. */
1319      DWORD error)                /* Result code from error. */      DWORD error)                /* Result code from error. */
1320  {  {
1321      int length;      int length;
1322      WCHAR *wMsgPtr;      WCHAR *wMsgPtr;
1323      char *msg;      char *msg;
1324      char id[TCL_INTEGER_SPACE], msgBuf[24 + TCL_INTEGER_SPACE];      char id[TCL_INTEGER_SPACE], msgBuf[24 + TCL_INTEGER_SPACE];
1325      Tcl_DString ds;      Tcl_DString ds;
1326      Tcl_Obj *resultPtr = Tcl_GetObjResult(interp);      Tcl_Obj *resultPtr = Tcl_GetObjResult(interp);
1327    
1328      length = FormatMessageW(FORMAT_MESSAGE_FROM_SYSTEM      length = FormatMessageW(FORMAT_MESSAGE_FROM_SYSTEM
1329              | FORMAT_MESSAGE_ALLOCATE_BUFFER, NULL, error,              | FORMAT_MESSAGE_ALLOCATE_BUFFER, NULL, error,
1330              MAKELANGID(LANG_NEUTRAL, SUBLANG_DEFAULT), (WCHAR *) &wMsgPtr,              MAKELANGID(LANG_NEUTRAL, SUBLANG_DEFAULT), (WCHAR *) &wMsgPtr,
1331              0, NULL);              0, NULL);
1332      if (length == 0) {      if (length == 0) {
1333          char *msgPtr;          char *msgPtr;
1334    
1335          length = FormatMessageA(FORMAT_MESSAGE_FROM_SYSTEM          length = FormatMessageA(FORMAT_MESSAGE_FROM_SYSTEM
1336                  | FORMAT_MESSAGE_ALLOCATE_BUFFER, NULL, error,                  | FORMAT_MESSAGE_ALLOCATE_BUFFER, NULL, error,
1337                  MAKELANGID(LANG_NEUTRAL, SUBLANG_DEFAULT), (char *) &msgPtr,                  MAKELANGID(LANG_NEUTRAL, SUBLANG_DEFAULT), (char *) &msgPtr,
1338                  0, NULL);                  0, NULL);
1339          if (length > 0) {          if (length > 0) {
1340              wMsgPtr = (WCHAR *) LocalAlloc(LPTR, (length + 1) * sizeof(WCHAR));              wMsgPtr = (WCHAR *) LocalAlloc(LPTR, (length + 1) * sizeof(WCHAR));
1341              MultiByteToWideChar(CP_ACP, 0, msgPtr, length + 1, wMsgPtr,              MultiByteToWideChar(CP_ACP, 0, msgPtr, length + 1, wMsgPtr,
1342                      length + 1);                      length + 1);
1343              LocalFree(msgPtr);              LocalFree(msgPtr);
1344          }          }
1345      }      }
1346      if (length == 0) {      if (length == 0) {
1347          if (error == ERROR_CALL_NOT_IMPLEMENTED) {          if (error == ERROR_CALL_NOT_IMPLEMENTED) {
1348              msg = "function not supported under Win32s";              msg = "function not supported under Win32s";
1349          } else {          } else {
1350              sprintf(msgBuf, "unknown error: %d", error);              sprintf(msgBuf, "unknown error: %d", error);
1351              msg = msgBuf;              msg = msgBuf;
1352          }          }
1353      } else {      } else {
1354          Tcl_Encoding encoding;          Tcl_Encoding encoding;
1355    
1356          encoding = Tcl_GetEncoding(NULL, "unicode");          encoding = Tcl_GetEncoding(NULL, "unicode");
1357          Tcl_ExternalToUtfDString(encoding, (char *) wMsgPtr, -1, &ds);          Tcl_ExternalToUtfDString(encoding, (char *) wMsgPtr, -1, &ds);
1358          Tcl_FreeEncoding(encoding);          Tcl_FreeEncoding(encoding);
1359          LocalFree(wMsgPtr);          LocalFree(wMsgPtr);
1360    
1361          msg = Tcl_DStringValue(&ds);          msg = Tcl_DStringValue(&ds);
1362          length = Tcl_DStringLength(&ds);          length = Tcl_DStringLength(&ds);
1363    
1364          /*          /*
1365           * Trim the trailing CR/LF from the system message.           * Trim the trailing CR/LF from the system message.
1366           */           */
1367          if (msg[length-1] == '\n') {          if (msg[length-1] == '\n') {
1368              msg[--length] = 0;              msg[--length] = 0;
1369          }          }
1370          if (msg[length-1] == '\r') {          if (msg[length-1] == '\r') {
1371              msg[--length] = 0;              msg[--length] = 0;
1372          }          }
1373      }      }
1374    
1375      sprintf(id, "%d", error);      sprintf(id, "%d", error);
1376      Tcl_SetErrorCode(interp, "WINDOWS", id, msg, (char *) NULL);      Tcl_SetErrorCode(interp, "WINDOWS", id, msg, (char *) NULL);
1377      Tcl_AppendToObj(resultPtr, msg, length);      Tcl_AppendToObj(resultPtr, msg, length);
1378    
1379      if (length != 0) {      if (length != 0) {
1380          Tcl_DStringFree(&ds);          Tcl_DStringFree(&ds);
1381      }      }
1382  }  }
1383    
1384  /*  /*
1385   *----------------------------------------------------------------------   *----------------------------------------------------------------------
1386   *   *
1387   * ConvertDWORD --   * ConvertDWORD --
1388   *   *
1389   *      This function determines whether a DWORD needs to be byte   *      This function determines whether a DWORD needs to be byte
1390   *      swapped, and returns the appropriately swapped value.   *      swapped, and returns the appropriately swapped value.
1391   *   *
1392   * Results:   * Results:
1393   *      Returns a converted DWORD.   *      Returns a converted DWORD.
1394   *   *
1395   * Side effects:   * Side effects:
1396   *      None.   *      None.
1397   *   *
1398   *----------------------------------------------------------------------   *----------------------------------------------------------------------
1399   */   */
1400    
1401  static DWORD  static DWORD
1402  ConvertDWORD(  ConvertDWORD(
1403      DWORD type,                 /* Either REG_DWORD or REG_DWORD_BIG_ENDIAN */      DWORD type,                 /* Either REG_DWORD or REG_DWORD_BIG_ENDIAN */
1404      DWORD value)                /* The value to be converted. */      DWORD value)                /* The value to be converted. */
1405  {  {
1406      DWORD order = 1;      DWORD order = 1;
1407      DWORD localType;      DWORD localType;
1408    
1409      /*      /*
1410       * Check to see if the low bit is in the first byte.       * Check to see if the low bit is in the first byte.
1411       */       */
1412    
1413      localType = (*((char*)(&order)) == 1) ? REG_DWORD : REG_DWORD_BIG_ENDIAN;      localType = (*((char*)(&order)) == 1) ? REG_DWORD : REG_DWORD_BIG_ENDIAN;
1414      return (type != localType) ? SWAPLONG(value) : value;      return (type != localType) ? SWAPLONG(value) : value;
1415  }  }
1416    
1417  /* End of tclwinreg.c */  /* End of tclwinreg.c */

Legend:
Removed from v.67  
changed lines
  Added in v.71

dashley@gmail.com
ViewVC Help
Powered by ViewVC 1.1.25