develooper Front page | perl.perl5.porters | Postings from August 2011

[perl #97088] [PATCH] Prevent executing get-magic twice for derefing by makin a non-magic copy instead of using the OPpDEREFed flag.

Thread Next
From:
Gerard Goossen
Date:
August 16, 2011 00:38
Subject:
[perl #97088] [PATCH] Prevent executing get-magic twice for derefing by makin a non-magic copy instead of using the OPpDEREFed flag.
Message ID:
rt-3.6.HEAD-31297-1313480304-160.97088-75-0@perl.org
# New Ticket Created by  Gerard Goossen 
# Please include the string:  [perl #97088]
# in the subject line of all future correspondence about this issue. 
# <URL: https://rt.perl.org:443/rt3/Ticket/Display.html?id=97088 >



This is a bug report for perl from gerard@ggoossen.net,
generated with the help of perlbug 1.39 running under perl 5.15.1.

>From 6c657ff634b3b3a85e93a22d9b2af7510b5df74b Mon Sep 17 00:00:00 2001
From: Gerard Goossen <gerard@ggoossen.net>
Date: Sun, 14 Aug 2011 11:19:38 +0200
Subject: [PATCH] Prevent executing get-magic twice for derefing by makin a
 non-magic copy instead of using the OPpDEREFed flag.

Currently preventing get-magic to be executed twice (once by the op
returning the value to do autovivication and once by the rv2xv op).
is being done by setting setting OPpDEREFed on the rv2xv op in the
peephole optimizer, but this doesn't always work, see the test cases
added.
Instead of setting the OPpDEREFed flag, make a non-magic copy of the
SV in vivify_ref (the first time get-magic is executed).
---
 dump.c           |    4 ----
 embed.fnc        |    2 +-
 ext/B/t/f_sort.t |    4 ++--
 lib/overload.t   |    2 +-
 op.c             |   21 ---------------------
 op.h             |    2 --
 pp.c             |    5 ++---
 pp_ctl.c         |    6 +-----
 pp_hot.c         |   25 ++++++++++++++-----------
 proto.h          |    4 ++--
 t/op/gmagic.t    |    5 +++++
 11 files changed, 28 insertions(+), 52 deletions(-)

diff --git a/dump.c b/dump.c
index c19cb8e..7fa0ff2 100644
--- a/dump.c
+++ b/dump.c
@@ -1020,10 +1020,6 @@ Perl_do_op_dump(pTHX_ I32 level, PerlIO *file, const OP *o)
 		    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/embed.fnc b/embed.fnc
index 4da1d75..1a8acbd 100644
--- a/embed.fnc
+++ b/embed.fnc
@@ -1382,7 +1382,7 @@ ApdR	|char*	|sv_uni_display	|NN SV *dsv|NN SV *ssv|STRLEN pvlim|UV flags
 : Used by Data::Alias
 EXp	|void	|vivify_defelem	|NN SV* sv
 : Used in pp.c
-p	|void	|vivify_ref	|NN SV* sv|U32 to_what
+p	|void	|vivify_ref	|NN SV** svp|U32 to_what
 : Used in pp_sys.c
 p	|I32	|wait4pid	|Pid_t pid|NN int* statusp|int flags
 : Used in locale.c and perl.c
diff --git a/ext/B/t/f_sort.t b/ext/B/t/f_sort.t
index d5288a5..58a8cf2 100644
--- a/ext/B/t/f_sort.t
+++ b/ext/B/t/f_sort.t
@@ -517,7 +517,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/DREFed,1
+# o      <1> rv2av[t4] sKR/1
 # p      <$> const[IV 0] s
 # q      <2> aelem sK/2
 # -      <@> scope lK
@@ -552,7 +552,7 @@ EOT_EOT
 # l  <|> mapwhile(other->m)[t12] lK
 # m      <$> gv(*_) s
 # n      <1> rv2sv sKM/DREFAV,1
-# o      <1> rv2av[t2] sKR/DREFed,1
+# o      <1> rv2av[t2] sKR/1
 # p      <$> const(IV 0) s
 # q      <2> aelem sK/2
 # -      <@> scope lK
diff --git a/lib/overload.t b/lib/overload.t
index 12ed55b..605429e 100644
--- a/lib/overload.t
+++ b/lib/overload.t
@@ -1820,7 +1820,7 @@ foreach my $op (qw(<=> == != < <= > >=)) {
 
 	$subs{'%{}'} = '%s';
 	push @tests, [ {qw(a 1 b 2 c 3)}, 'join "", sort keys %%{%s}',
-			'(%{})', undef, [ 1, 2, 0 ], 0 ];
+			'(%{})', undef, [ 1, 1, 0 ], 0 ];
 
 	$subs{'&{}'} = '%s';
 	push @tests, [ sub {99}, 'do {&{%s} for 1,2}',
diff --git a/op.c b/op.c
index ad0d3f8..e25d19e 100644
--- a/op.c
+++ b/op.c
@@ -9926,27 +9926,6 @@ Perl_rpeep(pTHX_ register OP *o)
 	    DEFER(cPMOP->op_pmstashstartu.op_pmreplstart);
 	    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)
-		 )
-		 || (   oldop->op_type == OP_ENTERSUB
-		     && oldop->op_private & OPpENTERSUB_DEREF )
-		)
-	    ) {
-		o->op_private |= OPpDEREFed;
-	    }
-
 	case OP_SORT: {
 	    /* will point to RV2AV or PADAV op on LHS/RHS of assign */
 	    OP *oleft;
diff --git a/op.h b/op.h
index f01e0bf..fddfc3d 100644
--- a/op.h
+++ b/op.h
@@ -201,8 +201,6 @@ 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. */
diff --git a/pp.c b/pp.c
index 8649bec..f0ea025 100644
--- a/pp.c
+++ b/pp.c
@@ -301,8 +301,7 @@ PP(pp_rv2sv)
     dVAR; dSP; dTOPss;
     GV *gv = NULL;
 
-    if (!(PL_op->op_private & OPpDEREFed))
-	SvGETMAGIC(sv);
+    SvGETMAGIC(sv);
     if (SvROK(sv)) {
 	if (SvAMAGIC(sv)) {
 	    sv = amagic_deref_call(sv, to_sv_amg);
@@ -340,7 +339,7 @@ PP(pp_rv2sv)
 		Perl_croak(aTHX_ "%s", PL_no_localize_ref);
 	}
 	else if (PL_op->op_private & OPpDEREF)
-	    vivify_ref(sv, PL_op->op_private & OPpDEREF);
+	    vivify_ref(&sv, PL_op->op_private & OPpDEREF);
     }
     SETs(sv);
     RETURN;
diff --git a/pp_ctl.c b/pp_ctl.c
index c0a16e4..9cec2f4 100644
--- a/pp_ctl.c
+++ b/pp_ctl.c
@@ -2366,7 +2366,7 @@ S_return_lvalues(pTHX_ SV **mark, SV **sp, SV **newsp, I32 gimme,
 		    assert(cx->blk_sub.retop->op_type == OP_RV2HV);
 		    deref_type = OPpDEREF_HV;
 		}
-		vivify_ref(TOPs, deref_type);
+		vivify_ref(&TOPs, deref_type);
 	    }
 	}
     }
@@ -2416,7 +2416,6 @@ PP(pp_return)
     bool popsub2 = FALSE;
     bool clear_errsv = FALSE;
     bool lval = FALSE;
-    bool gmagic = FALSE;
     I32 gimme;
     SV **newsp;
     PMOP *newpm;
@@ -2459,7 +2458,6 @@ PP(pp_return)
 	popsub2 = TRUE;
 	lval = !!CvLVALUE(cx->blk_sub.cv);
 	retop = cx->blk_sub.retop;
-	gmagic = CxLVAL(cx) & OPpENTERSUB_DEREF;
 	cxstack_ix++; /* preserve cx entry on stack for use by POPSUB */
 	break;
     case CXt_EVAL:
@@ -2499,7 +2497,6 @@ PP(pp_return)
 			*++newsp = SvREFCNT_inc(*SP);
 			FREETMPS;
 			sv_2mortal(*newsp);
-			if (gmagic) SvGETMAGIC(*newsp);
 		    }
 		    else {
 			sv = SvREFCNT_inc(*SP);	/* FREETMPS could clobber it */
@@ -2510,7 +2507,6 @@ PP(pp_return)
 		}
 		else if (SvTEMP(*SP) && SvREFCNT(*SP) == 1) {
 		    *++newsp = *SP;
-		    if (gmagic) SvGETMAGIC(*SP);
 		}
 		else
 		    *++newsp = sv_mortalcopy(*SP);
diff --git a/pp_hot.c b/pp_hot.c
index 2f159e5..7a1c505 100644
--- a/pp_hot.c
+++ b/pp_hot.c
@@ -311,7 +311,7 @@ PP(pp_padsv)
 		SAVECLEARSV(PAD_SVl(PL_op->op_targ));
         if (PL_op->op_private & OPpDEREF) {
 	    PUTBACK;
-	    vivify_ref(PAD_SVl(PL_op->op_targ), PL_op->op_private & OPpDEREF);
+	    vivify_ref(&TOPs, PL_op->op_private & OPpDEREF);
 	    SPAGAIN;
 	}
     }
@@ -759,8 +759,7 @@ 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);
+    SvGETMAGIC(sv);
     if (SvROK(sv)) {
 	if (SvAMAGIC(sv)) {
 	    sv = amagic_deref_call(sv, is_pp_rv2av ? to_av_amg : to_hv_amg);
@@ -1792,8 +1791,9 @@ PP(pp_helem)
 	    else
 		SAVEHDELETE(hv, keysv);
 	}
-	else if (PL_op->op_private & OPpDEREF)
-	    vivify_ref(*svp, PL_op->op_private & OPpDEREF);
+	else if (PL_op->op_private & OPpDEREF) {
+	    vivify_ref(svp, PL_op->op_private & OPpDEREF);
+	}
     }
     sv = (svp ? *svp : &PL_sv_undef);
     /* Originally this did a conditional C<sv = sv_mortalcopy(sv)>; this
@@ -2463,14 +2463,12 @@ PP(pp_leavesub)
     I32 gimme;
     register PERL_CONTEXT *cx;
     SV *sv;
-    bool gmagic;
 
     if (CxMULTICALL(&cxstack[cxstack_ix]))
 	return 0;
 
     POPBLOCK(cx,newpm);
     cxstack_ix++; /* temporarily protect top context */
-    gmagic = CxLVAL(cx) & OPpENTERSUB_DEREF;
 
     TAINT_NOT;
     if (gimme == G_SCALAR) {
@@ -2481,7 +2479,6 @@ PP(pp_leavesub)
 		    *MARK = SvREFCNT_inc(TOPs);
 		    FREETMPS;
 		    sv_2mortal(*MARK);
-		    if (gmagic) SvGETMAGIC(*MARK);
 		}
 		else {
 		    sv = SvREFCNT_inc(TOPs);	/* FREETMPS could clobber it */
@@ -2492,7 +2489,6 @@ PP(pp_leavesub)
 	    }
 	    else if (SvTEMP(TOPs) && SvREFCNT(TOPs) == 1) {
 		*MARK = TOPs;
-		if (gmagic) SvGETMAGIC(TOPs);
 	    }
 	    else
 		*MARK = sv_mortalcopy(TOPs);
@@ -2843,7 +2839,7 @@ PP(pp_aelem)
 		SAVEADELETE(av, elem);
 	}
 	else if (PL_op->op_private & OPpDEREF)
-	    vivify_ref(*svp, PL_op->op_private & OPpDEREF);
+	    vivify_ref(svp, PL_op->op_private & OPpDEREF);
     }
     sv = (svp ? *svp : &PL_sv_undef);
     if (!lval && SvRMAGICAL(av) && SvGMAGICAL(sv)) /* see note in pp_helem() */
@@ -2853,8 +2849,9 @@ PP(pp_aelem)
 }
 
 void
-Perl_vivify_ref(pTHX_ SV *sv, U32 to_what)
+Perl_vivify_ref(pTHX_ SV **svp, U32 to_what)
 {
+    SV* sv = *svp;
     PERL_ARGS_ASSERT_VIVIFY_REF;
 
     SvGETMAGIC(sv);
@@ -2876,6 +2873,12 @@ Perl_vivify_ref(pTHX_ SV *sv, U32 to_what)
 	SvROK_on(sv);
 	SvSETMAGIC(sv);
     }
+    if (SvGMAGICAL(sv)) {
+	/* copy the sv without magic to prevent magic from being
+	   executed twice */
+	*svp = sv_newmortal();
+	sv_setsv_nomg(*svp, sv);
+    }
 }
 
 PP(pp_method)
diff --git a/proto.h b/proto.h
index b267253..6b13206 100644
--- a/proto.h
+++ b/proto.h
@@ -4423,10 +4423,10 @@ PERL_CALLCONV void	Perl_vivify_defelem(pTHX_ SV* sv)
 #define PERL_ARGS_ASSERT_VIVIFY_DEFELEM	\
 	assert(sv)
 
-PERL_CALLCONV void	Perl_vivify_ref(pTHX_ SV* sv, U32 to_what)
+PERL_CALLCONV void	Perl_vivify_ref(pTHX_ SV** svp, U32 to_what)
 			__attribute__nonnull__(pTHX_1);
 #define PERL_ARGS_ASSERT_VIVIFY_REF	\
-	assert(sv)
+	assert(svp)
 
 PERL_CALLCONV void	Perl_vload_module(pTHX_ U32 flags, SV* name, SV* ver, va_list* args)
 			__attribute__nonnull__(pTHX_2);
diff --git a/t/op/gmagic.t b/t/op/gmagic.t
index 64e7a2a..8ab9be0 100644
--- a/t/op/gmagic.t
+++ b/t/op/gmagic.t
@@ -83,6 +83,11 @@ ok($wgot == 0, 'a plain *foo causes no set-magic');
       'mortal magic var is explicitly returned in autoviv context';
 
   $tied_to = tie $_{elem}, "Tie::Monitor";
+  () = ( (), sub { delete $_{elem} }->() )->[3];
+  expected_tie_calls $tied_to, 1, 0,
+     'mortal magic var is implicitly returned in autoviv context';
+
+  $tied_to = tie $_{elem}, "Tie::Monitor";
   my $rsub;
   $rsub = sub { if ($_[0]) { delete $_{elem} } else { &$rsub(1)->[3] } };
   &$rsub;
-- 
1.7.5.4

---
Flags:
    category=core
    severity=low
---
Site configuration information for perl 5.15.1:

Configured by gerard at Tue Aug 16 09:22:54 CEST 2011.

Summary of my perl5 (revision 5 version 15 subversion 1) configuration:
  Commit id: d95340a439bc5dc8cb5f3c0e96fabec2fa0d3281
  Platform:
    osname=linux, osvers=2.6.39-2-686-pae, archname=i686-linux-thread-multi
    uname='linux zeus 2.6.39-2-686-pae #1 smp tue jul 5 03:48:49 utc 2011 i686 gnulinux '
    config_args='-des -Dusethreads -Doptimize=-O0 -g3 -DDEBUGGING -Dusedevel -Dprefix=/home/gerard/perl/inst/blead-codegen'
    hint=recommended, useposix=true, d_sigaction=define
    useithreads=define, usemultiplicity=define
    useperlio=define, d_sfio=undef, uselargefiles=define, usesocks=undef
    use64bitint=undef, use64bitall=undef, uselongdouble=undef
    usemymalloc=n, bincompat5005=undef
  Compiler:
    cc='cc', ccflags ='-D_REENTRANT -D_GNU_SOURCE -DDEBUGGING -fno-strict-aliasing -pipe -fstack-protector -I/usr/local/include -D_LARGEFILE_SOURCE -D_FILE_OFFSET_BITS=64',
    optimize='-O0 -g3',
    cppflags='-D_REENTRANT -D_GNU_SOURCE -DDEBUGGING -fno-strict-aliasing -pipe -fstack-protector -I/usr/local/include'
    ccversion='', gccversion='4.6.1', gccosandvers=''
    intsize=4, longsize=4, ptrsize=4, doublesize=8, byteorder=1234
    d_longlong=define, longlongsize=8, d_longdbl=define, longdblsize=12
    ivtype='long', ivsize=4, nvtype='double', nvsize=8, Off_t='off_t', lseeksize=8
    alignbytes=4, prototype=define
  Linker and Libraries:
    ld='cc', ldflags =' -fstack-protector -L/usr/local/lib'
    libpth=/usr/local/lib /lib /usr/lib /usr/lib/i386-linux-gnu /usr/lib64
    libs=-lnsl -ldb -ldl -lm -lcrypt -lutil -lpthread -lc
    perllibs=-lnsl -ldl -lm -lcrypt -lutil -lpthread -lc
    libc=, so=so, useshrplib=false, libperl=libperl.a
    gnulibc_version='2.13'
  Dynamic Linking:
    dlsrc=dl_dlopen.xs, dlext=so, d_dlsymun=undef, ccdlflags='-Wl,-E'
    cccdlflags='-fPIC', lddlflags='-shared -O0 -g3 -L/usr/local/lib -fstack-protector'

Locally applied patches:
    

---
@INC for perl 5.15.1:
    lib
    /home/gerard/perl/inst/blead-codegen/lib/site_perl/5.15.1/i686-linux-thread-multi
    /home/gerard/perl/inst/blead-codegen/lib/site_perl/5.15.1
    /home/gerard/perl/inst/blead-codegen/lib/5.15.1/i686-linux-thread-multi
    /home/gerard/perl/inst/blead-codegen/lib/5.15.1
    /home/gerard/perl/inst/blead-codegen/lib/site_perl
    .

---
Environment for perl 5.15.1:
    HOME=/home/gerard
    LANG=en_US.UTF-8
    LANGUAGE (unset)
    LD_LIBRARY_PATH (unset)
    LOGDIR (unset)
    PATH=/home/gerard/bin:/usr/local/bin:/usr/bin:/bin:/usr/games
    PERL_BADLANG (unset)
    SHELL=/bin/bash


Thread Next


nntp.perl.org: Perl Programming lists via nntp and http.
Comments to Ask Bjørn Hansen at ask@perl.org | Group listing | About