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.

4 files changed, 381 insertions, 0 deletions

diff --git a/etc/NEWS b/etc/NEWS
index 5ac803eec4b..ea4a657cba9 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 5ac66181403..e93aaab9ca1 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 1e416ceead7..fe8689a07b4 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 2b920f29c65..5d1c3c84c67 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