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