diff --git a/dist/PathTools/Cwd.pm b/dist/PathTools/Cwd.pm index 7876f301bf038..a89e1f9d29481 100644 --- a/dist/PathTools/Cwd.pm +++ b/dist/PathTools/Cwd.pm @@ -3,7 +3,7 @@ use strict; use Exporter; -our $VERSION = '3.92'; +our $VERSION = '3.93'; my $xs_version = $VERSION; $VERSION =~ tr/_//d; diff --git a/dist/PathTools/Cwd.xs b/dist/PathTools/Cwd.xs index bca575c9b768c..06c02b134d69a 100644 --- a/dist/PathTools/Cwd.xs +++ b/dist/PathTools/Cwd.xs @@ -302,6 +302,7 @@ int Perl_getcwd_sv(pTHX_ SV *sv) /* Some getcwd()s automatically allocate a buffer of the given * size from the heap if they are given a NULL buffer pointer. * The problem is that this behaviour is not portable. */ + /* XXX bug use PerlEnv_get_childdir/PerlEnv_free_childenv all OSes? */ if (getcwd(buf, sizeof(buf) - 1)) { STRLEN len = strlen(buf); sv_setpvn(sv, buf, len); diff --git a/lib/Internals.pod b/lib/Internals.pod index be679cec873ac..af59ed7b07c39 100644 --- a/lib/Internals.pod +++ b/lib/Internals.pod @@ -57,6 +57,22 @@ to implement higher-level behavior which should be used instead. See the core implementation for the exact meaning of the readonly flag for each internal variable type. +=item Internals::getcwd() + +Internally core maintained version of L or +L. Only for use if loading L or +calling C and its C to L will +somehow break a TAP test in a C<.t>. + +Not defined on all platforms and all perl build flag configs. May not set +C env var. May disappear at any time. Probe for the sub's existance +before calling it and write C/C if C is +unavailable. Although this would be a bug, there is no guarentee it will +return the same identical string as L or +L. The public implementations can get patched +in the future for some future discovered bug while this sub keeps the buggy +return value. + =item hv_clear_placeholders(%hash) Clear any placeholders from a locked hash. Should not be used directly. diff --git a/lib/blib.pm b/lib/blib.pm index f8fd500d5e6d3..48c1fb00ab072 100644 --- a/lib/blib.pm +++ b/lib/blib.pm @@ -39,7 +39,7 @@ Nick Ing-Simmons nik@tiuk.ti.com use Cwd; use File::Spec; -our $VERSION = '1.07'; +our $VERSION = '1.08'; our $Verbose = 0; sub import @@ -52,7 +52,11 @@ sub import # That means that it would not be possible to run `make test` # for the Win32 module because blib.pm would always load the # installed version before @INC gets updated with the blib path. - chomp($dir = `cd`); + if(defined &Internals::getcwd) { + $dir = Internals::getcwd(); + } else { + chomp($dir = `cd`); + } } else { $dir = getcwd; diff --git a/pod/perldelta.pod b/pod/perldelta.pod index baa03b9396ea0..7d1d929a700cc 100644 --- a/pod/perldelta.pod +++ b/pod/perldelta.pod @@ -123,11 +123,13 @@ XXX Remove this section if F did not add any cont =over 4 -=item * - -L has been upgraded from version A.xx to B.yy. +=item blib.pm -XXX If there was something important to note about this change, include that here. +C was updated from 1.07 to 1.08. Previously when L, +and only that module, the C was obtained through inefficiently +shelling out to a new C, this was fixed and the C when using +C and L is obtained with a fast same-process API +function call the way C and C do it. =back @@ -346,9 +348,12 @@ well. =over 4 -=item * +=item Internals::getcwd() is documented as very limited platform availability -XXX +C is documented as experimental, unsupported, not-bug-free +and removeable in the future, and very limited availability on random +platforms and perl core build flags. Basically C only, and only for +esoteric C<.t> TAP situations and esoteric internal core reasons. =back diff --git a/universal.c b/universal.c index 5a41eced41094..2f0374617d1ce 100644 --- a/universal.c +++ b/universal.c @@ -1136,16 +1136,17 @@ XS(XS_re_regexp_pattern) XS(XS_Internals_getcwd) { dXSARGS; - SV *sv = sv_newmortal(); - if (items != 0) croak_xs_usage(cv, ""); + EXTEND(SP,1); + dXSTARG; + PUSHs(TARG); + PUTBACK; - (void)getcwd_sv(sv); + (void)getcwd_sv(TARG); - SvTAINTED_on(sv); - PUSHs(sv); - XSRETURN(1); + SvTAINTED_on(TARG); + SvSETMAGIC(TARG); } #endif @@ -1314,6 +1315,10 @@ struct xsub_details { int ix; }; +#ifdef WIN32 + XS_EXTERNAL(w32_GetCwd); +#endif + static const struct xsub_details these_details[] = { {"UNIVERSAL::isa", XS_UNIVERSAL_isa, NULL, 0 }, {"UNIVERSAL::can", XS_UNIVERSAL_can, NULL, 0 }, @@ -1344,6 +1349,11 @@ static const struct xsub_details these_details[] = { {"re::regexp_pattern", XS_re_regexp_pattern, "$", 0 }, #if defined(HAS_GETCWD) && defined(PERL_IS_MINIPERL) {"Internals::getcwd", XS_Internals_getcwd, "", 0 }, +#elif defined(WIN32) + /* Always offer backup, Win32CORE.c vs AUTOLOAD vs Win32.pm + vs Win32.dll vs loading a .pm or .dll at all, has rare dep/recursion + problems in certain modules or .t files. See w32_GetCwd() . */ + {"Internals::getcwd", w32_GetCwd, "", 0 }, #endif {"Tie::Hash::NamedCapture::_tie_it", XS_NamedCapture_tie_it, NULL, 0 }, {"Tie::Hash::NamedCapture::TIEHASH", XS_NamedCapture_TIEHASH, NULL, 0 }, diff --git a/util.c b/util.c index fa946b4153c2d..8c3e8e46f1175 100644 --- a/util.c +++ b/util.c @@ -4124,6 +4124,7 @@ Perl_getcwd_sv(pTHX_ SV *sv) /* Some getcwd()s automatically allocate a buffer of the given * size from the heap if they are given a NULL buffer pointer. * The problem is that this behaviour is not portable. */ + /* XXX bug use PerlEnv_get_childdir/PerlEnv_free_childenv all OSes? */ if (getcwd(buf, sizeof(buf) - 1)) { sv_setpv(sv, buf); return TRUE; diff --git a/win32/win32.c b/win32/win32.c index 0f54fc61344fb..08528b5533be1 100644 --- a/win32/win32.c +++ b/win32/win32.c @@ -5016,12 +5016,17 @@ XS(w32_SetChildShowWindow) } -#ifdef PERL_IS_MINIPERL -/* shelling out is much slower, full perl uses Win32.pm */ -XS(w32_GetCwd) + +/* Shelling out is much slower, full perl uses Win32.pm. + So for miniperl install "Win32::GetCwd", and for mini and full perl + install this as "Internals::getcwd". On Win32 platform, because of + Win32CORE.c AUTOLOAD vs DynaLoader.pm vs Win32.pm, race and recursion + and dependency problems can happen in rare cases. For example, see blib.pm + Offer Internals::getcwd as a backup at all times. */ +XS_EXTERNAL(w32_GetCwd) { - dXSARGS; - PERL_UNUSED_VAR(items); + + SV *sv; /* Make the host for current directory */ char* ptr = PerlEnv_get_childdir(); /* @@ -5030,20 +5035,28 @@ XS(w32_GetCwd) * else return 'undef' */ if (ptr) { - SV *sv = sv_newmortal(); + dXSTARG; + sv = TARG; sv_setpv(sv, ptr); PerlEnv_free_childdir(ptr); #ifndef INCOMPLETE_TAINTS SvTAINTED_on(sv); #endif - - ST(0) = sv; - XSRETURN(1); + SvSETMAGIC(sv); } - XSRETURN_UNDEF; + else { + sv = &PL_sv_undef; + } + { + dXSARGS; + PERL_UNUSED_VAR(items); + XSprePUSH; + XPUSHs(sv); + PUTBACK; + } + return; } -#endif void Perl_init_os_extras(void)