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