Tcl Source Code

Artifact Content
Login
Bounty program for improvements to Tcl and certain Tcl packages.

Artifact e7ae6db38b926c62685cf099e58750aee24bebce:


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