In perl.git, the branch blead has been updated
<http://perl5.git.perl.org/perl.git/commitdiff/e167a7177da799ca1757dc382b386abd3ae29491?hp=acffc8af7f7e4e27d4ead35373df7dab0b76c200>
- Log -----------------------------------------------------------------
commit e167a7177da799ca1757dc382b386abd3ae29491
Author: Father Chrysostomos <spr...@cpan.org>
Date: Thu Aug 4 14:09:57 2016 -0700
gv.c:require_tie_mod: Create namesv only when needed
We only need it as an SV when we are going to load a module. Also,
there is no need for two separate SVs; we can use the same one for
Perl_load_module as we use subsequently in gv_stashsv.
M gv.c
commit 48a813738cbf9815d7f2664cc0893b8a19442e0b
Author: Father Chrysostomos <spr...@cpan.org>
Date: Thu Aug 4 13:59:32 2016 -0700
gv.c: comment typeo
M gv.c
commit a16834824708e400dd3b5e8219647a2266bc3d83
Author: Father Chrysostomos <spr...@cpan.org>
Date: Thu Aug 4 13:55:41 2016 -0700
gv.c:require_tie_mod: Accept pvn params
All the callers create the SV on the fly. We might as well put the
SV creation into the function itself. (A forthcoming commit will
refactor things to avoid the SV when possible.)
M embed.fnc
M embed.h
M gv.c
M proto.h
commit 15dd00343b389c6a74d3fbe7b76a39028f8c6865
Author: Daniel Dragan <bul...@hotmail.com>
Date: Thu Aug 4 00:37:46 2016 -0500
#126041 preserve systemroot env var during env wipe for Win32 in magic.t
This fixes a test fail with VC 2005 on WinXP in magic.t. See perl #126041
for an example of the failure. Systemroot env var is required on WinXP to
load SXS tracked DLLs, VC 2005 and 2008's MS libc's are SXS tracked
(before and after are not), so once %ENV is wipe and systemroot is deleted
the require Win32; cant load the XS DLL because the XS DLL is linked
against the SXS tracked libc specific to 2005/2008.
M t/op/magic.t
-----------------------------------------------------------------------
Summary of changes:
embed.fnc | 3 ++-
embed.h | 2 +-
gv.c | 27 ++++++++++++++-------------
proto.h | 4 ++--
t/op/magic.t | 2 ++
5 files changed, 21 insertions(+), 17 deletions(-)
diff --git a/embed.fnc b/embed.fnc
index 61c9296..baa15b2 100644
--- a/embed.fnc
+++ b/embed.fnc
@@ -1938,7 +1938,8 @@ s |bool|gv_magicalize|NN GV *gv|NN HV *stash|NN const
char *name \
s |void|maybe_multimagic_gv|NN GV *gv|NN const char *name|const svtype sv_type
s |bool|gv_is_in_main|NN const char *name|STRLEN len \
|const U32 is_utf8
-s |void |require_tie_mod|NN GV *gv|NN const char *varpv|NN SV* namesv \
+s |void |require_tie_mod|NN GV *gv|NN const char *varpv \
+ |NN const char * name|STRLEN len \
|const U32 flags
#endif
diff --git a/embed.h b/embed.h
index 3e43529..930ea91 100644
--- a/embed.h
+++ b/embed.h
@@ -1544,7 +1544,7 @@
#define gv_stashsvpvn_cached(a,b,c,d) S_gv_stashsvpvn_cached(aTHX_ a,b,c,d)
#define maybe_multimagic_gv(a,b,c) S_maybe_multimagic_gv(aTHX_ a,b,c)
#define parse_gv_stash_name(a,b,c,d,e,f,g,h) S_parse_gv_stash_name(aTHX_
a,b,c,d,e,f,g,h)
-#define require_tie_mod(a,b,c,d) S_require_tie_mod(aTHX_ a,b,c,d)
+#define require_tie_mod(a,b,c,d,e) S_require_tie_mod(aTHX_ a,b,c,d,e)
# endif
# if defined(PERL_IN_HV_C)
#define clear_placeholders(a,b) S_clear_placeholders(aTHX_ a,b)
diff --git a/gv.c b/gv.c
index cd1c32d..1e2f515 100644
--- a/gv.c
+++ b/gv.c
@@ -1305,7 +1305,8 @@ Perl_gv_autoload_pvn(pTHX_ HV *stash, const char *name,
STRLEN len, U32 flags)
* the sv slot must already be magicalized.
*/
STATIC void
-S_require_tie_mod(pTHX_ GV *gv, const char *varpv, SV* namesv, const U32 flags)
+S_require_tie_mod(pTHX_ GV *gv, const char *varpv, const char * name,
+ STRLEN len, const U32 flags)
{
const char varname = *varpv; /* varpv might be clobbered by
load_module, so save it. For the
@@ -1324,19 +1325,20 @@ S_require_tie_mod(pTHX_ GV *gv, const char *varpv, SV*
namesv, const U32 flags)
dSP;
ENTER;
- SAVEFREESV(namesv);
#define HV_FETCH_TIE_FUNC (GV **)hv_fetch(stash, "_tie_it", 7, 0)
/* Load the module if it is not loaded. */
- if (!(stash = gv_stashsv(namesv, 0))
+ if (!(stash = gv_stashpvn(name, len, 0))
|| !(gvp = HV_FETCH_TIE_FUNC) || !*gvp || !GvCV(*gvp))
{
- SV *module = newSVsv(namesv);
+ SV * const namesv = newSVpvn(name, len);
const char type = varname == '[' ? '$' : '%';
+ SAVEFREESV(namesv);
if ( flags & 1 )
save_scalar(gv);
- Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT, module, NULL);
+ Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT,
+ SvREFCNT_inc_NN(namesv), NULL);
assert(sp == PL_stack_sp);
stash = gv_stashsv(namesv, 0);
if (!stash)
@@ -1354,7 +1356,6 @@ S_require_tie_mod(pTHX_ GV *gv, const char *varpv, SV*
namesv, const U32 flags)
call_sv((SV *)*gvp, G_VOID|G_DISCARD);
LEAVE;
}
- else SvREFCNT_dec_NN(namesv);
}
/*
@@ -1450,7 +1451,7 @@ S_gv_stashpvn_internal(pTHX_ const char *name, U32
namelen, I32 flags)
gv_stashsvpvn_cached
Returns a pointer to the stash for a specified package, possibly
-cached. Implements both C<gv_stashpvn> and C<gc_stashsv>.
+cached. Implements both C<gv_stashpvn> and C<gv_stashsv>.
Requires one of either namesv or namepv to be non-null.
@@ -2082,7 +2083,7 @@ S_gv_magicalize(pTHX_ GV *gv, HV *stash, const char
*name, STRLEN len,
/* magicalization must be done before require_tie_mod is called */
if (sv_type == SVt_PVHV || sv_type == SVt_PVGV)
- require_tie_mod(gv, "!", newSVpvs("Errno"), 1);
+ require_tie_mod(gv, "!", "Errno", 5, 1);
break;
case '-': /* $- */
@@ -2099,7 +2100,7 @@ S_gv_magicalize(pTHX_ GV *gv, HV *stash, const char
*name, STRLEN len,
SvREADONLY_on(av);
if (sv_type == SVt_PVHV || sv_type == SVt_PVGV)
- require_tie_mod(gv, name, newSVpvs("Tie::Hash::NamedCapture"),
0);
+ require_tie_mod(gv, name, "Tie::Hash::NamedCapture",23, 0);
break;
}
@@ -2119,7 +2120,7 @@ S_gv_magicalize(pTHX_ GV *gv, HV *stash, const char
*name, STRLEN len,
case '[': /* $[ */
if ((sv_type == SVt_PV || sv_type == SVt_PVGV)
&& FEATURE_ARYBASE_IS_ENABLED) {
- require_tie_mod(gv,name,newSVpvs("arybase"),0);
+ require_tie_mod(gv,name,"arybase",7,0);
}
else goto magicalize;
break;
@@ -2207,9 +2208,9 @@ S_maybe_multimagic_gv(pTHX_ GV *gv, const char *name,
const svtype sv_type)
if (sv_type == SVt_PVHV || sv_type == SVt_PVGV) {
if (*name == '!')
- require_tie_mod(gv, "!", newSVpvs("Errno"), 1);
+ require_tie_mod(gv, "!", "Errno", 5, 1);
else if (*name == '-' || *name == '+')
- require_tie_mod(gv, name, newSVpvs("Tie::Hash::NamedCapture"), 0);
+ require_tie_mod(gv, name, "Tie::Hash::NamedCapture", 23, 0);
} else if (sv_type == SVt_PV) {
if (*name == '*' || *name == '#') {
/* diag_listed_as: $* is no longer supported */
@@ -2221,7 +2222,7 @@ S_maybe_multimagic_gv(pTHX_ GV *gv, const char *name,
const svtype sv_type)
if (sv_type==SVt_PV || sv_type==SVt_PVGV) {
switch (*name) {
case '[':
- require_tie_mod(gv,name,newSVpvs("arybase"),0);
+ require_tie_mod(gv,name,"arybase",7,0);
break;
#ifdef PERL_SAWAMPERSAND
case '`':
diff --git a/proto.h b/proto.h
index d3918b1..3cdb21c 100644
--- a/proto.h
+++ b/proto.h
@@ -4324,9 +4324,9 @@ STATIC void S_maybe_multimagic_gv(pTHX_ GV *gv,
const char *name, const svtype s
STATIC bool S_parse_gv_stash_name(pTHX_ HV **stash, GV **gv, const char
**name, STRLEN *len, const char *nambeg, STRLEN full_len, const U32 is_utf8,
const I32 add);
#define PERL_ARGS_ASSERT_PARSE_GV_STASH_NAME \
assert(stash); assert(gv); assert(name); assert(len); assert(nambeg)
-STATIC void S_require_tie_mod(pTHX_ GV *gv, const char *varpv, SV* namesv,
const U32 flags);
+STATIC void S_require_tie_mod(pTHX_ GV *gv, const char *varpv, const char *
name, STRLEN len, const U32 flags);
#define PERL_ARGS_ASSERT_REQUIRE_TIE_MOD \
- assert(gv); assert(varpv); assert(namesv)
+ assert(gv); assert(varpv); assert(name)
#endif
#if defined(PERL_IN_GV_C) || defined(PERL_IN_SV_C) || defined(PERL_IN_PAD_C)
|| defined(PERL_IN_OP_C)
PERL_CALLCONV void Perl_sv_add_backref(pTHX_ SV *const tsv, SV *const sv);
diff --git a/t/op/magic.t b/t/op/magic.t
index 536b225..f8c822b 100644
--- a/t/op/magic.t
+++ b/t/op/magic.t
@@ -719,10 +719,12 @@ SKIP: {
if $ENV{PERL_VALGRIND} || $Is_VMS;
$PATH = $ENV{PATH};
+ $SYSTEMROOT = $ENV{SYSTEMROOT} if exists $ENV{SYSTEMROOT}; # win32
$PDL = $ENV{PERL_DESTRUCT_LEVEL} || 0;
$ENV{foo} = "bar";
%ENV = ();
$ENV{PATH} = $PATH;
+ $ENV{SYSTEMROOT} = $SYSTEMROOT if defined $SYSTEMROOT;
$ENV{PERL_DESTRUCT_LEVEL} = $PDL || 0;
if ($Is_MSWin32) {
is `set foo 2>NUL`, "";
--
Perl5 Master Repository
