From: Eli Zaretskii Date: Tue, 29 May 2018 17:52:17 +0000 (+0300) Subject: Allow access to MS-Windows Registry from Lisp programs X-Git-Tag: emacs-27.0.90~4975 X-Git-Url: http://git.eshelyaron.com/gitweb/?a=commitdiff_plain;h=5be83e343f9f0f3487793b54ff95bc89ee6b824a;p=emacs.git 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. --- 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 @@ -9268,6 +9347,215 @@ network_interface_info (Lisp_Object ifname) return network_interface_get_info (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 @@ -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 diff --git a/src/w32fns.c b/src/w32fns.c index 2b920f29c65..5d1c3c84c67 100644 --- a/src/w32fns.c +++ b/src/w32fns.c @@ -10058,6 +10058,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