[Emacs-diffs] master 5be83e3: Allow access to MS-Windows Registry from Lisp programs

[Eli Zaretskii]

branch: master
commit 5be83e343f9f0f3487793b54ff95bc89ee6b824a
Author: Eli Zaretskii <address@hidden>
Commit: Eli Zaretskii <address@hidden>

    Allow access to MS-Windows Registry from Lisp programs
    
    * src/w32.c (g_b_init_reg_open_key_ex_w)
    (g_b_init_reg_query_value_ex_w)
    (g_b_init_expand_environment_strings_w): New init flags.
    (globals_of_w32): Initialize them at startup.
    (RegOpenKeyExW_Proc, RegQueryValueExW_Proc)
    (ExpandEnvironmentStringsW_Proc): New function typedefs.
    (reg_open_key_ex_w, reg_query_value_ex_w)
    (expand_environment_strings_w): New wrapper function.
    (w32_read_registry): New function.
    * src/w32fns.c (Fw32_read_registry) [WINDOWSNT]: New primitive.
    (syms_of_w32fns) [WINDOWSNT]: Defsubr it.  DEFSYM "HKLM", "HKCU",
    etc. root keys.
    
    * etc/NEWS: Mention the new primitive.
---
 etc/NEWS     |   7 ++
 src/w32.c    | 291 +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
 src/w32.h    |   2 +
 src/w32fns.c |  81 +++++++++++++++++
 4 files changed, 381 insertions(+)

diff --git a/etc/NEWS b/etc/NEWS
index 5ac803e..ea4a657 100644
--- a/etc/NEWS
+++ b/etc/NEWS
@@ -682,6 +682,13 @@ to 't' would enable the macOS proxy icon has been replaced 
with a
 separate variable, 'ns-use-proxy-icon'.  'frame-title-format' will now
 work as on other platforms.
 
+---
+** New primitive 'w32-read-registry'.
+This primitive lets Lisp programs access the MS-Windows Registry by
+retrieving values stored under a given key.  It is intended to be used
+for supporting features such as XDG-like location of important files
+and directories.
+
 
 ----------------------------------------------------------------------
 This file is part of GNU Emacs.
diff --git a/src/w32.c b/src/w32.c
index 5ac6618..e93aaab 100644
--- a/src/w32.c
+++ b/src/w32.c
@@ -326,6 +326,9 @@ static BOOL g_b_init_set_file_security_a;
 static BOOL g_b_init_set_named_security_info_w;
 static BOOL g_b_init_set_named_security_info_a;
 static BOOL g_b_init_get_adapters_info;
+static BOOL g_b_init_reg_open_key_ex_w;
+static BOOL g_b_init_reg_query_value_ex_w;
+static BOOL g_b_init_expand_environment_strings_w;
 
 BOOL g_b_init_compare_string_w;
 BOOL g_b_init_debug_break_process;
@@ -504,6 +507,9 @@ typedef DWORD (WINAPI *GetAdaptersInfo_Proc) (
 int (WINAPI *pMultiByteToWideChar)(UINT,DWORD,LPCSTR,int,LPWSTR,int);
 int (WINAPI 
*pWideCharToMultiByte)(UINT,DWORD,LPCWSTR,int,LPSTR,int,LPCSTR,LPBOOL);
 DWORD multiByteToWideCharFlags;
+typedef LONG (WINAPI *RegOpenKeyExW_Proc) (HKEY,LPCWSTR,DWORD,REGSAM,PHKEY);
+typedef LONG (WINAPI *RegQueryValueExW_Proc) 
(HKEY,LPCWSTR,LPDWORD,LPDWORD,LPBYTE,LPDWORD);
+typedef DWORD (WINAPI *ExpandEnvironmentStringsW_Proc) (LPCWSTR,LPWSTR,DWORD);
 
   /* ** A utility function ** */
 static BOOL
@@ -1376,6 +1382,79 @@ get_adapters_info (PIP_ADAPTER_INFO pAdapterInfo, PULONG 
pOutBufLen)
   return s_pfn_Get_Adapters_Info (pAdapterInfo, pOutBufLen);
 }
 
+static LONG WINAPI
+reg_open_key_ex_w (HKEY hkey, LPCWSTR lpSubKey, DWORD ulOptions,
+                  REGSAM samDesired, PHKEY phkResult)
+{
+  static RegOpenKeyExW_Proc s_pfn_Reg_Open_Key_Ex_w = NULL;
+  HMODULE hm_advapi32 = NULL;
+
+  if (is_windows_9x () == TRUE)
+    return ERROR_NOT_SUPPORTED;
+
+  if (g_b_init_reg_open_key_ex_w == 0)
+    {
+      g_b_init_reg_open_key_ex_w = 1;
+      hm_advapi32 = LoadLibrary ("Advapi32.dll");
+      if (hm_advapi32)
+       s_pfn_Reg_Open_Key_Ex_w = (RegOpenKeyExW_Proc)
+         GetProcAddress (hm_advapi32, "RegOpenKeyExW");
+    }
+  if (s_pfn_Reg_Open_Key_Ex_w == NULL)
+    return ERROR_NOT_SUPPORTED;
+  return s_pfn_Reg_Open_Key_Ex_w (hkey, lpSubKey, ulOptions,
+                                 samDesired, phkResult);
+}
+
+static LONG WINAPI
+reg_query_value_ex_w (HKEY hkey, LPCWSTR lpValueName, LPDWORD lpReserved,
+                     LPDWORD lpType, LPBYTE lpData, LPDWORD lpcbData)
+{
+  static RegQueryValueExW_Proc s_pfn_Reg_Query_Value_Ex_w = NULL;
+  HMODULE hm_advapi32 = NULL;
+
+  if (is_windows_9x () == TRUE)
+    return ERROR_NOT_SUPPORTED;
+
+  if (g_b_init_reg_query_value_ex_w == 0)
+    {
+      g_b_init_reg_query_value_ex_w = 1;
+      hm_advapi32 = LoadLibrary ("Advapi32.dll");
+      if (hm_advapi32)
+       s_pfn_Reg_Query_Value_Ex_w = (RegQueryValueExW_Proc)
+         GetProcAddress (hm_advapi32, "RegQueryValueExW");
+    }
+  if (s_pfn_Reg_Query_Value_Ex_w == NULL)
+    return ERROR_NOT_SUPPORTED;
+  return s_pfn_Reg_Query_Value_Ex_w (hkey, lpValueName, lpReserved,
+                                    lpType, lpData, lpcbData);
+}
+
+static DWORD WINAPI
+expand_environment_strings_w (LPCWSTR lpSrc, LPWSTR lpDst, DWORD nSize)
+{
+  static ExpandEnvironmentStringsW_Proc s_pfn_Expand_Environment_Strings_w = 
NULL;
+  HMODULE hm_kernel32 = NULL;
+
+  if (is_windows_9x () == TRUE)
+    return ERROR_NOT_SUPPORTED;
+
+  if (g_b_init_expand_environment_strings_w == 0)
+    {
+      g_b_init_expand_environment_strings_w = 1;
+      hm_kernel32 = LoadLibrary ("Kernel32.dll");
+      if (hm_kernel32)
+       s_pfn_Expand_Environment_Strings_w = (ExpandEnvironmentStringsW_Proc)
+         GetProcAddress (hm_kernel32, "ExpandEnvironmentStringsW");
+    }
+  if (s_pfn_Expand_Environment_Strings_w == NULL)
+    {
+      errno = ENOSYS;
+      return FALSE;
+    }
+  return s_pfn_Expand_Environment_Strings_w (lpSrc, lpDst, nSize);
+}
+
 
 
 /* Return 1 if P is a valid pointer to an object of size SIZE.  Return
@@ -9269,6 +9348,215 @@ network_interface_info (Lisp_Object ifname)
 }
 
 
+/* Workhorse for w32-read-registry, which see.  */
+Lisp_Object
+w32_read_registry (HKEY rootkey, Lisp_Object lkey, Lisp_Object lname)
+{
+  HKEY hkey = NULL;
+  LONG status;
+  DWORD vsize, vtype;
+  LPBYTE pvalue;
+  Lisp_Object val, retval;
+  const char *key, *value_name;
+  /* The following sizes are according to size limitations
+     documented in MSDN.  */
+  wchar_t key_w[255+1];
+  wchar_t value_w[16*1024+1];
+  bool use_unicode = is_windows_9x () == 0;
+
+  if (use_unicode)
+    {
+      Lisp_Object encoded_key, encoded_vname;
+
+      /* Convert input strings to UTF-16.  */
+      encoded_key = code_convert_string_norecord (lkey, Qutf_16le, 1);
+      memcpy (key_w, SSDATA (encoded_key), SBYTES (encoded_key));
+      /* wchar_t strings need to be terminated by 2 null bytes.  */
+      key_w [SBYTES (encoded_key)/2] = L'\0';
+      encoded_vname = code_convert_string_norecord (lname, Qutf_16le, 1);
+      memcpy (value_w, SSDATA (encoded_vname), SBYTES (encoded_vname));
+      value_w[SBYTES (encoded_vname)/2] = L'\0';
+
+      /* Mirror the slashes, if required.  */
+      for (int i = 0; i < SBYTES (encoded_key)/2; i++)
+       {
+         if (key_w[i] == L'/')
+           key_w[i] = L'\\';
+       }
+      if ((status = reg_open_key_ex_w (rootkey, key_w, 0,
+                                      KEY_READ, &hkey)) == ERROR_NOT_SUPPORTED
+         || (status = reg_query_value_ex_w (hkey, value_w, NULL, NULL, NULL,
+                                            &vsize)) == ERROR_NOT_SUPPORTED
+         || status != ERROR_SUCCESS)
+       {
+         if (hkey)
+           RegCloseKey (hkey);
+         if (status != ERROR_NOT_SUPPORTED)
+           return Qnil;
+         use_unicode = 0;      /* fall back to non-Unicode calls */
+       }
+    }
+  if (!use_unicode)
+    {
+      /* Need to copy LKEY because we are going to modify it.  */
+      Lisp_Object local_lkey = Fcopy_sequence (lkey);
+
+      /* Mirror the slashes.  Note: this has to be done before
+        encoding, because after encoding we cannot guarantee that a
+        slash '/' always stands for itself, it could be part of some
+        multibyte sequence.  */
+      for (int i = 0; i < SBYTES (local_lkey); i++)
+       {
+         if (SSDATA (local_lkey)[i] == '/')
+           SSDATA (local_lkey)[i] = '\\';
+       }
+
+      key = SSDATA (ENCODE_SYSTEM (local_lkey));
+      value_name = SSDATA (ENCODE_SYSTEM (lname));
+
+      if ((status = RegOpenKeyEx (rootkey, key, 0,
+                                 KEY_READ, &hkey)) != ERROR_SUCCESS
+         || (status = RegQueryValueEx (hkey, value_name, NULL,
+                                       NULL, NULL, &vsize)) != ERROR_SUCCESS)
+       {
+         if (hkey)
+           RegCloseKey (hkey);
+         return Qnil;
+       }
+    }
+
+  pvalue = xzalloc (vsize);
+  if (use_unicode)
+    status = reg_query_value_ex_w (hkey, value_w, NULL, &vtype, pvalue, 
&vsize);
+  else
+    status = RegQueryValueEx (hkey, value_name, NULL, &vtype, pvalue, &vsize);
+  if (status != ERROR_SUCCESS)
+    {
+      xfree (pvalue);
+      RegCloseKey (hkey);
+      return Qnil;
+    }
+
+  switch (vtype)
+    {
+      case REG_NONE:
+       retval = Qt;
+       break;
+      case REG_DWORD:
+       retval = INTEGER_TO_CONS (*((DWORD *)pvalue));
+       break;
+      case REG_QWORD:
+       retval = INTEGER_TO_CONS (*((long long *)pvalue));
+       break;
+      case REG_BINARY:
+       {
+         int i;
+         unsigned char *dbuf = (unsigned char *)pvalue;
+
+         val = make_uninit_vector (vsize);
+         for (i = 0; i < vsize; i++)
+           ASET (val, i, make_number (dbuf[i]));
+
+         retval = val;
+         break;
+       }
+      case REG_SZ:
+       if (use_unicode)
+         {
+           /* pvalue ends with 2 null bytes, but we need only one,
+              and AUTO_STRING_WITH_LEN will add it.  */
+           if (pvalue[vsize - 1] == '\0')
+             vsize -= 2;
+           AUTO_STRING_WITH_LEN (sval, (char *)pvalue, vsize);
+           retval = from_unicode (sval);
+         }
+       else
+         {
+           /* Don't waste a byte on the terminating null character,
+              since make_unibyte_string will add one anyway.  */
+           if (pvalue[vsize - 1] == '\0')
+             vsize--;
+           retval = DECODE_SYSTEM (make_unibyte_string (pvalue, vsize));
+         }
+       break;
+      case REG_EXPAND_SZ:
+       if (use_unicode)
+         {
+           wchar_t expanded_w[32*1024];
+           DWORD dsize = sizeof (expanded_w) / 2;
+           DWORD produced = expand_environment_strings_w ((wchar_t *)pvalue,
+                                                          expanded_w,
+                                                          dsize);
+           if (produced > 0 && produced < dsize)
+             {
+               AUTO_STRING_WITH_LEN (sval, (char *)expanded_w,
+                                     produced * 2 - 2);
+               retval = from_unicode (sval);
+             }
+           else
+             {
+               if (pvalue[vsize - 1] == '\0')
+                 vsize -= 2;
+               AUTO_STRING_WITH_LEN (sval, (char *)pvalue, vsize);
+               retval = from_unicode (sval);
+             }
+         }
+       else
+         {
+           char expanded[32*1024]; /* size limitation according to MSDN */
+           DWORD produced = ExpandEnvironmentStrings ((char *)pvalue,
+                                                      expanded,
+                                                      sizeof (expanded));
+           if (produced > 0 && produced < sizeof (expanded))
+             retval = make_unibyte_string (expanded, produced - 1);
+           else
+             {
+               if (pvalue[vsize - 1] == '\0')
+                 vsize--;
+               retval = make_unibyte_string (pvalue, vsize);
+             }
+
+           retval = DECODE_SYSTEM (retval);
+         }
+       break;
+      case REG_MULTI_SZ:
+       if (use_unicode)
+         {
+           wchar_t *wp = (wchar_t *)pvalue;
+
+           val = Qnil;
+           do {
+             size_t wslen = wcslen (wp);
+             AUTO_STRING_WITH_LEN (sval, (char *)wp, wslen * 2);
+             val = Fcons (from_unicode (sval), val);
+             wp += wslen + 1;
+           } while (*wp);
+         }
+       else
+         {
+           char *p = (char *)pvalue;
+
+           val = Qnil;
+           do {
+             size_t slen = strlen (p);
+
+             val = Fcons (DECODE_SYSTEM (make_unibyte_string (p, slen)), val);
+             p += slen + 1;
+           } while (*p);
+         }
+
+       retval = Fnreverse (val);
+       break;
+      default:
+       error ("unsupported registry data type: %d", (int)vtype);
+    }
+
+  xfree (pvalue);
+  RegCloseKey (hkey);
+  return retval;
+}
+
+
 /* The Windows CRT functions are "optimized for speed", so they don't
    check for timezone and DST changes if they were last called less
    than 1 minute ago (see http://support.microsoft.com/kb/821231).  So
@@ -9699,6 +9987,9 @@ globals_of_w32 (void)
   g_b_init_set_named_security_info_w = 0;
   g_b_init_set_named_security_info_a = 0;
   g_b_init_get_adapters_info = 0;
+  g_b_init_reg_open_key_ex_w = 0;
+  g_b_init_reg_query_value_ex_w = 0;
+  g_b_init_expand_environment_strings_w = 0;
   g_b_init_compare_string_w = 0;
   g_b_init_debug_break_process = 0;
   num_of_processors = 0;
diff --git a/src/w32.h b/src/w32.h
index 1e416ce..fe8689a 100644
--- a/src/w32.h
+++ b/src/w32.h
@@ -227,6 +227,8 @@ extern int w32_compare_strings (const char *, const char *, 
char *, int);
 /* Return a cryptographically secure seed for PRNG.  */
 extern int w32_init_random (void *, ptrdiff_t);
 
+extern Lisp_Object w32_read_registry (HKEY, Lisp_Object, Lisp_Object);
+
 #ifdef HAVE_GNUTLS
 #include <gnutls/gnutls.h>
 
diff --git a/src/w32fns.c b/src/w32fns.c
index 2b920f2..5d1c3c8 100644
--- a/src/w32fns.c
+++ b/src/w32fns.c
@@ -10059,6 +10059,78 @@ DEFUN ("w32-notification-close",
 #endif /* WINDOWSNT && !HAVE_DBUS */
 
 
+#ifdef WINDOWSNT
+/***********************************************************************
+                         Reading Registry
+ ***********************************************************************/
+DEFUN ("w32-read-registry",
+       Fw32_read_registry, Sw32_read_registry,
+       3, 3, 0,
+       doc: /* Return the value stored in MS-Windows Registry under 
ROOT/KEY/NAME.
+
+ROOT is a symbol, one of `HKCR', `HKCU', `HKLM', `HKU', or `HKCC'.
+It can also be nil, which means try `HKCU', and if that fails, try `HKLM'.
+
+KEY and NAME must be strings, and NAME must not include slashes.
+KEY can use either forward- or back-slashes.
+
+If the the named KEY or its subkey called NAME don't exist, or cannot
+be accessed by the current user, the function returns nil.  Otherwise,
+the return value depends on the type of the data stored in Registry:
+
+  If the data type is REG_NONE, the function returns t.
+  If the data type is REG_DWORD or REG_QWORD, the function returns
+    its integer value.  If the value is too large for a Lisp integer,
+    the function returns a cons (HIGH . LOW) of 2 integers, with LOW
+    the low 16 bits and HIGH the high bits.  If HIGH is too large for
+    a Lisp integer, the function returns (HIGH MIDDLE . LOW), first
+    the high bits, then the middle 24 bits, and finally the low 16 bits.
+  If the data type is REG_BINARY, the function returns a vector whose
+    elements are individual bytes of the value.
+  If the data type is REG_SZ, the function returns a string.
+  If the data type REG_EXPAND_SZ, the function returns a string with
+    all the %..% references to environment variables replaced by the
+    values of those variables.  If the expansion fails, or some
+    variables are not defined in the environment, some or all of
+    the environment variables will remain unexpanded.
+  If the data type is REG_MULTI_SZ, the function returns a list whose
+    elements are the individual strings.
+
+Note that this function doesn't know whether a string value is a file
+name, so file names will be returned with backslashes, which may need
+to be converted to forward slashes by the caller.  */)
+  (Lisp_Object root, Lisp_Object key, Lisp_Object name)
+{
+  CHECK_SYMBOL (root);
+  CHECK_STRING (key);
+  CHECK_STRING (name);
+
+  HKEY rootkey;
+  if (EQ (root, QHKCR))
+    rootkey = HKEY_CLASSES_ROOT;
+  else if (EQ (root, QHKCU))
+    rootkey = HKEY_CURRENT_USER;
+  else if (EQ (root, QHKLM))
+    rootkey = HKEY_LOCAL_MACHINE;
+  else if (EQ (root, QHKU))
+    rootkey = HKEY_USERS;
+  else if (EQ (root, QHKCC))
+    rootkey = HKEY_CURRENT_CONFIG;
+  else if (!NILP (root))
+    error ("unknown root key: %s", SDATA (SYMBOL_NAME (root)));
+
+  Lisp_Object val = w32_read_registry (NILP (root)
+                                      ? HKEY_CURRENT_USER
+                                      : rootkey,
+                                      key, name);
+  if (NILP (val) && NILP (root))
+    val = w32_read_registry (HKEY_LOCAL_MACHINE, key, name);
+
+  return val;
+}
+
+#endif /* WINDOWSNT */
+
 /***********************************************************************
                            Initialization
  ***********************************************************************/
@@ -10151,6 +10223,14 @@ syms_of_w32fns (void)
   DEFSYM (QCbody, ":body");
 #endif
 
+#ifdef WINDOWSNT
+  DEFSYM (QHKCR, "HKCR");
+  DEFSYM (QHKCU, "HKCU");
+  DEFSYM (QHKLM, "HKLM");
+  DEFSYM (QHKU,  "HKU");
+  DEFSYM (QHKCC, "HKCC");
+#endif
+
   /* Symbols used elsewhere, but only in MS-Windows-specific code.  */
   DEFSYM (Qgnutls, "gnutls");
   DEFSYM (Qlibxml2, "libxml2");
@@ -10508,6 +10588,7 @@ tip frame.  */);
 #endif
 
 #ifdef WINDOWSNT
+  defsubr (&Sw32_read_registry);
   defsubr (&Sfile_system_info);
   defsubr (&Sdefault_printer_name);
 #endif