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

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

Parent Directory Parent Directory | Revision Log Revision Log


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

dashley@gmail.com
ViewVC Help
Powered by ViewVC 1.1.25