Skip to content

Commit 769fbf2

Browse files
committed
blib.pm dont shell out to "cmd.exe" on Win32+Win32.pm
-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.
1 parent a6f05e6 commit 769fbf2

File tree

8 files changed

+76
-26
lines changed

8 files changed

+76
-26
lines changed

dist/PathTools/Cwd.pm

Lines changed: 1 addition & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -3,7 +3,7 @@ use strict;
33
use Exporter;
44

55

6-
our $VERSION = '3.92';
6+
our $VERSION = '3.93';
77
my $xs_version = $VERSION;
88
$VERSION =~ tr/_//d;
99

dist/PathTools/Cwd.xs

Lines changed: 1 addition & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -302,6 +302,7 @@ int Perl_getcwd_sv(pTHX_ SV *sv)
302302
/* Some getcwd()s automatically allocate a buffer of the given
303303
* size from the heap if they are given a NULL buffer pointer.
304304
* The problem is that this behaviour is not portable. */
305+
/* XXX bug use PerlEnv_get_childdir/PerlEnv_free_childenv all OSes? */
305306
if (getcwd(buf, sizeof(buf) - 1)) {
306307
STRLEN len = strlen(buf);
307308
sv_setpvn(sv, buf, len);

lib/Internals.pod

Lines changed: 16 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -57,6 +57,22 @@ to implement higher-level behavior which should be used instead.
5757
See the core implementation for the exact meaning of the readonly flag for
5858
each internal variable type.
5959

60+
=item Internals::getcwd()
61+
62+
Internally core maintained version of L<Cwd::getcwd()|Cwd/getcwd> or
63+
L<Win32::GetCwd()|Win32/Win32::GetCwd()>. Only for use if loading L<Cwd::|Cwd> or
64+
calling C<Win32::GetCwd()> and its C<AUTOLOAD> to L<Win32.pm|Win32> will
65+
somehow break a TAP test in a C<.t>.
66+
67+
Not defined on all platforms and all perl build flag configs. May not set
68+
C<PWD> env var. May disappear at any time. Probe for the sub's existance
69+
before calling it and write C<if>/C<else> if C<Internals::getcwd> is
70+
unavailable. Although this would be a bug, there is no guarentee it will
71+
return the same identical string as L<Cwd::getcwd()|Cwd/getcwd> or
72+
L<Win32::GetCwd()|Win32/Win32::GetCwd()>. The public implementations can get patched
73+
in the future for some future discovered bug while this sub keeps the buggy
74+
return value.
75+
6076
=item hv_clear_placeholders(%hash)
6177

6278
Clear any placeholders from a locked hash. Should not be used directly.

lib/blib.pm

Lines changed: 6 additions & 2 deletions
Original file line numberDiff line numberDiff line change
@@ -39,7 +39,7 @@ Nick Ing-Simmons [email protected]
3939
use Cwd;
4040
use File::Spec;
4141

42-
our $VERSION = '1.07';
42+
our $VERSION = '1.08';
4343
our $Verbose = 0;
4444

4545
sub import
@@ -52,7 +52,11 @@ sub import
5252
# That means that it would not be possible to run `make test`
5353
# for the Win32 module because blib.pm would always load the
5454
# installed version before @INC gets updated with the blib path.
55-
chomp($dir = `cd`);
55+
if(defined &Internals::getcwd) {
56+
$dir = Internals::getcwd();
57+
} else {
58+
chomp($dir = `cd`);
59+
}
5660
}
5761
else {
5862
$dir = getcwd;

pod/perldelta.pod

Lines changed: 11 additions & 6 deletions
Original file line numberDiff line numberDiff line change
@@ -123,11 +123,13 @@ XXX Remove this section if F<Porting/corelist-perldelta.pl> did not add any cont
123123

124124
=over 4
125125

126-
=item *
127-
128-
L<XXX> has been upgraded from version A.xx to B.yy.
126+
=item blib.pm
129127

130-
XXX If there was something important to note about this change, include that here.
128+
C<blib.pm> was updated from 1.07 to 1.08. Previously when L<Win32.pm|Win32>,
129+
and only that module, the C<cwd()> was obtained through inefficiently
130+
shelling out to a new C<cmd.exe>, this was fixed and the C<cwd> when using
131+
C<blib.pm> and L<Win32.pm|Win32> is obtained with a fast same-process API
132+
function call the way C<Win32::GetCwd()> and C<Cwd::> do it.
131133

132134
=back
133135

@@ -346,9 +348,12 @@ well.
346348

347349
=over 4
348350

349-
=item *
351+
=item Internals::getcwd() is documented as very limited platform availability
350352

351-
XXX
353+
C<Internals::getcwd()> is documented as experimental, unsupported, not-bug-free
354+
and removeable in the future, and very limited availability on random
355+
platforms and perl core build flags. Basically C<Win32> only, and only for
356+
esoteric C<.t> TAP situations and esoteric internal core reasons.
352357

353358
=back
354359

universal.c

Lines changed: 16 additions & 6 deletions
Original file line numberDiff line numberDiff line change
@@ -1136,16 +1136,17 @@ XS(XS_re_regexp_pattern)
11361136
XS(XS_Internals_getcwd)
11371137
{
11381138
dXSARGS;
1139-
SV *sv = sv_newmortal();
1140-
11411139
if (items != 0)
11421140
croak_xs_usage(cv, "");
1141+
EXTEND(SP,1);
1142+
dXSTARG;
1143+
PUSHs(TARG);
1144+
PUTBACK;
11431145

1144-
(void)getcwd_sv(sv);
1146+
(void)getcwd_sv(TARG);
11451147

1146-
SvTAINTED_on(sv);
1147-
PUSHs(sv);
1148-
XSRETURN(1);
1148+
SvTAINTED_on(TARG);
1149+
SvSETMAGIC(TARG);
11491150
}
11501151

11511152
#endif
@@ -1314,6 +1315,10 @@ struct xsub_details {
13141315
int ix;
13151316
};
13161317

1318+
#ifdef WIN32
1319+
XS_EXTERNAL(w32_GetCwd);
1320+
#endif
1321+
13171322
static const struct xsub_details these_details[] = {
13181323
{"UNIVERSAL::isa", XS_UNIVERSAL_isa, NULL, 0 },
13191324
{"UNIVERSAL::can", XS_UNIVERSAL_can, NULL, 0 },
@@ -1344,6 +1349,11 @@ static const struct xsub_details these_details[] = {
13441349
{"re::regexp_pattern", XS_re_regexp_pattern, "$", 0 },
13451350
#if defined(HAS_GETCWD) && defined(PERL_IS_MINIPERL)
13461351
{"Internals::getcwd", XS_Internals_getcwd, "", 0 },
1352+
#elif defined(WIN32)
1353+
/* Always offer backup, Win32CORE.c vs AUTOLOAD vs Win32.pm
1354+
vs Win32.dll vs loading a .pm or .dll at all, has rare dep/recursion
1355+
problems in certain modules or .t files. See w32_GetCwd() . */
1356+
{"Internals::getcwd", w32_GetCwd, "", 0 },
13471357
#endif
13481358
{"Tie::Hash::NamedCapture::_tie_it", XS_NamedCapture_tie_it, NULL, 0 },
13491359
{"Tie::Hash::NamedCapture::TIEHASH", XS_NamedCapture_TIEHASH, NULL, 0 },

util.c

Lines changed: 1 addition & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -4124,6 +4124,7 @@ Perl_getcwd_sv(pTHX_ SV *sv)
41244124
/* Some getcwd()s automatically allocate a buffer of the given
41254125
* size from the heap if they are given a NULL buffer pointer.
41264126
* The problem is that this behaviour is not portable. */
4127+
/* XXX bug use PerlEnv_get_childdir/PerlEnv_free_childenv all OSes? */
41274128
if (getcwd(buf, sizeof(buf) - 1)) {
41284129
sv_setpv(sv, buf);
41294130
return TRUE;

win32/win32.c

Lines changed: 24 additions & 11 deletions
Original file line numberDiff line numberDiff line change
@@ -5016,12 +5016,17 @@ XS(w32_SetChildShowWindow)
50165016
}
50175017

50185018

5019-
#ifdef PERL_IS_MINIPERL
5020-
/* shelling out is much slower, full perl uses Win32.pm */
5021-
XS(w32_GetCwd)
5019+
5020+
/* Shelling out is much slower, full perl uses Win32.pm.
5021+
So for miniperl install "Win32::GetCwd", and for mini and full perl
5022+
install this as "Internals::getcwd". On Win32 platform, because of
5023+
Win32CORE.c AUTOLOAD vs DynaLoader.pm vs Win32.pm, race and recursion
5024+
and dependency problems can happen in rare cases. For example, see blib.pm
5025+
Offer Internals::getcwd as a backup at all times. */
5026+
XS_EXTERNAL(w32_GetCwd)
50225027
{
5023-
dXSARGS;
5024-
PERL_UNUSED_VAR(items);
5028+
5029+
SV *sv;
50255030
/* Make the host for current directory */
50265031
char* ptr = PerlEnv_get_childdir();
50275032
/*
@@ -5030,20 +5035,28 @@ XS(w32_GetCwd)
50305035
* else return 'undef'
50315036
*/
50325037
if (ptr) {
5033-
SV *sv = sv_newmortal();
5038+
dXSTARG;
5039+
sv = TARG;
50345040
sv_setpv(sv, ptr);
50355041
PerlEnv_free_childdir(ptr);
50365042

50375043
#ifndef INCOMPLETE_TAINTS
50385044
SvTAINTED_on(sv);
50395045
#endif
5040-
5041-
ST(0) = sv;
5042-
XSRETURN(1);
5046+
SvSETMAGIC(sv);
50435047
}
5044-
XSRETURN_UNDEF;
5048+
else {
5049+
sv = &PL_sv_undef;
5050+
}
5051+
{
5052+
dXSARGS;
5053+
PERL_UNUSED_VAR(items);
5054+
XSprePUSH;
5055+
XPUSHs(sv);
5056+
PUTBACK;
5057+
}
5058+
return;
50455059
}
5046-
#endif
50475060

50485061
void
50495062
Perl_init_os_extras(void)

0 commit comments

Comments
 (0)