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

Annotation of /projs/trunk/shared_source/c_tcl_base_7_5_w_mods/tclwinreg.c

Parent Directory Parent Directory | Revision Log Revision Log


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

Properties

Name Value
svn:keywords Header

dashley@gmail.com
ViewVC Help
Powered by ViewVC 1.1.25