In perl.git, the branch blead has been updated
<http://perl5.git.perl.org/perl.git/commitdiff/0824d66743a706cd268ace8fc9df03d7374c6886?hp=5f26d5fd39994d2ecb568aeb7efdba685fe9a350>
- Log -----------------------------------------------------------------
commit 0824d66743a706cd268ace8fc9df03d7374c6886
Author: David Mitchell <da...@iabyn.com>
Date: Tue May 25 11:38:35 2010 +0100
add OPpDEREFed flag to avoid double mg_get()
The previous commit made various ops such as rv2av unconditionally do
an SvGETMAGIC(). Under some circumstances this could cause a double
mg_get() (and hence double FETCH etc). In particular, when the
proceeding op was something like aelem with OPpDEREF, the aelem would
call vivify_ref(), which would call magic. So in peep(), mark
OP_RV2[SAH]V ops with the new OPpDEREFed flag if the preceding op was
OPpDEREF. Then use this flag to avoid a second dose of magic.
Note that RV2GV probably needs this flag too, but there weren't any
spare private flag bits left for that op (I think).
M dump.c
M ext/B/B/Concise.pm
M ext/B/t/f_sort.t
M op.c
M op.h
M pp.c
M pp_hot.c
commit bb1bc619ea68d9703fbd3fe5bc65ae000f90151f
Author: Father Chrysostomos (via RT) <perlbug-follo...@perl.org>
Date: Sun Jan 17 14:32:24 2010 -0800
Deref ops ignore get-magic when SvROK(sv)
This is just like bug 68192, except in this case itâs a different set
of operators that have had this problem for much longer.
M pp.c
M pp_hot.c
M t/op/tie.t
commit 6a5f8cbd14b4a44b35830907e944f1af0caeea90
Author: Father Chrysostomos <spr...@cpan.org>
Date: Mon May 24 11:56:25 2010 +0100
Just the tests from a proposed fix for 68192
The bug was fixed in a different way by davem, but the tests
are needed as the base for a commit to follow
M t/op/tie.t
-----------------------------------------------------------------------
Summary of changes:
dump.c | 5 ++
ext/B/B/Concise.pm | 1 +
ext/B/t/f_sort.t | 4 +-
op.c | 14 +++++++
op.h | 2 +
pp.c | 14 +-----
pp_hot.c | 8 +---
t/op/tie.t | 107 ++++++++++++++++++++++++++++++++++++++++++++++++++++
8 files changed, 136 insertions(+), 19 deletions(-)
diff --git a/dump.c b/dump.c
index 631f37c..46af01a 100644
--- a/dump.c
+++ b/dump.c
@@ -928,6 +928,11 @@ Perl_do_op_dump(pTHX_ I32 level, PerlIO *file, const OP *o)
if (o->op_private & OPpMAYBE_LVSUB)
sv_catpv(tmpsv, ",MAYBE_LVSUB");
}
+
+ if ((optype==OP_RV2SV || optype==OP_RV2AV || optype==OP_RV2HV)
+ && (o->op_private & OPpDEREFed))
+ sv_catpv(tmpsv, ",DEREFed");
+
if (optype == OP_AELEM || optype == OP_HELEM) {
if (o->op_private & OPpLVAL_DEFER)
sv_catpv(tmpsv, ",LVAL_DEFER");
diff --git a/ext/B/B/Concise.pm b/ext/B/B/Concise.pm
index 2699605..04e93cd 100644
--- a/ext/B/B/Concise.pm
+++ b/ext/B/B/Concise.pm
@@ -606,6 +606,7 @@ $priv{$_}{64} = "RTIME" for ("match", "subst", "substcont",
"qr");
"COMPL", "GROWS");
$priv{"repeat"}{64} = "DOLIST";
$priv{"leaveloop"}{64} = "CONT";
+$priv{$_}{4} = "DREFed" for (qw(rv2sv rv2av rv2hv));
@{$priv{$_}}{32,64,96} = ("DREFAV", "DREFHV", "DREFSV")
for (qw(rv2gv rv2sv padsv aelem helem));
$priv{$_}{16} = "STATE" for ("padav", "padhv", "padsv");
diff --git a/ext/B/t/f_sort.t b/ext/B/t/f_sort.t
index 6a36fcb..b940345 100644
--- a/ext/B/t/f_sort.t
+++ b/ext/B/t/f_sort.t
@@ -518,7 +518,7 @@ checkOptree(name => q{Compound sort/map Expression },
# l <|> mapwhile(other->m)[t26] lK
# m <#> gv[*_] s
# n <1> rv2sv sKM/DREFAV,1
-# o <1> rv2av[t4] sKR/1
+# o <1> rv2av[t4] sKR/DEREFed,1
# p <$> const[IV 0] s
# q <2> aelem sK/2
# - <@> scope lK
@@ -553,7 +553,7 @@ EOT_EOT
# l <|> mapwhile(other->m)[t12] lK
# m <$> gv(*_) s
# n <1> rv2sv sKM/DREFAV,1
-# o <1> rv2av[t2] sKR/1
+# o <1> rv2av[t2] sKR/DREFed,1
# p <$> const(IV 0) s
# q <2> aelem sK/2
# - <@> scope lK
diff --git a/op.c b/op.c
index 40ef4bc..da0ad2c 100644
--- a/op.c
+++ b/op.c
@@ -8877,6 +8877,20 @@ Perl_peep(pTHX_ register OP *o)
}
break;
}
+ case OP_RV2SV:
+ case OP_RV2AV:
+ case OP_RV2HV:
+ if (oldop
+ && ( oldop->op_type == OP_AELEM
+ || oldop->op_type == OP_PADSV
+ || oldop->op_type == OP_RV2SV
+ || oldop->op_type == OP_RV2GV
+ || oldop->op_type == OP_HELEM
+ )
+ && (oldop->op_private & OPpDEREF)
+ ) {
+ o->op_private |= OPpDEREFed;
+ }
case OP_SORT: {
/* will point to RV2AV or PADAV op on LHS/RHS of assign */
diff --git a/op.h b/op.h
index b9327bb..b66c4a1 100644
--- a/op.h
+++ b/op.h
@@ -191,6 +191,8 @@ Deprecated. Use C<GIMME_V> instead.
#define OPpDEREF_AV 32 /* Want ref to AV. */
#define OPpDEREF_HV 64 /* Want ref to HV. */
#define OPpDEREF_SV (32|64) /* Want ref to SV. */
+/* Private for OP_RV2SV, OP_RV2AV, OP_RV2AV */
+#define OPpDEREFed 4 /* prev op was OPpDEREF */
/* OP_ENTERSUB only */
#define OPpENTERSUB_DB 16 /* Debug subroutine. */
#define OPpENTERSUB_HASTARG 32 /* Called from OP tree. */
diff --git a/pp.c b/pp.c
index fa20914..937fdfd 100644
--- a/pp.c
+++ b/pp.c
@@ -139,6 +139,7 @@ PP(pp_rv2gv)
{
dVAR; dSP; dTOPss;
+ SvGETMAGIC(sv);
if (SvROK(sv)) {
wasref:
tryAMAGICunDEREF(to_gv);
@@ -156,11 +157,6 @@ PP(pp_rv2gv)
}
else {
if (!isGV_with_GP(sv)) {
- if (SvGMAGICAL(sv)) {
- mg_get(sv);
- if (SvROK(sv))
- goto wasref;
- }
if (!SvOK(sv) && sv != &PL_sv_undef) {
/* If this is a 'my' scalar and flag is set then vivify
* NI-S 1999/05/07
@@ -276,8 +272,9 @@ PP(pp_rv2sv)
dVAR; dSP; dTOPss;
GV *gv = NULL;
+ if (!(PL_op->op_private & OPpDEREFed))
+ SvGETMAGIC(sv);
if (SvROK(sv)) {
- wasref:
tryAMAGICunDEREF(to_sv);
sv = SvRV(sv);
@@ -295,11 +292,6 @@ PP(pp_rv2sv)
gv = MUTABLE_GV(sv);
if (!isGV_with_GP(gv)) {
- if (SvGMAGICAL(sv)) {
- mg_get(sv);
- if (SvROK(sv))
- goto wasref;
- }
gv = Perl_softref2xv(aTHX_ sv, "a SCALAR", SVt_PV, &sp);
if (!gv)
RETURN;
diff --git a/pp_hot.c b/pp_hot.c
index ea24062..a8c06b8 100644
--- a/pp_hot.c
+++ b/pp_hot.c
@@ -820,8 +820,9 @@ PP(pp_rv2av)
const bool is_pp_rv2av = PL_op->op_type == OP_RV2AV;
const svtype type = is_pp_rv2av ? SVt_PVAV : SVt_PVHV;
+ if (!(PL_op->op_private & OPpDEREFed))
+ SvGETMAGIC(sv);
if (SvROK(sv)) {
- wasref:
tryAMAGICunDEREF_var(is_pp_rv2av ? to_av_amg : to_hv_amg);
sv = SvRV(sv);
@@ -858,11 +859,6 @@ PP(pp_rv2av)
GV *gv;
if (!isGV_with_GP(sv)) {
- if (SvGMAGICAL(sv)) {
- mg_get(sv);
- if (SvROK(sv))
- goto wasref;
- }
gv = Perl_softref2xv(aTHX_ sv, is_pp_rv2av ? an_array : a_hash,
type, &sp);
if (!gv)
diff --git a/t/op/tie.t b/t/op/tie.t
index bd3f2e5..281c0d9 100644
--- a/t/op/tie.t
+++ b/t/op/tie.t
@@ -790,3 +790,110 @@ my $x = $a[0] + $h{foo} + $a[$i] + (@a)[0];
print "x=$x c=$c\n";
EXPECT
x=0 c=4
+########
+# Bug 68192 - numeric ops not calling mg_get when tied scalar holds a ref
+sub TIESCALAR { bless {}, __PACKAGE__ };
+sub STORE {};
+sub FETCH {
+ print "fetching... "; # make sure FETCH is called once per op
+ 123456
+};
+my $foo;
+tie $foo, __PACKAGE__;
+my $a = [1234567];
+$foo = $a;
+print "+ ", 0 + $foo, "\n";
+print "** ", $foo**1, "\n";
+print "* ", $foo*1, "\n";
+print "/ ", $foo*1, "\n";
+print "% ", $foo%123457, "\n";
+print "- ", $foo-0, "\n";
+print "neg ", - -$foo, "\n";
+print "int ", int $foo, "\n";
+print "abs ", abs $foo, "\n";
+print "== ", 123456 == $foo, "\n";
+print "< ", 123455 < $foo, "\n";
+print "> ", 123457 > $foo, "\n";
+print "<= ", 123456 <= $foo, "\n";
+print ">= ", 123456 >= $foo, "\n";
+print "!= ", 0 != $foo, "\n";
+print "<=> ", 123457 <=> $foo, "\n";
+EXPECT
+fetching... + 123456
+fetching... ** 123456
+fetching... * 123456
+fetching... / 123456
+fetching... % 123456
+fetching... - 123456
+fetching... neg 123456
+fetching... int 123456
+fetching... abs 123456
+fetching... == 1
+fetching... < 1
+fetching... > 1
+fetching... <= 1
+fetching... >= 1
+fetching... != 1
+fetching... <=> 1
+########
+# Ties returning overloaded objects
+{
+ package overloaded;
+ use overload
+ '*{}' => sub { print '*{}'; \*100 },
+ '@{}' => sub { print '@{}'; \...@100 },
+ '%{}' => sub { print '%{}'; \%100 },
+ '${}' => sub { print '${}'; \$100 },
+ map {
+ my $op = $_;
+ $_ => sub { print "$op"; 100 }
+ } qw< 0+ "" + ** * / % - neg int abs == < > <= >= != <=> >
+}
+$o = bless [], overloaded;
+
+sub TIESCALAR { bless {}, "" }
+sub FETCH { print "fetching... "; $o }
+sub STORE{}
+tie $ghew, "";
+
+$ghew=undef; 1+$ghew; print "\n";
+$ghew=undef; $ghew**1; print "\n";
+$ghew=undef; $ghew*1; print "\n";
+$ghew=undef; $ghew/1; print "\n";
+$ghew=undef; $ghew%1; print "\n";
+$ghew=undef; $ghew-1; print "\n";
+$ghew=undef; -$ghew; print "\n";
+$ghew=undef; int $ghew; print "\n";
+$ghew=undef; abs $ghew; print "\n";
+$ghew=undef; 1 == $ghew; print "\n";
+$ghew=undef; $ghew<1; print "\n";
+$ghew=undef; $ghew>1; print "\n";
+$ghew=undef; $ghew<=1; print "\n";
+$ghew=undef; $ghew >=1; print "\n";
+$ghew=undef; $ghew != 1; print "\n";
+$ghew=undef; $ghew<=>1; print "\n";
+$ghew=\*shrext; *$ghew; print "\n";
+$ghe...@spled; @$ghew; print "\n";
+$ghew=\%frit; %$ghew; print "\n";
+$ghew=\$drile; $$ghew; print "\n";
+EXPECT
+fetching... +
+fetching... **
+fetching... *
+fetching... /
+fetching... %
+fetching... -
+fetching... neg
+fetching... int
+fetching... abs
+fetching... ==
+fetching... <
+fetching... >
+fetching... <=
+fetching... >=
+fetching... !=
+fetching... <=>
+fetching... *{}
+fetching... @{}
+fetching... %{}
+fetching... ${}
--
Perl5 Master Repository
