In perl.git, the branch davem/post-5.12 has been updated
<http://perl5.git.perl.org/perl.git/commitdiff/fd69380d5d5b95ef16e2521cf4251b34ee0ce151?hp=d71e3dc326c2464ea298c6a68a3c5ab7f611e6c1>
- Log -----------------------------------------------------------------
commit fd69380d5d5b95ef16e2521cf4251b34ee0ce151
Author: David Mitchell <da...@iabyn.com>
Date: Tue Mar 23 12:11:43 2010 +0000
Fix assorted bugs related to magic (such as pos) not "sticking" to
magical array and hash elements; e.g. the following looped infinitely:
$h{tainted_element} =~ /..../g
There are two side-effects of this fix.
First, MGf_GSKIP has been extended to work on tied array
elements as well as hash elements. This is the mechanism that skips all
but the first tied element magic gets until after the next set.
Second, rvalue hash/array element access where the element has get magic,
now directly returns the element rather than a mortal copy.
The root cause of the bug was code similar to the following in pp_alem,
pp_aelemfast, pp_helem and pp_rv2av:
if (!lval && SvGMAGICAL(sv)) /* see note in pp_helem() */
sv = sv_mortalcopy(sv);
According to the note, this was added in 1998 to make this work:
local $tied{foo} = $tied{foo}
Since it returns a copy rather than the element, this make //g fail.
My first attempt, a few years ago, to fix this, took the approach that
the LHS of the bind should be made an lvalue in the presence of //g, since
it now modifies its LHS; i.e.
expr =~ // expr is rvalue
expr =~ s/// expr is lvalue
expr =~ //g expr was rvalue, I proposed to change it to lvalue
Unfortunately this fix broke too much stuff (stuff that was arguably
already broken, but it upset people). For example, f() ~= s////
correctly gives the error
Can't modify non-lvalue subroutine call
My fix extended f() =~ //g to give the same error. Which is reasonable,
because the g isn't doing what you want. But plenty of people had code that
only needed to match once and the g had just been cargo-culted. So it
broke their working code. So lets not do this.
My new approach has been to remove the sv_mortalcopy(). It turns out
that this is no longer needed to fix the local $tied{foo} issue.
Presumably that went away as a side-effect of my container/value magic
localisation rationalisation of a few years ago, although I haven't
analysed it - just noted that the tests still pass (!). However, an issue
with removing it is that mg_get() no longer gets called. So a plain
$tied_hash{elem};
in void context no longer calls FETCH(). Which broke some tests and might
break some code. Also, there's an issue with the delayed calling of magic
in @+[n] and %+{foo}; by the time the get magic is called, the original
pattern may have gone out of scope.
The solution is to simply replace the original
sv = sv_mortalcopy(sv);
with
mg_get(sv);
This then caused problems with tied array FETCH() getting called too much.
I fixed this by extending the MGf_GSKIP mechanism to tied arrays as well
as hashes. I don't understand why tied arrays have always been treated
differently than tied hashes, but unifying them didn't seem to break
anything (except for a Storable test, whose comment indicated that the
test's author thought FETCH() was being called to often anyway).
-----------------------------------------------------------------------
Summary of changes:
dist/Storable/t/tied_items.t | 4 ++--
mg.c | 2 +-
mg.h | 2 +-
pp_hot.c | 26 ++++++++++++++++----------
t/op/magic.t | 11 ++++++++++-
t/op/taint.t | 22 ++++++++++++++--------
6 files changed, 44 insertions(+), 23 deletions(-)
diff --git a/dist/Storable/t/tied_items.t b/dist/Storable/t/tied_items.t
index bd15e5c..03e6cfe 100644
--- a/dist/Storable/t/tied_items.t
+++ b/dist/Storable/t/tied_items.t
@@ -55,5 +55,5 @@ $ref2 = dclone $ref;
ok 5, $a_fetches == 0;
ok 6, $$ref2 eq $$ref;
ok 7, $$ref2 == 8;
-# I don't understand why it's 3 and not 2
-ok 8, $a_fetches == 3;
+# a bug in 5.12 and earlier caused an extra FETCH
+ok 8, $a_fetches == 2 || $a_fetches == 3 ;
diff --git a/mg.c b/mg.c
index 137026d..bf8bd53 100644
--- a/mg.c
+++ b/mg.c
@@ -1691,7 +1691,7 @@ Perl_magic_getpack(pTHX_ SV *sv, MAGIC *mg)
{
PERL_ARGS_ASSERT_MAGIC_GETPACK;
- if (mg->mg_ptr)
+ if (mg->mg_type == PERL_MAGIC_tiedelem)
mg->mg_flags |= MGf_GSKIP;
magic_methpack(sv,mg,"FETCH");
return 0;
diff --git a/mg.h b/mg.h
index fcac411..3362854 100644
--- a/mg.h
+++ b/mg.h
@@ -38,7 +38,7 @@ struct magic {
#define MGf_TAINTEDDIR 1 /* PERL_MAGIC_envelem only */
#define MGf_MINMATCH 1 /* PERL_MAGIC_regex_global only */
#define MGf_REFCOUNTED 2
-#define MGf_GSKIP 4
+#define MGf_GSKIP 4 /* skip further GETs until after next SET */
#define MGf_COPY 8 /* has an svt_copy MGVTBL entry */
#define MGf_DUP 0x10 /* has an svt_dup MGVTBL entry */
#define MGf_LOCAL 0x20 /* has an svt_local MGVTBL entry */
diff --git a/pp_hot.c b/pp_hot.c
index 3371e88..8f8af53 100644
--- a/pp_hot.c
+++ b/pp_hot.c
@@ -658,7 +658,7 @@ PP(pp_aelemfast)
SV *sv = (svp ? *svp : &PL_sv_undef);
EXTEND(SP, 1);
if (!lval && SvGMAGICAL(sv)) /* see note in pp_helem() */
- sv = sv_mortalcopy(sv);
+ mg_get(sv);
PUSHs(sv);
RETURN;
}
@@ -893,7 +893,7 @@ PP(pp_rv2av)
SV ** const svp = av_fetch(av, i, FALSE);
/* See note in pp_helem, and bug id #27839 */
SP[i+1] = svp
- ? SvGMAGICAL(*svp) ? sv_mortalcopy(*svp) : *svp
+ ? SvGMAGICAL(*svp) ? (mg_get(*svp), *svp) : *svp
: &PL_sv_undef;
}
}
@@ -1840,14 +1840,20 @@ PP(pp_helem)
vivify_ref(*svp, PL_op->op_private & OPpDEREF);
}
sv = (svp ? *svp : &PL_sv_undef);
- /* This makes C<local $tied{foo} = $tied{foo}> possible.
- * Pushing the magical RHS on to the stack is useless, since
- * that magic is soon destined to be misled by the local(),
- * and thus the later pp_sassign() will fail to mg_get() the
- * old value. This should also cure problems with delayed
- * mg_get()s. GSAR 98-07-03 */
+ /* Originally this did a conditional C<sv = sv_mortalcopy(sv)>; this
+ * was to make C<local $tied{foo} = $tied{foo}> possible.
+ * However, it seems no longer to be needed for that purpose, and
+ * introduced a new bug: stuff like C<while ($hash{taintedval} =~ /.../g>
+ * would loop endlessly since the pos magic is getting set on the
+ * mortal copy and lost. However, the copy has the effect of
+ * triggering the get magic, and losing it altogether made things like
+ * c<$tied{foo};> in void context no longer do get magic, which some
+ * code relied on. Also, delayed triggering of magic on @+ and friends
+ * meant the original regex may be out of scope by now. So as a
+ * compromise, do the get magic here. (The MGf_GSKIP flag will stop it
+ * being called too many times). */
if (!lval && SvGMAGICAL(sv))
- sv = sv_mortalcopy(sv);
+ mg_get(sv);
PUSHs(sv);
RETURN;
}
@@ -2983,7 +2989,7 @@ PP(pp_aelem)
}
sv = (svp ? *svp : &PL_sv_undef);
if (!lval && SvGMAGICAL(sv)) /* see note in pp_helem() */
- sv = sv_mortalcopy(sv);
+ mg_get(sv);
PUSHs(sv);
RETURN;
}
diff --git a/t/op/magic.t b/t/op/magic.t
index 3df3e4b..5a2733f 100644
--- a/t/op/magic.t
+++ b/t/op/magic.t
@@ -12,7 +12,7 @@ BEGIN {
use warnings;
use Config;
-plan (tests => 80);
+plan (tests => 81);
$Is_MSWin32 = $^O eq 'MSWin32';
$Is_NetWare = $^O eq 'NetWare';
@@ -443,6 +443,15 @@ is "@+", "10 1 6 10";
};
my @y = f();
is $x, "@y", "return a magic array ($x) vs (@y)";
+
+ sub f2 {
+ "abc" =~ /(?<foo>.)./;
+ my @h = %+;
+ $x = "@h";
+ return %+;
+ };
+ @y = f();
+ is $x, "@y", "return a magic hash ($x) vs (@y)";
}
# Test for bug [perl #36434]
diff --git a/t/op/taint.t b/t/op/taint.t
index b4c8bfe..f601552 100644
--- a/t/op/taint.t
+++ b/t/op/taint.t
@@ -17,7 +17,7 @@ use Config;
use File::Spec::Functions;
BEGIN { require './test.pl'; }
-plan tests => 319;
+plan tests => 321;
$| = 1;
@@ -1128,13 +1128,19 @@ TERNARY_CONDITIONALS: {
{
my @a;
- local $::TODO = 1;
- $a[0] = $^X;
- my $i = 0;
- while($a[0]=~ m/(.)/g ) {
- last if $i++ > 10000;
- }
- cmp_ok $i, '<', 10000, "infinite m//g";
+ $a[0] = $^X . '-';
+ $a[0]=~ m/(.)/g;
+ cmp_ok pos($a[0]), '>', 0, "infinite m//g on arrays (aelemfast)";
+
+ my $i = 1;
+ $a[$i] = $^X . '-';
+ $a[$i]=~ m/(.)/g;
+ cmp_ok pos($a[$i]), '>', 0, "infinite m//g on arrays (aelem)";
+
+ my %h;
+ $h{a} = $^X . '-';
+ $h{a}=~ m/(.)/g;
+ cmp_ok pos($h{a}), '>', 0, "infinite m//g on hashes (helem)";
}
SKIP:
--
Perl5 Master Repository
