Skip to content

Commit

Permalink
blib.pm dont shell out to "cmd.exe" on Win32+Win32.pm
Browse files Browse the repository at this point in the history
-document Internals::getcwd() enough, with scary warnings, for future
 core devs, or CPAN devs.  A permanent reason for Internals::getcwd() to
 exist on Win32 full perl was found. See code comments.
-optimize a bit the built-in perl core cwd() XSUBs, use TARG, and group
 stack manipulation together for C compiler variable liveness reasons aka
 less variables to save in non-vol regs or on C stack around function
 calls.
  • Loading branch information
bulk88 committed Oct 20, 2024
1 parent 82c4939 commit 18599f6
Show file tree
Hide file tree
Showing 8 changed files with 76 additions and 26 deletions.
2 changes: 1 addition & 1 deletion dist/PathTools/Cwd.pm
Original file line number Diff line number Diff line change
Expand Up @@ -3,7 +3,7 @@ use strict;
use Exporter;


our $VERSION = '3.92';
our $VERSION = '3.93';
my $xs_version = $VERSION;
$VERSION =~ tr/_//d;

Expand Down
1 change: 1 addition & 0 deletions dist/PathTools/Cwd.xs
Original file line number Diff line number Diff line change
Expand Up @@ -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);
Expand Down
16 changes: 16 additions & 0 deletions lib/Internals.pod
Original file line number Diff line number Diff line change
Expand Up @@ -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<Cwd::getcwd()|Cwd/getcwd> or
L<Win32::GetCwd()|Win32/Win32::GetCwd()>. Only for use if loading L<Cwd::|Cwd> or
calling C<Win32::GetCwd()> and its C<AUTOLOAD> to L<Win32.pm|Win32> 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<PWD> env var. May disappear at any time. Probe for the sub's existance
before calling it and write C<if>/C<else> if C<Internals::getcwd> is
unavailable. Although this would be a bug, there is no guarentee it will
return the same identical string as L<Cwd::getcwd()|Cwd/getcwd> or
L<Win32::GetCwd()|Win32/Win32::GetCwd()>. 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.
Expand Down
8 changes: 6 additions & 2 deletions lib/blib.pm
Original file line number Diff line number Diff line change
Expand Up @@ -39,7 +39,7 @@ Nick Ing-Simmons [email protected]
use Cwd;
use File::Spec;

our $VERSION = '1.07';
our $VERSION = '1.08';
our $Verbose = 0;

sub import
Expand All @@ -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;
Expand Down
17 changes: 11 additions & 6 deletions pod/perldelta.pod
Original file line number Diff line number Diff line change
Expand Up @@ -123,11 +123,13 @@ XXX Remove this section if F<Porting/corelist-perldelta.pl> did not add any cont

=over 4

=item *

L<XXX> 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<blib.pm> was updated from 1.07 to 1.08. Previously when L<Win32.pm|Win32>,
and only that module, the C<cwd()> was obtained through inefficiently
shelling out to a new C<cmd.exe>, this was fixed and the C<cwd> when using
C<blib.pm> and L<Win32.pm|Win32> is obtained with a fast same-process API
function call the way C<Win32::GetCwd()> and C<Cwd::> do it.

=back

Expand Down Expand Up @@ -346,9 +348,12 @@ well.

=over 4

=item *
=item Internals::getcwd() is documented as very limited platform availability

XXX
C<Internals::getcwd()> 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<Win32> only, and only for
esoteric C<.t> TAP situations and esoteric internal core reasons.

=back

Expand Down
22 changes: 16 additions & 6 deletions universal.c
Original file line number Diff line number Diff line change
Expand Up @@ -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
Expand Down Expand Up @@ -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 },
Expand Down Expand Up @@ -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 },
Expand Down
1 change: 1 addition & 0 deletions util.c
Original file line number Diff line number Diff line change
Expand Up @@ -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;
Expand Down
35 changes: 24 additions & 11 deletions win32/win32.c
Original file line number Diff line number Diff line change
Expand Up @@ -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();
/*
Expand All @@ -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)
Expand Down

0 comments on commit 18599f6

Please sign in to comment.