summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorDavid Mitchell <davem@iabyn.com>2010-03-23 12:11:43 +0000
committerDavid Mitchell <davem@iabyn.com>2010-03-23 12:11:43 +0000
commitfd69380d5d5b95ef16e2521cf4251b34ee0ce151 (patch)
tree06f3bdf160300d7361e10d1ef591d0fb77801406
parentd71e3dc326c2464ea298c6a68a3c5ab7f611e6c1 (diff)
downloadperl-fd69380d5d5b95ef16e2521cf4251b34ee0ce151.tar.gz
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).
-rw-r--r--dist/Storable/t/tied_items.t4
-rw-r--r--mg.c2
-rw-r--r--mg.h2
-rw-r--r--pp_hot.c26
-rw-r--r--t/op/magic.t11
-rw-r--r--t/op/taint.t22
6 files changed, 44 insertions, 23 deletions
diff --git a/dist/Storable/t/tied_items.t b/dist/Storable/t/tied_items.t
index bd15e5cc4f..03e6cfe9ff 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 137026d8d0..bf8bd53a74 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 fcac411113..33628546c9 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 3371e889ea..8f8af53230 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 3df3e4bab0..5a2733fd3a 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 b4c8bfea53..f601552e28 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: