stop checking the Win32 registry if *"/Software/Perl" doesn't exist

This stops each ENV var lookup (and 16 calls to get_regstr, most of which
are %ENV lookups, are done automatically each time a Win32 Perl process
starts) from querying the registry for usually failing lookups.
ActiveState is the only known major user of the Software/Perl reg key.

details:
-cache the root handles, so a typically failing env var lookup does only 1
 system call instead of 3 if the parent key exists
-if the key exists, looking it up is slightly faster since it is 4
 registry syscall instead of previously 6 (open "*\Software\Perl", 2
 RegQueryValueExAs(on "found" behavior each RegQueryValueExA does 2
 RegQueryValueExW  calls), close "*\Software\Perl")
-dont make a system call to lookup a value if the parent key doesn't exist
-change "Software\\Perl" to "SOFTWARE\\Perl" since the reg is case
 preserving but lookups are not case sensitive, this all caps casing is
 what regedit shows, and might save a couple cpu cycles in the DB lookup
 in the kernel
-use RegOpenKeyExW instead of RegOpenKeyEx (actually RegOpenKeyExA), this
 avoids ansi to utf16 conversions at runtime
-dont check HKEY handles for NULL before calling RegCloseKey.
 MS and ReactOS RegCloseKey checks for NULL (zero) handle first thing and
 returns ERROR_INVALID_HANDLE as the retval of RegCloseKey. MS App Verifier
 does not complain about NULL handles.
-Dont check the retval of RegCloseKey, there is no way to dispatch an error
 at this point in the process, there are no interps, and no perlio, and
 maybe no console if its a GUI, and the process is probably exiting anyway.
 Calling Perl_noperl_die (no perl, no perlio, print to stderr) would not
 be friendly to an embedder. A crash box with RaiseException with
 EXCEPTION_INVALID_HANDLE is a bad UI.
-Dont bother to zero the HKEY handles, after a PERL_SYS_TERM until the
 next (if any) PERL_SYS_INIT3, libperl is in an undefined state, it is the
 embedders responsibility to refcount and serialize calls to
 PERL_SYS_INIT3/PERL_SYS_TERM if necessary

See details in [perl #123658]

diff --git a/README.win32 b/README.win32
index 2a8651a..7e65653 100644 (file)
--- a/README.win32
+++ b/README.win32
@@ -485,10 +485,13 @@ You can also control the shell that perl uses to run system() and
 backtick commands via PERL5SHELL.  See L<perlrun>.
 
 Perl does not depend on the registry, but it can look up certain default
-values if you choose to put them there.  Perl attempts to read entries from
-C<HKEY_CURRENT_USER\Software\Perl> and C<HKEY_LOCAL_MACHINE\Software\Perl>.
-Entries in the former override entries in the latter.  One or more of the
-following entries (of type REG_SZ or REG_EXPAND_SZ) may be set:
+values if you choose to put them there.  On Perl process start Perl checks if
+C<HKEY_CURRENT_USER\Software\Perl> and C<HKEY_LOCAL_MACHINE\Software\Perl>
+exist.  If the keys exists, they will be checked for remainder of the Perl
+process's run life for certain entries.  Entries in
+C<HKEY_CURRENT_USER\Software\Perl> override entries in
+C<HKEY_LOCAL_MACHINE\Software\Perl>.  One or more of the following entries
+(of type REG_SZ or REG_EXPAND_SZ) may be set in the keys:
 
  lib-$]        version-specific standard library path to add to @INC
  lib           standard library path to add to @INC

diff --git a/pod/perldelta.pod b/pod/perldelta.pod
index 91fbd1b..414a099 100644 (file)
--- a/pod/perldelta.pod
+++ b/pod/perldelta.pod
@@ -319,6 +319,27 @@ L</Modules and Pragmata> section.
 
 XXX
 
+=item Win32
+
+=over
+
+=item *
+
+The behavior of Perl using C<HKEY_CURRENT_USER\Software\Perl> and
+C<HKEY_LOCAL_MACHINE\Software\Perl> to lookup certain values, including
+C<%ENV> vars starting with C<PERL> has changed.  Previously, the 2 keys were
+checked for entries at all times through Perl processes life time even if they
+did not exist.  For performance reasons, now, if the root key (i.e.
+C<HKEY_CURRENT_USER\Software\Perl> or C<HKEY_LOCAL_MACHINE\Software\Perl>) does
+not exist at process start time, it will not be checked again for C<%ENV>
+override entries for the remainder of the Perl processes life.  This more
+closely matches Unix behaviour in that the enviroment is copied or inherited on
+startup and changing the variable in the parent process or another process or
+editing <.bashrc> will not change the enviromental variable in other existing,
+running, processes.
+
+=back
+
 =back
 
 =head1 Internal Changes

diff --git a/win32/win32.c b/win32/win32.c
index 2b883a2..466922f 100644 (file)
--- a/win32/win32.c
+++ b/win32/win32.c
@@ -167,6 +167,10 @@ END_EXTERN_C
 
 static OSVERSIONINFO g_osver = {0, 0, 0, 0, 0, ""};
 
+/* initialized by Perl_win32_init/PERL_SYS_INIT */
+static HKEY HKCU_Perl_hnd;
+static HKEY HKLM_Perl_hnd;
+
 #ifdef SET_INVALID_PARAMETER_HANDLER
 static BOOL silent_invalid_parameter_handler = FALSE;
 
@@ -256,34 +260,28 @@ set_w32_module_name(void)
 
 /* *svp (if non-NULL) is expected to be POK (valid allocated SvPVX(*svp)) */
 static char*
-get_regstr_from(HKEY hkey, const char *valuename, SV **svp)
+get_regstr_from(HKEY handle, const char *valuename, SV **svp)
 {
     /* Retrieve a REG_SZ or REG_EXPAND_SZ from the registry */
-    HKEY handle;
     DWORD type;
-    const char *subkey = "Software\\Perl";
     char *str = NULL;
     long retval;
+    DWORD datalen;
 
-    retval = RegOpenKeyEx(hkey, subkey, 0, KEY_READ, &handle);
-    if (retval == ERROR_SUCCESS) {
-       DWORD datalen;
-       retval = RegQueryValueEx(handle, valuename, 0, &type, NULL, &datalen);
-       if (retval == ERROR_SUCCESS
-           && (type == REG_SZ || type == REG_EXPAND_SZ))
-       {
-           dTHX;
-           if (!*svp)
-               *svp = sv_2mortal(newSVpvs(""));
-           SvGROW(*svp, datalen);
-           retval = RegQueryValueEx(handle, valuename, 0, NULL,
-                                    (PBYTE)SvPVX(*svp), &datalen);
-           if (retval == ERROR_SUCCESS) {
-               str = SvPVX(*svp);
-               SvCUR_set(*svp,datalen-1);
-           }
+    retval = RegQueryValueEx(handle, valuename, 0, &type, NULL, &datalen);
+    if (retval == ERROR_SUCCESS
+       && (type == REG_SZ || type == REG_EXPAND_SZ))
+    {
+       dTHX;
+       if (!*svp)
+           *svp = sv_2mortal(newSVpvs(""));
+       SvGROW(*svp, datalen);
+       retval = RegQueryValueEx(handle, valuename, 0, NULL,
+                                (PBYTE)SvPVX(*svp), &datalen);
+       if (retval == ERROR_SUCCESS) {
+           str = SvPVX(*svp);
+           SvCUR_set(*svp,datalen-1);
        }
-       RegCloseKey(handle);
     }
     return str;
 }
@@ -292,9 +290,19 @@ get_regstr_from(HKEY hkey, const char *valuename, SV **svp)
 static char*
 get_regstr(const char *valuename, SV **svp)
 {
-    char *str = get_regstr_from(HKEY_CURRENT_USER, valuename, svp);
-    if (!str)
-       str = get_regstr_from(HKEY_LOCAL_MACHINE, valuename, svp);
+    char *str;
+    if (HKCU_Perl_hnd) {
+       str = get_regstr_from(HKCU_Perl_hnd, valuename, svp);
+       if (!str)
+           goto try_HKLM;
+    }
+    else {
+       try_HKLM:
+       if (HKLM_Perl_hnd)
+           str = get_regstr_from(HKLM_Perl_hnd, valuename, svp);
+       else
+           str = NULL;
+    }
     return str;
 }
 
@@ -4443,6 +4451,17 @@ Perl_win32_init(int *argcp, char ***argvp)
 #endif
 
     ansify_path();
+    {
+       LONG retval;
+       retval = RegOpenKeyExW(HKEY_CURRENT_USER, L"SOFTWARE\\Perl", 0, KEY_READ, &HKCU_Perl_hnd);
+       if (retval != ERROR_SUCCESS) {
+           HKCU_Perl_hnd = NULL;
+       }
+       retval = RegOpenKeyExW(HKEY_LOCAL_MACHINE, L"SOFTWARE\\Perl", 0, KEY_READ, &HKLM_Perl_hnd);
+       if (retval != ERROR_SUCCESS) {
+           HKLM_Perl_hnd = NULL;
+       }
+    }
 }
 
 void
@@ -4452,6 +4471,11 @@ Perl_win32_term(void)
     OP_REFCNT_TERM;
     PERLIO_TERM;
     MALLOC_TERM;
+    /* handles might be NULL, RegCloseKey then returns ERROR_INVALID_HANDLE
+       but no point of checking and we can't die() at this point */
+    RegCloseKey(HKLM_Perl_hnd);
+    RegCloseKey(HKCU_Perl_hnd);
+    /* the handles are in an undefined state until the next PERL_SYS_INIT3 */
 }
 
 void