make overload respect get magic
authorDavid Mitchell <davem@iabyn.com>
Fri, 21 May 2010 13:18:21 +0000 (14:18 +0100)
committerDavid Mitchell <davem@iabyn.com>
Fri, 21 May 2010 13:18:21 +0000 (14:18 +0100)
In most places, ops checked their args for overload *before* doing
mg_get(). This meant that, among other issues, tied vars that
returned overloaded objects wouldn't trigger calling the
overloaded method.  (Actually, for tied and arrays and hashes, it
still often would since mg_get gets called beforehand in rvalue
context).

This patch does the following:

Makes sure get magic is called first.

Moves most of the overload code formerly included by macros at the
start of each pp function into the separate helper functions
Perl_try_amagic_bin, Perl_try_amagic_un, S_try_amagic_ftest,
with 3 new wrapper macros:
tryAMAGICbin_MG, tryAMAGICun_MG, tryAMAGICftest_MG.
This made the code 3800 bytes smaller.

Makes sure that FETCH is not called multiple times. Much of this
bit was helped by some earlier work from Father Chrysostomos.

Added new functions and macros sv_inc_nomg(), sv_dec_nomg(),
dPOPnv_nomg, dPOPXiirl_ul_nomg, dPOPTOPnnrl_nomg, dPOPTOPiirl_ul_nomg
dPOPTOPiirl_nomg, SvIV_please_nomg, SvNV_nomg (again, some of
these were based on Father Chrysostomos's work).

Fixed the list version of the repeat operator (x): it now only
calls overloaded methods for the scalar version:
    (1,2,$overloaded) x 10
no longer erroneously calls
    x_method($overloaded,10))

The only thing I haven't checked/fixed yet is overloading the
iterator operator, <>.

13 files changed:
embed.fnc
embed.h
global.sym
gv.c
lib/overload.t
pp.c
pp.h
pp_ctl.c
pp_hot.c
pp_sys.c
proto.h
sv.c
sv.h

index 87143f0..00629fd 100644 (file)
--- a/embed.fnc
+++ b/embed.fnc
@@ -172,6 +172,8 @@ END_EXTERN_C
 /* functions with flag 'n' should come before here */
 START_EXTERN_C
 #  include "pp_proto.h"
+XEop   |bool   |try_amagic_bin |int method|int flags
+XEop   |bool   |try_amagic_un  |int method|int flags
 Ap     |SV*    |amagic_call    |NN SV* left|NN SV* right|int method|int dir
 Ap     |int    |Gv_AMupdate    |NN HV* stash|bool destructing
 ApR    |CV*    |gv_handler     |NULLOK HV* stash|I32 id
@@ -1137,6 +1139,7 @@ Ap        |OP*    |sv_compile_2op |NN SV *sv|NN OP **startop \
                                |NN const char *code|NN PAD **padp
 Apd    |int    |getcwd_sv      |NN SV* sv
 Apd    |void   |sv_dec         |NULLOK SV *const sv
+Apd    |void   |sv_dec_nomg    |NULLOK SV *const sv
 Ap     |void   |sv_dump        |NN SV* sv
 ApdR   |bool   |sv_derived_from|NN SV* sv|NN const char *const name
 ApdR   |bool   |sv_does        |NN SV* sv|NN const char *const name
@@ -1150,6 +1153,7 @@ pd        |void   |sv_free_arenas
 Apd    |char*  |sv_gets        |NN SV *const sv|NN PerlIO *const fp|I32 append
 Apd    |char*  |sv_grow        |NN SV *const sv|STRLEN newlen
 Apd    |void   |sv_inc         |NULLOK SV *const sv
+Apd    |void   |sv_inc_nomg    |NULLOK SV *const sv
 Amdb   |void   |sv_insert      |NN SV *const bigstr|const STRLEN offset \
                                |const STRLEN len|NN const char *const little \
                                |const STRLEN littlelen
diff --git a/embed.h b/embed.h
index 76352c6..706bfe4 100644 (file)
--- a/embed.h
+++ b/embed.h
 #define sv_compile_2op         Perl_sv_compile_2op
 #define getcwd_sv              Perl_getcwd_sv
 #define sv_dec                 Perl_sv_dec
+#define sv_dec_nomg            Perl_sv_dec_nomg
 #define sv_dump                        Perl_sv_dump
 #define sv_derived_from                Perl_sv_derived_from
 #define sv_does                        Perl_sv_does
 #define sv_gets                        Perl_sv_gets
 #define sv_grow                        Perl_sv_grow
 #define sv_inc                 Perl_sv_inc
+#define sv_inc_nomg            Perl_sv_inc_nomg
 #define sv_insert_flags                Perl_sv_insert_flags
 #define sv_isa                 Perl_sv_isa
 #define sv_isobject            Perl_sv_isobject
 #if defined(PERL_CORE) || defined(PERL_EXT)
 #define regcurly               Perl_regcurly
 #endif
+#if defined(PERL_CORE) || defined(PERL_EXT)
+#endif
 #define amagic_call(a,b,c,d)   Perl_amagic_call(aTHX_ a,b,c,d)
 #define Gv_AMupdate(a,b)       Perl_Gv_AMupdate(aTHX_ a,b)
 #define gv_handler(a,b)                Perl_gv_handler(aTHX_ a,b)
 #define sv_compile_2op(a,b,c,d)        Perl_sv_compile_2op(aTHX_ a,b,c,d)
 #define getcwd_sv(a)           Perl_getcwd_sv(aTHX_ a)
 #define sv_dec(a)              Perl_sv_dec(aTHX_ a)
+#define sv_dec_nomg(a)         Perl_sv_dec_nomg(aTHX_ a)
 #define sv_dump(a)             Perl_sv_dump(aTHX_ a)
 #define sv_derived_from(a,b)   Perl_sv_derived_from(aTHX_ a,b)
 #define sv_does(a,b)           Perl_sv_does(aTHX_ a,b)
 #define sv_gets(a,b,c)         Perl_sv_gets(aTHX_ a,b,c)
 #define sv_grow(a,b)           Perl_sv_grow(aTHX_ a,b)
 #define sv_inc(a)              Perl_sv_inc(aTHX_ a)
+#define sv_inc_nomg(a)         Perl_sv_inc_nomg(aTHX_ a)
 #define sv_insert_flags(a,b,c,d,e,f)   Perl_sv_insert_flags(aTHX_ a,b,c,d,e,f)
 #define sv_isa(a,b)            Perl_sv_isa(aTHX_ a,b)
 #define sv_isobject(a)         Perl_sv_isobject(aTHX_ a)
index 116fb19..5cbfe3f 100644 (file)
@@ -32,6 +32,8 @@ Perl_mfree
 Perl_get_context
 Perl_set_context
 Perl_regcurly
+Perl_try_amagic_bin
+Perl_try_amagic_un
 Perl_amagic_call
 Perl_Gv_AMupdate
 Perl_gv_handler
@@ -549,6 +551,7 @@ Perl_sv_collxfrm
 Perl_sv_compile_2op
 Perl_getcwd_sv
 Perl_sv_dec
+Perl_sv_dec_nomg
 Perl_sv_dump
 Perl_sv_derived_from
 Perl_sv_does
@@ -558,6 +561,7 @@ Perl_sv_free2
 Perl_sv_gets
 Perl_sv_grow
 Perl_sv_inc
+Perl_sv_inc_nomg
 Perl_sv_insert
 Perl_sv_insert_flags
 Perl_sv_isa
diff --git a/gv.c b/gv.c
index 3412c9a..2d4cebc 100644 (file)
--- a/gv.c
+++ b/gv.c
@@ -1818,6 +1818,99 @@ Perl_gv_handler(pTHX_ HV *stash, I32 id)
 }
 
 
+/* Implement tryAMAGICun_MG macro.
+   Do get magic, then see if the stack arg is overloaded and if so call it.
+   Flags:
+       AMGf_set     return the arg using SETs rather than assigning to
+                    the targ
+       AMGf_numeric apply sv_2num to the stack arg.
+*/
+
+bool
+Perl_try_amagic_un(pTHX_ int method, int flags) {
+    dVAR;
+    dSP;
+    SV* tmpsv;
+    SV* const arg = TOPs;
+
+    SvGETMAGIC(arg);
+
+    if (SvAMAGIC(arg) && (tmpsv = AMG_CALLun_var(arg,method))) {
+       if (flags & AMGf_set) {
+           SETs(tmpsv);
+       }
+       else {
+           dTARGET;
+           if (SvPADMY(TARG)) {
+               sv_setsv(TARG, tmpsv);
+               SETTARG;
+           }
+           else
+               SETs(tmpsv);
+       }
+       PUTBACK;
+       return TRUE;
+    }
+
+    if ((flags & AMGf_numeric) && SvROK(arg))
+       *sp = sv_2num(arg);
+    return FALSE;
+}
+
+
+/* Implement tryAMAGICbin_MG macro.
+   Do get magic, then see if the two stack args are overloaded and if so
+   call it.
+   Flags:
+       AMGf_set     return the arg using SETs rather than assigning to
+                    the targ
+       AMGf_assign  op may be called as mutator (eg +=)
+       AMGf_numeric apply sv_2num to the stack arg.
+*/
+
+bool
+Perl_try_amagic_bin(pTHX_ int method, int flags) {
+    dVAR;
+    dSP;
+    SV* const left = TOPm1s;
+    SV* const right = TOPs;
+
+    SvGETMAGIC(left);
+    if (left != right)
+       SvGETMAGIC(right);
+
+    if (SvAMAGIC(left) || SvAMAGIC(right)) {
+       SV * const tmpsv = amagic_call(left, right, method,
+                   ((flags & AMGf_assign) && opASSIGN ? AMGf_assign: 0));
+       if (tmpsv) {
+           if (flags & AMGf_set) {
+               (void)POPs;
+               SETs(tmpsv);
+           }
+           else {
+               dATARGET;
+               (void)POPs;
+               if (opASSIGN || SvPADMY(TARG)) {
+                   sv_setsv(TARG, tmpsv);
+                   SETTARG;
+               }
+               else
+                   SETs(tmpsv);
+           }
+           PUTBACK;
+           return TRUE;
+       }
+    }
+    if (flags & AMGf_numeric) {
+       if (SvROK(left))
+           *(sp-1) = sv_2num(left);
+       if (SvROK(right))
+           *sp     = sv_2num(right);
+    }
+    return FALSE;
+}
+
+
 SV*
 Perl_amagic_call(pTHX_ SV *left, SV *right, int method, int flags)
 {
@@ -2120,7 +2213,10 @@ Perl_amagic_call(pTHX_ SV *left, SV *right, int method, int flags)
   if (( (method + assignshift == off)
        && (assign || (method == inc_amg) || (method == dec_amg)))
       || force_cpy)
+  {
     RvDEEPCP(left);
+  }
+
   {
     dSP;
     BINOP myop;
index 734e8b1..2b28c5a 100644 (file)
@@ -47,7 +47,7 @@ sub numify { 0 + "${$_[0]}" } # Not needed, additional overhead
 package main;
 
 $| = 1;
-use Test::More tests => 607;
+use Test::More tests => 1970;
 
 
 $a = new Oscalar "087";
@@ -1590,4 +1590,243 @@ foreach my $op (qw(<=> == != < <= > >=)) {
     is($y, $o, "copy constructor falls back to assignment (preinc)");
 }
 
+# only scalar 'x' should currently overload
+
+{
+    package REPEAT;
+
+    my ($x,$n, $nm);
+
+    use overload
+       'x'        => sub { $x++; 1 },
+       '0+'       => sub { $n++; 1 },
+       'nomethod' => sub { $nm++; 1 },
+       'fallback' => 0,
+    ;
+
+    my $s = bless {};
+
+    package main;
+
+    my @a;
+    my $count = 3;
+
+    ($x,$n,$nm) = (0,0,0);
+    @a = ((1,2,$s) x $count);
+    is("$x-$n-$nm", "0-0-0", 'repeat 1');
+
+    ($x,$n,$nm) = (0,0,0);
+    @a = ((1,$s,3) x $count);
+    is("$x-$n-$nm", "0-0-0", 'repeat 2');
+
+    ($x,$n,$nm) = (0,0,0);
+    @a = ((1,2,3) x $s);
+    is("$x-$n-$nm", "0-1-0", 'repeat 3');
+}
+
+
+
+# RT #57012: magic items need to have mg_get() called before testing for
+# overload. Lack of this means that overloaded values returned by eg a
+# tied array didn't call overload methods.
+# We test here both a tied array and scalar, since the implementation of
+# tied  arrays (and hashes) is such that in rvalue context, mg_get is
+# called prior to executing the op, while it isn't for a tied scalar.
+
+{
+
+    my @terms;
+    my %subs;
+    my $funcs;
+    my $use_int;
+
+    BEGIN {
+       # A note on what methods to expect to be called, and
+       # how many times FETCH/STORE is called:
+       #
+       # Mutating ops (+=, ++ etc) trigger a copy ('='), since
+       # the code can't distingish between something that's been copied:
+       #    $a = foo->new(0); $b = $a; refcnt($$b) == 2
+       # and overloaded objects stored in ties which will have extra
+       # refcounts due to the tied_obj magic and entries on the tmps
+       # stack when returning from FETCH etc. So we always copy.
+
+       # This accounts for a '=', and an extra STORE.
+       # We also have a FETCH returning the final value from the eval,
+       # plus a FETCH in the overload subs themselves: ($_[0][0])
+       # triggers one. However, tied agregates have a mechanism to prevent
+       # multiple fetches between STOREs, which means that the tied
+       # hash skips doing a FETCH during '='.
+
+       for (qw(+ - * / % ** << >> x . & | ^)) {
+           my $e = "%s $_= 3";
+           $subs{"$_="} = $e;
+           # ARRAY  FETCH: initial,        sub+=, eval-return,
+           # SCALAR FETCH: initial, sub=,  sub+=, eval-return,
+           # STORE:        copy, mutator
+           push @terms, [ 18, $e, "$_=", '(=)', 3, 4, 2 ];
+           $e = "%s $_ 3";
+           $subs{$_} = $e;
+           # ARRAY  FETCH: initial
+           # SCALAR FETCH: initial eval-return,
+           push @terms, [ 18, $e, $_, '', 1, 2, 0 ];
+       }
+       for (qw(++ --)) {
+           my $pre  = "$_%s";
+           my $post = "%s$_";
+           $subs{$_} = $pre;
+           push @terms,
+               # ARRAY  FETCH: initial,        sub+=, eval-return,
+               # SCALAR FETCH: initial, sub=,  sub+=, eval-return,
+               # STORE:        copy, mutator
+               [ 18, $pre,  $_, '(=)("")', 3, 4, 2 ],
+               # ARRAY  FETCH: initial,        sub+=
+               # SCALAR FETCH: initial, sub=,  sub+=
+               # STORE:        copy, mutator
+               [ 18, $post, $_, '(=)("")', 2, 3, 2 ];
+       }
+
+       # For the non-mutator ops, we have a initial FETCH,
+       # an extra FETCH within the sub itself for the scalar option,
+       # and no STOREs
+
+       for (qw(< <= >  >= == != lt le gt ge eq ne <=> cmp)) {
+           my $e = "%s $_ 3";
+           $subs{$_} = $e;
+           push @terms, [ 3, $e, $_, '', 1, 2, 0 ];
+       }
+       for (qw(atan2)) {
+           my $e = "$_ %s, 3";
+           $subs{$_} = $e;
+           push @terms, [ 18, $e, $_, '', 1, 2, 0 ];
+       }
+       for (qw(cos sin exp abs log sqrt int ! ~)) {
+           my $e = "$_(%s)";
+           $subs{$_} = $e;
+           push @terms, [ 1.23, $e, $_, '', 1, 2, 0 ];
+       }
+       for (qw(-)) {
+           my $e = "$_(%s)";
+           $subs{neg} = $e;
+           push @terms, [ 18, $e, 'neg', '', 1, 2, 0 ];
+       }
+       my $e = '(%s) ? 1 : 0';
+       $subs{bool} = $e;
+       push @terms, [ 18, $e, 'bool', '', 1, 2, 0 ];
+
+       # note: this is testing unary qr, not binary =~
+       $subs{qr} = '(%s)';
+       push @terms, [ qr/abc/, '"abc" =~ (%s)', 'qr', '', 1, 2, 0 ];
+
+       $e = '"abc" ~~ (%s)';
+       $subs{'~~'} = $e;
+       push @terms, [ "abc", $e, '~~', '', 1, 1, 0 ];
+
+       $subs{'-X'} = 'do { my $f = (%s);'
+                   . '$_[1] eq "r" ? (-r ($f)) :'
+                   . '$_[1] eq "e" ? (-e ($f)) :'
+                   . '$_[1] eq "f" ? (-f ($f)) :'
+                   . '$_[1] eq "l" ? (-l ($f)) :'
+                   . '$_[1] eq "t" ? (-t ($f)) :'
+                   . '$_[1] eq "T" ? (-T ($f)) : 0;}';
+       # Note - we don't care what these filetests return, as
+       # long as the tied and untied versions return the same value.
+       # The flags below are chosen to test all uses of tryAMAGICftest_MG
+       for (qw(r e f l t T)) {
+           push @terms, [ 'TEST', "-$_ (%s)", '-X', '', 1, 2, 0 ];
+       }
+
+       $subs{'${}'} = '%s';
+       push @terms, [ do {my $s=99; \$s}, '${%s}', '${}', '', 1, 2, 0 ];
+
+       # we skip testing '@{}' here because too much of this test
+       # framework involves array deredfences!
+
+       $subs{'%{}'} = '%s';
+       push @terms, [ {qw(a 1 b 2 c 3)}, 'join "", sort keys %%{%s}', '%{}',
+               '', 1, 2, 0 ];
+
+       $subs{'&{}'} = '%s';
+       push @terms, [ sub {99}, '&{%s}', '&{}', '', 1, 2, 0 ];
+
+       our $RT57012A = 88;
+       our $RT57012B;
+       $subs{'*{}'} = '%s';
+       push @terms, [ \*RT57012A, '*RT57012B = *{%s}; our $RT57012B',
+               '*{}', '', 1, 2, 0 ];
+
+       # XXX TODO: '<>'
+
+       for my $sub (keys %subs) {
+           my $term = $subs{$sub};
+           my $t = sprintf $term, '$_[0][0]';
+           $subs{$sub} = eval
+               "sub { \$funcs .= '($sub)'; my \$r; if (\$use_int) {"
+               . "use integer; \$r = ($t) } else { \$r = ($t) } \$r }";
+           die $@ if $@;
+       }
+    }
+
+    my $fetches;
+    my $stores;
+
+    package RT57012_OV;
+
+    my $other;
+    use overload
+       %subs,
+       "="   => sub { $other .= '(=)';  bless [ $_[0][0] ] },
+       '0+'  => sub { $other .= '(0+)'; 0 + $_[0][0] },
+       '""'  => sub { $other .= '("")'; "$_[0][0]"   },
+       ;
+
+    package RT57012_TIE_S;
+
+    my $tie_val;
+    sub TIESCALAR { bless [ bless [ $tie_val ], 'RT57012_OV' ] }
+    sub FETCH     { $fetches++; $_[0][0] }
+    sub STORE     { $stores++;  $_[0][0] = $_[1] }
+
+    package RT57012_TIE_A;
+
+    sub TIEARRAY  { bless [] }
+    sub FETCH     { $fetches++; $_[0][0] }
+    sub STORE     { $stores++;  $_[0][$_[1]] = $_[2] }
+
+    package main;
+
+    for my $term (@terms) {
+       my ($val, $sub_term, $exp_funcs, $exp_side,
+           $exp_fetch_a, $exp_fetch_s, $exp_store) = @$term;
+
+       $tie_val = $val;
+       for my $int ('', 'use integer; ') {
+           $use_int = ($int ne '');
+           for my $var ('$ta[0]', '$ts') {
+               my $exp_fetch = ($var eq '$ts') ? $exp_fetch_s : $exp_fetch_a;
+               tie my $ts, 'RT57012_TIE_S';
+               tie my @ta, 'RT57012_TIE_A';
+               $ta[0] = bless [ $val ], 'RT57012_OV';
+               my $x = $val;
+               my $tied_term  = $int . sprintf $sub_term, $var;
+               my $plain_term = $int . sprintf $sub_term, '$x';
+
+               $other = ''; $funcs = '';
+
+               $fetches = 0;
+               $stores = 0;
+               my $res = eval $tied_term;
+               $res = "$res";
+               my $exp = eval $plain_term;
+               $exp = "$exp";
+               is ($res, $exp, "tied '$tied_term' return value");
+               is ($funcs, "($exp_funcs)", "tied '$tied_term' methods called");
+               is ($other, $exp_side, "tied '$tied_term' side effects called");
+               is ($fetches, $exp_fetch, "tied '$tied_term' FETCH count");
+               is ($stores, $exp_store, "tied '$tied_term' STORE count");
+           }
+       }
+    }
+}
+
 # EOF
diff --git a/pp.c b/pp.c
index e998e21..b346026 100644 (file)
--- a/pp.c
+++ b/pp.c
@@ -911,7 +911,7 @@ PP(pp_postinc)
        SvFLAGS(TOPs) &= ~(SVp_NOK|SVp_POK);
     }
     else
-       sv_inc(TOPs);
+       sv_inc_nomg(TOPs);
     SvSETMAGIC(TOPs);
     /* special case for undef: see thread at 2003-03/msg00536.html in archive */
     if (!SvOK(TARG))
@@ -933,7 +933,7 @@ PP(pp_postdec)
        SvFLAGS(TOPs) &= ~(SVp_NOK|SVp_POK);
     }
     else
-       sv_dec(TOPs);
+       sv_dec_nomg(TOPs);
     SvSETMAGIC(TOPs);
     SETs(TARG);
     return NORMAL;
@@ -947,17 +947,17 @@ PP(pp_pow)
 #ifdef PERL_PRESERVE_IVUV
     bool is_int = 0;
 #endif
-    tryAMAGICbin(pow,opASSIGN);
-    svl = sv_2num(TOPm1s);
-    svr = sv_2num(TOPs);
+    tryAMAGICbin_MG(pow_amg, AMGf_assign|AMGf_numeric);
+    svr = TOPs;
+    svl = TOPm1s;
 #ifdef PERL_PRESERVE_IVUV
     /* For integer to integer power, we do the calculation by hand wherever
        we're sure it is safe; otherwise we call pow() and try to convert to
        integer afterwards. */
     {
-       SvIV_please(svr);
+       SvIV_please_nomg(svr);
        if (SvIOK(svr)) {
-           SvIV_please(svl);
+           SvIV_please_nomg(svl);
            if (SvIOK(svl)) {
                UV power;
                bool baseuok;
@@ -1013,7 +1013,7 @@ PP(pp_pow)
                    }
                     SP--;
                     SETn( result );
-                    SvIV_please(svr);
+                    SvIV_please_nomg(svr);
                     RETURN;
                } else {
                    register unsigned int highbit = 8 * sizeof(UV);
@@ -1062,8 +1062,8 @@ PP(pp_pow)
   float_it:
 #endif    
     {
-       NV right = SvNV(svr);
-       NV left  = SvNV(svl);
+       NV right = SvNV_nomg(svr);
+       NV left  = SvNV_nomg(svl);
        (void)POPs;
 
 #if defined(USE_LONG_DOUBLE) && defined(HAS_AIX_POWL_NEG_BASE_BUG)
@@ -1108,7 +1108,7 @@ PP(pp_pow)
 
 #ifdef PERL_PRESERVE_IVUV
        if (is_int)
-           SvIV_please(svr);
+           SvIV_please_nomg(svr);
 #endif
        RETURN;
     }
@@ -1117,17 +1117,17 @@ PP(pp_pow)
 PP(pp_multiply)
 {
     dVAR; dSP; dATARGET; SV *svl, *svr;
-    tryAMAGICbin(mult,opASSIGN);
-    svl = sv_2num(TOPm1s);
-    svr = sv_2num(TOPs);
+    tryAMAGICbin_MG(mult_amg, AMGf_assign|AMGf_numeric);
+    svr = TOPs;
+    svl = TOPm1s;
 #ifdef PERL_PRESERVE_IVUV
-    SvIV_please(svr);
+    SvIV_please_nomg(svr);
     if (SvIOK(svr)) {
        /* Unless the left argument is integer in range we are going to have to
           use NV maths. Hence only attempt to coerce the right argument if
           we know the left is integer.  */
        /* Left operand is defined, so is it IV? */
-       SvIV_please(svl);
+       SvIV_please_nomg(svl);
        if (SvIOK(svl)) {
            bool auvok = SvUOK(svl);
            bool buvok = SvUOK(svr);
@@ -1230,8 +1230,8 @@ PP(pp_multiply)
     } /* SvIOK(svr) */
 #endif
     {
-      NV right = SvNV(svr);
-      NV left  = SvNV(svl);
+      NV right = SvNV_nomg(svr);
+      NV left  = SvNV_nomg(svl);
       (void)POPs;
       SETn( left * right );
       RETURN;
@@ -1241,9 +1241,9 @@ PP(pp_multiply)
 PP(pp_divide)
 {
     dVAR; dSP; dATARGET; SV *svl, *svr;
-    tryAMAGICbin(div,opASSIGN);
-    svl = sv_2num(TOPm1s);
-    svr = sv_2num(TOPs);
+    tryAMAGICbin_MG(div_amg, AMGf_assign|AMGf_numeric);
+    svr = TOPs;
+    svl = TOPm1s;
     /* Only try to do UV divide first
        if ((SLOPPYDIVIDE is true) or
            (PERL_PRESERVE_IVUV is true and one or both SV is a UV too large
@@ -1266,9 +1266,9 @@ PP(pp_divide)
 #endif
 
 #ifdef PERL_TRY_UV_DIVIDE
-    SvIV_please(svr);
+    SvIV_please_nomg(svr);
     if (SvIOK(svr)) {
-        SvIV_please(svl);
+        SvIV_please_nomg(svl);
         if (SvIOK(svl)) {
             bool left_non_neg = SvUOK(svl);
             bool right_non_neg = SvUOK(svr);
@@ -1348,8 +1348,8 @@ PP(pp_divide)
     } /* right wasn't SvIOK */
 #endif /* PERL_TRY_UV_DIVIDE */
     {
-       NV right = SvNV(svr);
-       NV left  = SvNV(svl);
+       NV right = SvNV_nomg(svr);
+       NV left  = SvNV_nomg(svl);
        (void)POPs;(void)POPs;
 #if defined(NAN_COMPARE_BROKEN) && defined(Perl_isnan)
        if (! Perl_isnan(right) && right == 0.0)
@@ -1364,7 +1364,8 @@ PP(pp_divide)
 
 PP(pp_modulo)
 {
-    dVAR; dSP; dATARGET; tryAMAGICbin(modulo,opASSIGN);
+    dVAR; dSP; dATARGET;
+    tryAMAGICbin_MG(modulo_amg, AMGf_assign|AMGf_numeric);
     {
        UV left  = 0;
        UV right = 0;
@@ -1374,9 +1375,9 @@ PP(pp_modulo)
        bool dright_valid = FALSE;
        NV dright = 0.0;
        NV dleft  = 0.0;
-        SV * svl;
-        SV * const svr = sv_2num(TOPs);
-        SvIV_please(svr);
+       SV * const svr = TOPs;
+       SV * const svl = TOPm1s;
+       SvIV_please_nomg(svr);
         if (SvIOK(svr)) {
             right_neg = !SvUOK(svr);
             if (!right_neg) {
@@ -1392,7 +1393,7 @@ PP(pp_modulo)
             }
         }
         else {
-           dright = SvNV(svr);
+           dright = SvNV_nomg(svr);
            right_neg = dright < 0;
            if (right_neg)
                dright = -dright;
@@ -1403,13 +1404,11 @@ PP(pp_modulo)
                 use_double = TRUE;
             }
        }
-       sp--;
 
         /* At this point use_double is only true if right is out of range for
            a UV.  In range NV has been rounded down to nearest UV and
            use_double false.  */
-        svl = sv_2num(TOPs);
-        SvIV_please(svl);
+        SvIV_please_nomg(svl);
        if (!use_double && SvIOK(svl)) {
             if (SvIOK(svl)) {
                 left_neg = !SvUOK(svl);
@@ -1427,7 +1426,7 @@ PP(pp_modulo)
             }
         }
        else {
-           dleft = SvNV(svl);
+           dleft = SvNV_nomg(svl);
            left_neg = dleft < 0;
            if (left_neg)
                dleft = -dleft;
@@ -1455,7 +1454,7 @@ PP(pp_modulo)
                 }
             }
         }
-       sp--;
+       sp -= 2;
        if (use_double) {
            NV dans;
 
@@ -1496,20 +1495,29 @@ PP(pp_modulo)
 
 PP(pp_repeat)
 {
-  dVAR; dSP; dATARGET; tryAMAGICbin(repeat,opASSIGN);
-  {
+    dVAR; dSP; dATARGET;
     register IV count;
-    dPOPss;
-    SvGETMAGIC(sv);
+    SV *sv;
+
+    if (GIMME == G_ARRAY && PL_op->op_private & OPpREPEAT_DOLIST) {
+       /* TODO: think of some way of doing list-repeat overloading ??? */
+       sv = POPs;
+       SvGETMAGIC(sv);
+    }
+    else {
+       tryAMAGICbin_MG(repeat_amg, AMGf_assign);
+       sv = POPs;
+    }
+
     if (SvIOKp(sv)) {
         if (SvUOK(sv)) {
-             const UV uv = SvUV(sv);
+             const UV uv = SvUV_nomg(sv);
              if (uv > IV_MAX)
                   count = IV_MAX; /* The best we can do? */
              else
                   count = uv;
         } else {
-             const IV iv = SvIV(sv);
+             const IV iv = SvIV_nomg(sv);
              if (iv < 0)
                   count = 0;
              else
@@ -1517,14 +1525,15 @@ PP(pp_repeat)
         }
     }
     else if (SvNOKp(sv)) {
-        const NV nv = SvNV(sv);
+        const NV nv = SvNV_nomg(sv);
         if (nv < 0.0)
              count = 0;
         else
              count = (IV)nv;
     }
     else
-        count = SvIV(sv);
+        count = SvIV_nomg(sv);
+
     if (GIMME == G_ARRAY && PL_op->op_private & OPpREPEAT_DOLIST) {
        dMARK;
        static const char oom_list_extend[] = "Out of memory during list extend";
@@ -1582,8 +1591,9 @@ PP(pp_repeat)
        static const char oom_string_extend[] =
          "Out of memory during string extend";
 
-       SvSetSV(TARG, tmpstr);
-       SvPV_force(TARG, len);
+       if (TARG != tmpstr)
+           sv_setsv_nomg(TARG, tmpstr);
+       SvPV_force_nomg(TARG, len);
        isutf = DO_UTF8(TARG);
        if (count != 1) {
            if (count < 1)
@@ -1616,20 +1626,19 @@ PP(pp_repeat)
        PUSHTARG;
     }
     RETURN;
-  }
 }
 
 PP(pp_subtract)
 {
     dVAR; dSP; dATARGET; bool useleft; SV *svl, *svr;
-    tryAMAGICbin(subtr,opASSIGN);
-    svl = sv_2num(TOPm1s);
-    svr = sv_2num(TOPs);
+    tryAMAGICbin_MG(subtr_amg, AMGf_assign|AMGf_numeric);
+    svr = TOPs;
+    svl = TOPm1s;
     useleft = USE_LEFT(svl);
 #ifdef PERL_PRESERVE_IVUV
     /* See comments in pp_add (in pp_hot.c) about Overflow, and how
        "bad things" happen if you rely on signed integers wrapping.  */
-    SvIV_please(svr);
+    SvIV_please_nomg(svr);
     if (SvIOK(svr)) {
        /* Unless the left argument is integer in range we are going to have to
           use NV maths. Hence only attempt to coerce the right argument if
@@ -1644,7 +1653,7 @@ PP(pp_subtract)
            /* left operand is undef, treat as zero.  */
        } else {
            /* Left operand is defined, so is it IV? */
-           SvIV_please(svl);
+           SvIV_please_nomg(svl);
            if (SvIOK(svl)) {
                if ((auvok = SvUOK(svl)))
                    auv = SvUVX(svl);
@@ -1727,7 +1736,7 @@ PP(pp_subtract)
     }
 #endif
     {
-       NV value = SvNV(svr);
+       NV value = SvNV_nomg(svr);
        (void)POPs;
 
        if (!useleft) {
@@ -1735,22 +1744,25 @@ PP(pp_subtract)
            SETn(-value);
            RETURN;
        }
-       SETn( SvNV(svl) - value );
+       SETn( SvNV_nomg(svl) - value );
        RETURN;
     }
 }
 
 PP(pp_left_shift)
 {
-    dVAR; dSP; dATARGET; tryAMAGICbin(lshift,opASSIGN);
+    dVAR; dSP; dATARGET; SV *svl, *svr;
+    tryAMAGICbin_MG(lshift_amg, AMGf_assign);
+    svr = POPs;
+    svl = TOPs;
     {
-      const IV shift = POPi;
+      const IV shift = SvIV_nomg(svr);
       if (PL_op->op_private & HINT_INTEGER) {
-       const IV i = TOPi;
+       const IV i = SvIV_nomg(svl);
        SETi(i << shift);
       }
       else {
-       const UV u = TOPu;
+       const UV u = SvUV_nomg(svl);
        SETu(u << shift);
       }
       RETURN;
@@ -1759,15 +1771,18 @@ PP(pp_left_shift)
 
 PP(pp_right_shift)
 {
-    dVAR; dSP; dATARGET; tryAMAGICbin(rshift,opASSIGN);
+    dVAR; dSP; dATARGET; SV *svl, *svr;
+    tryAMAGICbin_MG(rshift_amg, AMGf_assign);
+    svr = POPs;
+    svl = TOPs;
     {
-      const IV shift = POPi;
+      const IV shift = SvIV_nomg(svr);
       if (PL_op->op_private & HINT_INTEGER) {
-       const IV i = TOPi;
+       const IV i = SvIV_nomg(svl);
        SETi(i >> shift);
       }
       else {
-       const UV u = TOPu;
+       const UV u = SvUV_nomg(svl);
        SETu(u >> shift);
       }
       RETURN;
@@ -1776,11 +1791,12 @@ PP(pp_right_shift)
 
 PP(pp_lt)
 {
-    dVAR; dSP; tryAMAGICbinSET(lt,0);
+    dVAR; dSP;
+    tryAMAGICbin_MG(lt_amg, AMGf_set);
 #ifdef PERL_PRESERVE_IVUV
-    SvIV_please(TOPs);
+    SvIV_please_nomg(TOPs);
     if (SvIOK(TOPs)) {
-       SvIV_please(TOPm1s);
+       SvIV_please_nomg(TOPm1s);
        if (SvIOK(TOPm1s)) {
            bool auvok = SvUOK(TOPm1s);
            bool buvok = SvUOK(TOPs);
@@ -1836,7 +1852,7 @@ PP(pp_lt)
 #ifdef PERL_PRESERVE_IVUV
     else
 #endif
-    if (SvROK(TOPs) && !SvAMAGIC(TOPs) && SvROK(TOPm1s) && !SvAMAGIC(TOPm1s)) {
+    if (SvROK(TOPs) && SvROK(TOPm1s)) {
        SP--;
        SETs(boolSV(SvRV(TOPs) < SvRV(TOPp1s)));
        RETURN;
@@ -1844,13 +1860,13 @@ PP(pp_lt)
 #endif
     {
 #if defined(NAN_COMPARE_BROKEN) && defined(Perl_isnan)
-      dPOPTOPnnrl;
+      dPOPTOPnnrl_nomg;
       if (Perl_isnan(left) || Perl_isnan(right))
          RETSETNO;
       SETs(boolSV(left < right));
 #else
-      dPOPnv;
-      SETs(boolSV(TOPn < value));
+      dPOPnv_nomg;
+      SETs(boolSV(SvNV_nomg(TOPs) < value));
 #endif
       RETURN;
     }
@@ -1858,11 +1874,12 @@ PP(pp_lt)
 
 PP(pp_gt)
 {
-    dVAR; dSP; tryAMAGICbinSET(gt,0);
+    dVAR; dSP;
+    tryAMAGICbin_MG(gt_amg, AMGf_set);
 #ifdef PERL_PRESERVE_IVUV
-    SvIV_please(TOPs);
+    SvIV_please_nomg(TOPs);
     if (SvIOK(TOPs)) {
-       SvIV_please(TOPm1s);
+       SvIV_please_nomg(TOPm1s);
        if (SvIOK(TOPm1s)) {
            bool auvok = SvUOK(TOPm1s);
            bool buvok = SvUOK(TOPs);
@@ -1919,7 +1936,7 @@ PP(pp_gt)
 #ifdef PERL_PRESERVE_IVUV
     else
 #endif
-    if (SvROK(TOPs) && !SvAMAGIC(TOPs) && SvROK(TOPm1s) && !SvAMAGIC(TOPm1s)) {
+    if (SvROK(TOPs) && SvROK(TOPm1s)) {
         SP--;
         SETs(boolSV(SvRV(TOPs) > SvRV(TOPp1s)));
         RETURN;
@@ -1927,13 +1944,13 @@ PP(pp_gt)
 #endif
     {
 #if defined(NAN_COMPARE_BROKEN) && defined(Perl_isnan)
-      dPOPTOPnnrl;
+      dPOPTOPnnrl_nomg;
       if (Perl_isnan(left) || Perl_isnan(right))
          RETSETNO;
       SETs(boolSV(left > right));
 #else
-      dPOPnv;
-      SETs(boolSV(TOPn > value));
+      dPOPnv_nomg;
+      SETs(boolSV(SvNV_nomg(TOPs) > value));
 #endif
       RETURN;
     }
@@ -1941,11 +1958,12 @@ PP(pp_gt)
 
 PP(pp_le)
 {
-    dVAR; dSP; tryAMAGICbinSET(le,0);
+    dVAR; dSP;
+    tryAMAGICbin_MG(le_amg, AMGf_set);
 #ifdef PERL_PRESERVE_IVUV
-    SvIV_please(TOPs);
+    SvIV_please_nomg(TOPs);
     if (SvIOK(TOPs)) {
-       SvIV_please(TOPm1s);
+       SvIV_please_nomg(TOPm1s);
        if (SvIOK(TOPm1s)) {
            bool auvok = SvUOK(TOPm1s);
            bool buvok = SvUOK(TOPs);
@@ -2002,7 +2020,7 @@ PP(pp_le)
 #ifdef PERL_PRESERVE_IVUV
     else
 #endif
-    if (SvROK(TOPs) && !SvAMAGIC(TOPs) && SvROK(TOPm1s) && !SvAMAGIC(TOPm1s)) {
+    if (SvROK(TOPs) && SvROK(TOPm1s)) {
         SP--;
         SETs(boolSV(SvRV(TOPs) <= SvRV(TOPp1s)));
         RETURN;
@@ -2010,13 +2028,13 @@ PP(pp_le)
 #endif
     {
 #if defined(NAN_COMPARE_BROKEN) && defined(Perl_isnan)
-      dPOPTOPnnrl;
+      dPOPTOPnnrl_nomg;
       if (Perl_isnan(left) || Perl_isnan(right))
          RETSETNO;
       SETs(boolSV(left <= right));
 #else
-      dPOPnv;
-      SETs(boolSV(TOPn <= value));
+      dPOPnv_nomg;
+      SETs(boolSV(SvNV_nomg(TOPs) <= value));
 #endif
       RETURN;
     }
@@ -2024,11 +2042,12 @@ PP(pp_le)
 
 PP(pp_ge)
 {
-    dVAR; dSP; tryAMAGICbinSET(ge,0);
+    dVAR; dSP;
+    tryAMAGICbin_MG(ge_amg,AMGf_set);
 #ifdef PERL_PRESERVE_IVUV
-    SvIV_please(TOPs);
+    SvIV_please_nomg(TOPs);
     if (SvIOK(TOPs)) {
-       SvIV_please(TOPm1s);
+       SvIV_please_nomg(TOPm1s);
        if (SvIOK(TOPm1s)) {
            bool auvok = SvUOK(TOPm1s);
            bool buvok = SvUOK(TOPs);
@@ -2085,7 +2104,7 @@ PP(pp_ge)
 #ifdef PERL_PRESERVE_IVUV
     else
 #endif
-    if (SvROK(TOPs) && !SvAMAGIC(TOPs) && SvROK(TOPm1s) && !SvAMAGIC(TOPm1s)) {
+    if (SvROK(TOPs) && SvROK(TOPm1s)) {
         SP--;
         SETs(boolSV(SvRV(TOPs) >= SvRV(TOPp1s)));
         RETURN;
@@ -2093,13 +2112,13 @@ PP(pp_ge)
 #endif
     {
 #if defined(NAN_COMPARE_BROKEN) && defined(Perl_isnan)
-      dPOPTOPnnrl;
+      dPOPTOPnnrl_nomg;
       if (Perl_isnan(left) || Perl_isnan(right))
          RETSETNO;
       SETs(boolSV(left >= right));
 #else
-      dPOPnv;
-      SETs(boolSV(TOPn >= value));
+      dPOPnv_nomg;
+      SETs(boolSV(SvNV_nomg(TOPs) >= value));
 #endif
       RETURN;
     }
@@ -2107,18 +2126,19 @@ PP(pp_ge)
 
 PP(pp_ne)
 {
-    dVAR; dSP; tryAMAGICbinSET(ne,0);
+    dVAR; dSP;
+    tryAMAGICbin_MG(ne_amg,AMGf_set);
 #ifndef NV_PRESERVES_UV
-    if (SvROK(TOPs) && !SvAMAGIC(TOPs) && SvROK(TOPm1s) && !SvAMAGIC(TOPm1s)) {
+    if (SvROK(TOPs) && SvROK(TOPm1s)) {
         SP--;
        SETs(boolSV(SvRV(TOPs) != SvRV(TOPp1s)));
        RETURN;
     }
 #endif
 #ifdef PERL_PRESERVE_IVUV
-    SvIV_please(TOPs);
+    SvIV_please_nomg(TOPs);
     if (SvIOK(TOPs)) {
-       SvIV_please(TOPm1s);
+       SvIV_please_nomg(TOPm1s);
        if (SvIOK(TOPm1s)) {
            const bool auvok = SvUOK(TOPm1s);
            const bool buvok = SvUOK(TOPs);
@@ -2169,13 +2189,13 @@ PP(pp_ne)
 #endif
     {
 #if defined(NAN_COMPARE_BROKEN) && defined(Perl_isnan)
-      dPOPTOPnnrl;
+      dPOPTOPnnrl_nomg;
       if (Perl_isnan(left) || Perl_isnan(right))
          RETSETYES;
       SETs(boolSV(left != right));
 #else
-      dPOPnv;
-      SETs(boolSV(TOPn != value));
+      dPOPnv_nomg;
+      SETs(boolSV(SvNV_nomg(TOPs) != value));
 #endif
       RETURN;
     }
@@ -2183,9 +2203,10 @@ PP(pp_ne)
 
 PP(pp_ncmp)
 {
-    dVAR; dSP; dTARGET; tryAMAGICbin(ncmp,0);
+    dVAR; dSP; dTARGET;
+    tryAMAGICbin_MG(ncmp_amg, 0);
 #ifndef NV_PRESERVES_UV
-    if (SvROK(TOPs) && !SvAMAGIC(TOPs) && SvROK(TOPm1s) && !SvAMAGIC(TOPm1s)) {
+    if (SvROK(TOPs) && SvROK(TOPm1s) ) {
        const UV right = PTR2UV(SvRV(POPs));
        const UV left = PTR2UV(SvRV(TOPs));
        SETi((left > right) - (left < right));
@@ -2194,9 +2215,9 @@ PP(pp_ncmp)
 #endif
 #ifdef PERL_PRESERVE_IVUV
     /* Fortunately it seems NaN isn't IOK */
-    SvIV_please(TOPs);
+    SvIV_please_nomg(TOPs);
     if (SvIOK(TOPs)) {
-       SvIV_please(TOPm1s);
+       SvIV_please_nomg(TOPm1s);
        if (SvIOK(TOPm1s)) {
            const bool leftuvok = SvUOK(TOPm1s);
            const bool rightuvok = SvUOK(TOPs);
@@ -2259,7 +2280,7 @@ PP(pp_ncmp)
     }
 #endif
     {
-      dPOPTOPnnrl;
+      dPOPTOPnnrl_nomg;
       I32 value;
 
 #ifdef Perl_isnan
@@ -2312,7 +2333,7 @@ PP(pp_sle)
        break;
     }
 
-    tryAMAGICbinSET_var(amg_type,0);
+    tryAMAGICbin_MG(amg_type, AMGf_set);
     {
       dPOPTOPssrl;
       const int cmp = (IN_LOCALE_RUNTIME
@@ -2325,7 +2346,8 @@ PP(pp_sle)
 
 PP(pp_seq)
 {
-    dVAR; dSP; tryAMAGICbinSET(seq,0);
+    dVAR; dSP;
+    tryAMAGICbin_MG(seq_amg, AMGf_set);
     {
       dPOPTOPssrl;
       SETs(boolSV(sv_eq(left, right)));
@@ -2335,7 +2357,8 @@ PP(pp_seq)
 
 PP(pp_sne)
 {
-    dVAR; dSP; tryAMAGICbinSET(sne,0);
+    dVAR; dSP;
+    tryAMAGICbin_MG(sne_amg, AMGf_set);
     {
       dPOPTOPssrl;
       SETs(boolSV(!sv_eq(left, right)));
@@ -2345,7 +2368,8 @@ PP(pp_sne)
 
 PP(pp_scmp)
 {
-    dVAR; dSP; dTARGET;  tryAMAGICbin(scmp,0);
+    dVAR; dSP; dTARGET;
+    tryAMAGICbin_MG(scmp_amg, 0);
     {
       dPOPTOPssrl;
       const int cmp = (IN_LOCALE_RUNTIME
@@ -2358,11 +2382,10 @@ PP(pp_scmp)
 
 PP(pp_bit_and)
 {
-    dVAR; dSP; dATARGET; tryAMAGICbin(band,opASSIGN);
+    dVAR; dSP; dATARGET;
+    tryAMAGICbin_MG(band_amg, AMGf_assign);
     {
       dPOPTOPssrl;
-      SvGETMAGIC(left);
-      SvGETMAGIC(right);
       if (SvNIOKp(left) || SvNIOKp(right)) {
        if (PL_op->op_private & HINT_INTEGER) {
          const IV i = SvIV_nomg(left) & SvIV_nomg(right);
@@ -2386,11 +2409,9 @@ PP(pp_bit_or)
     dVAR; dSP; dATARGET;
     const int op_type = PL_op->op_type;
 
-    tryAMAGICbin_var((op_type == OP_BIT_OR ? bor_amg : bxor_amg), opASSIGN);
+    tryAMAGICbin_MG((op_type == OP_BIT_OR ? bor_amg : bxor_amg), AMGf_assign);
     {
       dPOPTOPssrl;
-      SvGETMAGIC(left);
-      SvGETMAGIC(right);
       if (SvNIOKp(left) || SvNIOKp(right)) {
        if (PL_op->op_private & HINT_INTEGER) {
          const IV l = (USE_LEFT(left) ? SvIV_nomg(left) : 0);
@@ -2415,11 +2436,11 @@ PP(pp_bit_or)
 
 PP(pp_negate)
 {
-    dVAR; dSP; dTARGET; tryAMAGICun(neg);
+    dVAR; dSP; dTARGET;
+    tryAMAGICun_MG(neg_amg, AMGf_numeric);
     {
-       SV * const sv = sv_2num(TOPs);
+       SV * const sv = TOPs;
        const int flags = SvFLAGS(sv);
-       SvGETMAGIC(sv);
        if ((flags & SVf_IOK) || ((flags & (SVp_IOK | SVp_NOK)) == SVp_IOK)) {
            /* It's publicly an integer, or privately an integer-not-float */
        oops_its_an_int:
@@ -2446,56 +2467,57 @@ PP(pp_negate)
 #endif
        }
        if (SvNIOKp(sv))
-           SETn(-SvNV(sv));
+           SETn(-SvNV_nomg(sv));
        else if (SvPOKp(sv)) {
            STRLEN len;
-           const char * const s = SvPV_const(sv, len);
+           const char * const s = SvPV_nomg_const(sv, len);
            if (isIDFIRST(*s)) {
                sv_setpvs(TARG, "-");
                sv_catsv(TARG, sv);
            }
            else if (*s == '+' || *s == '-') {
-               sv_setsv(TARG, sv);
-               *SvPV_force(TARG, len) = *s == '-' ? '+' : '-';
+               sv_setsv_nomg(TARG, sv);
+               *SvPV_force_nomg(TARG, len) = *s == '-' ? '+' : '-';
            }
            else if (DO_UTF8(sv)) {
-               SvIV_please(sv);
+               SvIV_please_nomg(sv);
                if (SvIOK(sv))
                    goto oops_its_an_int;
                if (SvNOK(sv))
-                   sv_setnv(TARG, -SvNV(sv));
+                   sv_setnv(TARG, -SvNV_nomg(sv));
                else {
                    sv_setpvs(TARG, "-");
                    sv_catsv(TARG, sv);
                }
            }
            else {
-               SvIV_please(sv);
+               SvIV_please_nomg(sv);
                if (SvIOK(sv))
                  goto oops_its_an_int;
-               sv_setnv(TARG, -SvNV(sv));
+               sv_setnv(TARG, -SvNV_nomg(sv));
            }
            SETTARG;
        }
        else
-           SETn(-SvNV(sv));
+           SETn(-SvNV_nomg(sv));
     }
     RETURN;
 }
 
 PP(pp_not)
 {
-    dVAR; dSP; tryAMAGICunSET_var(not_amg);
+    dVAR; dSP;
+    tryAMAGICun_MG(not_amg, AMGf_set);
     *PL_stack_sp = boolSV(!SvTRUE(*PL_stack_sp));
     return NORMAL;
 }
 
 PP(pp_complement)
 {
-    dVAR; dSP; dTARGET; tryAMAGICun_var(compl_amg);
+    dVAR; dSP; dTARGET;
+    tryAMAGICun_MG(compl_amg, 0);
     {
       dTOPss;
-      SvGETMAGIC(sv);
       if (SvNIOKp(sv)) {
        if (PL_op->op_private & HINT_INTEGER) {
          const IV i = ~SvIV_nomg(sv);
@@ -2513,7 +2535,7 @@ PP(pp_complement)
 
        (void)SvPV_nomg_const(sv,len); /* force check for uninit var */
        sv_setsv_nomg(TARG, sv);
-       tmps = (U8*)SvPV_force(TARG, len);
+       tmps = (U8*)SvPV_force_nomg(TARG, len);
        anum = len;
        if (SvUTF8(TARG)) {
          /* Calculate exact length, let's not estimate. */
@@ -2594,9 +2616,10 @@ PP(pp_complement)
 
 PP(pp_i_multiply)
 {
-    dVAR; dSP; dATARGET; tryAMAGICbin(mult,opASSIGN);
+    dVAR; dSP; dATARGET;
+    tryAMAGICbin_MG(mult_amg, AMGf_assign);
     {
-      dPOPTOPiirl;
+      dPOPTOPiirl_nomg;
       SETi( left * right );
       RETURN;
     }
@@ -2605,19 +2628,21 @@ PP(pp_i_multiply)
 PP(pp_i_divide)
 {
     IV num;
-    dVAR; dSP; dATARGET; tryAMAGICbin(div,opASSIGN);
+    dVAR; dSP; dATARGET;
+    tryAMAGICbin_MG(div_amg, AMGf_assign);
     {
-      dPOPiv;
+      dPOPTOPssrl;
+      IV value = SvIV_nomg(right);
       if (value == 0)
          DIE(aTHX_ "Illegal division by zero");
-      num = POPi;
+      num = SvIV_nomg(left);
 
       /* avoid FPE_INTOVF on some platforms when num is IV_MIN */
       if (value == -1)
           value = - num;
       else
           value = num / value;
-      PUSHi( value );
+      SETi(value);
       RETURN;
     }
 }
@@ -2630,9 +2655,10 @@ PP(pp_i_modulo)
 #endif
 {
      /* This is the vanilla old i_modulo. */
-     dVAR; dSP; dATARGET; tryAMAGICbin(modulo,opASSIGN);
+     dVAR; dSP; dATARGET;
+     tryAMAGICbin_MG(modulo_amg, AMGf_assign);
      {
-         dPOPTOPiirl;
+         dPOPTOPiirl_nomg;
          if (!right)
               DIE(aTHX_ "Illegal modulus zero");
          /* avoid FPE_INTOVF on some platforms when left is IV_MIN */
@@ -2652,9 +2678,10 @@ PP(pp_i_modulo_1)
      /* This is the i_modulo with the workaround for the _moddi3 bug
       * in (at least) glibc 2.2.5 (the PERL_ABS() the workaround).
       * See below for pp_i_modulo. */
-     dVAR; dSP; dATARGET; tryAMAGICbin(modulo,opASSIGN);
+     dVAR; dSP; dATARGET;
+     tryAMAGICbin_MG(modulo_amg, AMGf_assign);
      {
-         dPOPTOPiirl;
+         dPOPTOPiirl_nomg;
          if (!right)
               DIE(aTHX_ "Illegal modulus zero");
          /* avoid FPE_INTOVF on some platforms when left is IV_MIN */
@@ -2668,9 +2695,10 @@ PP(pp_i_modulo_1)
 
 PP(pp_i_modulo)
 {
-     dVAR; dSP; dATARGET; tryAMAGICbin(modulo,opASSIGN);
+     dVAR; dSP; dATARGET;
+     tryAMAGICbin_MG(modulo_amg, AMGf_assign);
      {
-         dPOPTOPiirl;
+         dPOPTOPiirl_nomg;
          if (!right)
               DIE(aTHX_ "Illegal modulus zero");
          /* The assumption is to use hereafter the old vanilla version... */
@@ -2711,9 +2739,10 @@ PP(pp_i_modulo)
 
 PP(pp_i_add)
 {
-    dVAR; dSP; dATARGET; tryAMAGICbin(add,opASSIGN);
+    dVAR; dSP; dATARGET;
+    tryAMAGICbin_MG(add_amg, AMGf_assign);
     {
-      dPOPTOPiirl_ul;
+      dPOPTOPiirl_ul_nomg;
       SETi( left + right );
       RETURN;
     }
@@ -2721,9 +2750,10 @@ PP(pp_i_add)
 
 PP(pp_i_subtract)
 {
-    dVAR; dSP; dATARGET; tryAMAGICbin(subtr,opASSIGN);
+    dVAR; dSP; dATARGET;
+    tryAMAGICbin_MG(subtr_amg, AMGf_assign);
     {
-      dPOPTOPiirl_ul;
+      dPOPTOPiirl_ul_nomg;
       SETi( left - right );
       RETURN;
     }
@@ -2731,9 +2761,10 @@ PP(pp_i_subtract)
 
 PP(pp_i_lt)
 {
-    dVAR; dSP; tryAMAGICbinSET(lt,0);
+    dVAR; dSP;
+    tryAMAGICbin_MG(lt_amg, AMGf_set);
     {
-      dPOPTOPiirl;
+      dPOPTOPiirl_nomg;
       SETs(boolSV(left < right));
       RETURN;
     }
@@ -2741,9 +2772,10 @@ PP(pp_i_lt)
 
 PP(pp_i_gt)
 {
-    dVAR; dSP; tryAMAGICbinSET(gt,0);
+    dVAR; dSP;
+    tryAMAGICbin_MG(gt_amg, AMGf_set);
     {
-      dPOPTOPiirl;
+      dPOPTOPiirl_nomg;
       SETs(boolSV(left > right));
       RETURN;
     }
@@ -2751,9 +2783,10 @@ PP(pp_i_gt)
 
 PP(pp_i_le)
 {
-    dVAR; dSP; tryAMAGICbinSET(le,0);
+    dVAR; dSP;
+    tryAMAGICbin_MG(le_amg, AMGf_set);
     {
-      dPOPTOPiirl;
+      dPOPTOPiirl_nomg;
       SETs(boolSV(left <= right));
       RETURN;
     }
@@ -2761,9 +2794,10 @@ PP(pp_i_le)
 
 PP(pp_i_ge)
 {
-    dVAR; dSP; tryAMAGICbinSET(ge,0);
+    dVAR; dSP;
+    tryAMAGICbin_MG(ge_amg, AMGf_set);
     {
-      dPOPTOPiirl;
+      dPOPTOPiirl_nomg;
       SETs(boolSV(left >= right));
       RETURN;
     }
@@ -2771,9 +2805,10 @@ PP(pp_i_ge)
 
 PP(pp_i_eq)
 {
-    dVAR; dSP; tryAMAGICbinSET(eq,0);
+    dVAR; dSP;
+    tryAMAGICbin_MG(eq_amg, AMGf_set);
     {
-      dPOPTOPiirl;
+      dPOPTOPiirl_nomg;
       SETs(boolSV(left == right));
       RETURN;
     }
@@ -2781,9 +2816,10 @@ PP(pp_i_eq)
 
 PP(pp_i_ne)
 {
-    dVAR; dSP; tryAMAGICbinSET(ne,0);
+    dVAR; dSP;
+    tryAMAGICbin_MG(ne_amg, AMGf_set);
     {
-      dPOPTOPiirl;
+      dPOPTOPiirl_nomg;
       SETs(boolSV(left != right));
       RETURN;
     }
@@ -2791,9 +2827,10 @@ PP(pp_i_ne)
 
 PP(pp_i_ncmp)
 {
-    dVAR; dSP; dTARGET; tryAMAGICbin(ncmp,0);
+    dVAR; dSP; dTARGET;
+    tryAMAGICbin_MG(ncmp_amg, 0);
     {
-      dPOPTOPiirl;
+      dPOPTOPiirl_nomg;
       I32 value;
 
       if (left > right)
@@ -2809,18 +2846,24 @@ PP(pp_i_ncmp)
 
 PP(pp_i_negate)
 {
-    dVAR; dSP; dTARGET; tryAMAGICun(neg);
-    SETi(-TOPi);
-    RETURN;
+    dVAR; dSP; dTARGET;
+    tryAMAGICun_MG(neg_amg, 0);
+    {
+       SV * const sv = TOPs;
+       IV const i = SvIV_nomg(sv);
+       SETi(-i);
+       RETURN;
+    }
 }
 
 /* High falutin' math. */
 
 PP(pp_atan2)
 {
-    dVAR; dSP; dTARGET; tryAMAGICbin(atan2,0);
+    dVAR; dSP; dTARGET;
+    tryAMAGICbin_MG(atan2_amg, 0);
     {
-      dPOPTOPnnrl;
+      dPOPTOPnnrl_nomg;
       SETn(Perl_atan2(left, right));
       RETURN;
     }
@@ -2855,9 +2898,11 @@ PP(pp_sin)
        break;
     }
 
-    tryAMAGICun_var(amg_type);
+
+    tryAMAGICun_MG(amg_type, 0);
     {
-      const NV value = POPn;
+      SV * const arg = POPs;
+      const NV value = SvNV_nomg(arg);
       if (neg_report) {
          if (op_type == OP_LOG ? (value <= 0.0) : (value < 0.0)) {
              SET_NUMERIC_STANDARD();
@@ -2915,10 +2960,11 @@ PP(pp_srand)
 
 PP(pp_int)
 {
-    dVAR; dSP; dTARGET; tryAMAGICun(int);
+    dVAR; dSP; dTARGET;
+    tryAMAGICun_MG(int_amg, AMGf_numeric);
     {
-      SV * const sv = sv_2num(TOPs);
-      const IV iv = SvIV(sv);
+      SV * const sv = TOPs;
+      const IV iv = SvIV_nomg(sv);
       /* XXX it's arguable that compiler casting to IV might be subtly
         different from modf (for numbers inside (IV_MIN,UV_MAX)) in which
         else preferring IV has introduced a subtle behaviour change bug. OTOH
@@ -2929,12 +2975,12 @@ PP(pp_int)
       }
       else if (SvIOK(sv)) {
        if (SvIsUV(sv))
-           SETu(SvUV(sv));
+           SETu(SvUV_nomg(sv));
        else
            SETi(iv);
       }
       else {
-         const NV value = SvNV(sv);
+         const NV value = SvNV_nomg(sv);
          if (value >= 0.0) {
              if (value < (NV)UV_MAX + 0.5) {
                  SETu(U_V(value));
@@ -2956,11 +3002,12 @@ PP(pp_int)
 
 PP(pp_abs)
 {
-    dVAR; dSP; dTARGET; tryAMAGICun(abs);
+    dVAR; dSP; dTARGET;
+    tryAMAGICun_MG(abs_amg, AMGf_numeric);
     {
-      SV * const sv = sv_2num(TOPs);
+      SV * const sv = TOPs;
       /* This will cache the NV value if string isn't actually integer  */
-      const IV iv = SvIV(sv);
+      const IV iv = SvIV_nomg(sv);
 
       if (!SvOK(sv)) {
         SETu(0);
@@ -2968,7 +3015,7 @@ PP(pp_abs)
       else if (SvIOK(sv)) {
        /* IVX is precise  */
        if (SvIsUV(sv)) {
-         SETu(SvUV(sv));       /* force it to be numeric only */
+         SETu(SvUV_nomg(sv));  /* force it to be numeric only */
        } else {
          if (iv >= 0) {
            SETi(iv);
@@ -2983,7 +3030,7 @@ PP(pp_abs)
          }
        }
       } else{
-       const NV value = SvNV(sv);
+       const NV value = SvNV_nomg(sv);
        if (value < 0.0)
          SETn(-value);
        else
diff --git a/pp.h b/pp.h
index a107dda..8cf208c 100644 (file)
--- a/pp.h
+++ b/pp.h
@@ -328,6 +328,7 @@ Does not use C<TARG>.  See also C<XPUSHu>, C<mPUSHu> and C<PUSHu>.
 #define dPOPss         SV *sv = POPs
 #define dTOPnv         NV value = TOPn
 #define dPOPnv         NV value = POPn
+#define dPOPnv_nomg    NV value = (sp--, SvNV_nomg(TOPp1s))
 #define dTOPiv         IV value = TOPi
 #define dPOPiv         IV value = POPi
 #define dTOPuv         UV value = TOPu
@@ -353,6 +354,10 @@ Does not use C<TARG>.  See also C<XPUSHu>, C<mPUSHu> and C<PUSHu>.
     IV right = POPi;                                   \
     SV *leftsv = CAT2(X,s);                            \
     IV left = USE_LEFT(leftsv) ? SvIV(leftsv) : 0
+#define dPOPXiirl_ul_nomg(X) \
+    IV right = POPi;                                   \
+    SV *leftsv = CAT2(X,s);                            \
+    IV left = USE_LEFT(leftsv) ? SvIV_nomg(leftsv) : 0
 
 #define dPOPPOPssrl    dPOPXssrl(POP)
 #define dPOPPOPnnrl    dPOPXnnrl(POP)
@@ -363,8 +368,13 @@ Does not use C<TARG>.  See also C<XPUSHu>, C<mPUSHu> and C<PUSHu>.
 #define dPOPTOPssrl    dPOPXssrl(TOP)
 #define dPOPTOPnnrl    dPOPXnnrl(TOP)
 #define dPOPTOPnnrl_ul dPOPXnnrl_ul(TOP)
+#define dPOPTOPnnrl_nomg \
+    NV right = SvNV_nomg(TOPs); NV left = (sp--, SvNV_nomg(TOPs))
 #define dPOPTOPiirl    dPOPXiirl(TOP)
 #define dPOPTOPiirl_ul dPOPXiirl_ul(TOP)
+#define dPOPTOPiirl_ul_nomg dPOPXiirl_ul_nomg(TOP)
+#define dPOPTOPiirl_nomg \
+    IV right = SvIV_nomg(TOPs); IV left = (sp--, SvIV_nomg(TOPs))
 
 #define RETPUSHYES     RETURNX(PUSHs(&PL_sv_yes))
 #define RETPUSHNO      RETURNX(PUSHs(&PL_sv_no))
@@ -398,6 +408,26 @@ Does not use C<TARG>.  See also C<XPUSHu>, C<mPUSHu> and C<PUSHu>.
 #define AMGf_noleft    2
 #define AMGf_assign    4
 #define AMGf_unary     8
+#define AMGf_numeric   0x10    /* for Perl_try_amagic_bin */
+#define AMGf_set       0x20    /* for Perl_try_amagic_bin */
+
+
+/* do SvGETMAGIC on the stack args before checking for overload */
+
+#define tryAMAGICun_MG(method, flags) STMT_START { \
+       if ( (SvFLAGS(TOPs) & (SVf_ROK|SVs_GMG)) \
+               && Perl_try_amagic_un(aTHX_ method, flags)) \
+           return NORMAL; \
+    } STMT_END
+#define tryAMAGICbin_MG(method, flags) STMT_START { \
+       if ( ((SvFLAGS(TOPm1s)|SvFLAGS(TOPs)) & (SVf_ROK|SVs_GMG)) \
+               && Perl_try_amagic_bin(aTHX_ method, flags)) \
+           return NORMAL; \
+    } STMT_END
+
+/* these  tryAMAGICun* tryAMAGICbin* macros are no longer used in core
+ * (except for tryAMAGICunDEREF*, tryAMAGICunTARGET),
+ * and are only here for backwards compatibility */
 
 #define tryAMAGICbinW_var(meth_enum,assign,set) STMT_START { \
            SV* const left = *(sp-1); \
@@ -472,9 +502,12 @@ Does not use C<TARG>.  See also C<XPUSHu>, C<mPUSHu> and C<PUSHu>.
 #define tryAMAGICunDEREF_var(meth_enum) \
        tryAMAGICunW_var(meth_enum,setAGAIN,0,(void)0)
 
+/* this macro is obsolete and is only here for backwards compatibility */
+
 #define tryAMAGICftest(chr)                            \
     STMT_START {                                       \
        assert(chr != '?');                             \
+       SvGETMAGIC(TOPs);                               \
        if ((PL_op->op_flags & OPf_KIDS)                \
                && SvAMAGIC(TOPs)) {                    \
            const char tmpchr = (chr);                  \
@@ -522,6 +555,7 @@ Does not use C<TARG>.  See also C<XPUSHu>, C<mPUSHu> and C<PUSHu>.
 #define RvDEEPCP(rv) STMT_START { SV* tmpRef=SvRV(rv); SV* rv_copy;     \
   if (SvREFCNT(tmpRef)>1 && (rv_copy = AMG_CALLun(rv,copy))) {          \
     SvRV_set(rv, rv_copy);                 \
+    SvSETMAGIC(rv);                        \
     SvREFCNT_dec(tmpRef);                   \
   } } STMT_END
 
index 05c5310..2408a7b 100644 (file)
--- a/pp_ctl.c
+++ b/pp_ctl.c
@@ -96,6 +96,7 @@ PP(pp_regcomp)
 
 #define tryAMAGICregexp(rx)                    \
     STMT_START {                               \
+       SvGETMAGIC(rx);                         \
        if (SvROK(rx) && SvAMAGIC(rx)) {        \
            SV *sv = AMG_CALLun(rx, regexp);    \
            if (sv) {                           \
@@ -4159,6 +4160,19 @@ S_do_smartmatch(pTHX_ HV *seen_this, HV *seen_other)
     SV *e = TOPs;      /* e is for 'expression' */
     SV *d = TOPm1s;    /* d is for 'default', as in PL_defgv */
 
+    /* Take care only to invoke mg_get() once for each argument.
+     * Currently we do this by copying the SV if it's magical. */
+    if (d) {
+       if (SvGMAGICAL(d))
+           d = sv_mortalcopy(d);
+    }
+    else
+       d = &PL_sv_undef;
+
+    assert(e);
+    if (SvGMAGICAL(e))
+       e = sv_mortalcopy(e);
+
     /* First of all, handle overload magic of the rightmost argument */
     if (SvAMAGIC(e)) {
        SV * tmpsv;
@@ -4177,18 +4191,6 @@ S_do_smartmatch(pTHX_ HV *seen_this, HV *seen_other)
 
     SP -= 2;   /* Pop the values */
 
-    /* Take care only to invoke mg_get() once for each argument. 
-     * Currently we do this by copying the SV if it's magical. */
-    if (d) {
-       if (SvGMAGICAL(d))
-           d = sv_mortalcopy(d);
-    }
-    else
-       d = &PL_sv_undef;
-
-    assert(e);
-    if (SvGMAGICAL(e))
-       e = sv_mortalcopy(e);
 
     /* ~~ undef */
     if (!SvOK(e)) {
index ab36593..52d0d8d 100644 (file)
--- a/pp_hot.c
+++ b/pp_hot.c
@@ -227,7 +227,7 @@ PP(pp_unstack)
 
 PP(pp_concat)
 {
-  dVAR; dSP; dATARGET; tryAMAGICbin(concat,opASSIGN);
+  dVAR; dSP; dATARGET; tryAMAGICbin_MG(concat_amg, AMGf_assign);
   {
     dPOPTOPssrl;
     bool lbyte;
@@ -236,9 +236,8 @@ PP(pp_concat)
     bool rbyte = FALSE;
     bool rcopied = FALSE;
 
-    if (TARG == right && right != left) {
-       /* mg_get(right) may happen here ... */
-       rpv = SvPV_const(right, rlen);
+    if (TARG == right && right != left) { /* $r = $l.$r */
+       rpv = SvPV_nomg_const(right, rlen);
        rbyte = !DO_UTF8(right);
        right = newSVpvn_flags(rpv, rlen, SVs_TEMP);
        rpv = SvPV_const(right, rlen);  /* no point setting UTF-8 here */
@@ -247,7 +246,7 @@ PP(pp_concat)
 
     if (TARG != left) {
         STRLEN llen;
-        const char* const lpv = SvPV_const(left, llen);        /* mg_get(left) may happen here */
+        const char* const lpv = SvPV_nomg_const(left, llen);
        lbyte = !DO_UTF8(left);
        sv_setpvn(TARG, lpv, llen);
        if (!lbyte)
@@ -257,7 +256,6 @@ PP(pp_concat)
     }
     else { /* TARG == left */
         STRLEN llen;
-       SvGETMAGIC(left);               /* or mg_get(left) may happen here */
        if (!SvOK(TARG)) {
            if (left == right && ckWARN(WARN_UNINITIALIZED))
                report_uninit(right);
@@ -269,9 +267,11 @@ PP(pp_concat)
            SvUTF8_off(TARG);
     }
 
-    /* or mg_get(right) may happen here */
     if (!rcopied) {
-       rpv = SvPV_const(right, rlen);
+       if (left == right)
+           /* $a.$a: do magic twice: tied might return different 2nd time */
+           SvGETMAGIC(right);
+       rpv = SvPV_nomg_const(right, rlen);
        rbyte = !DO_UTF8(right);
     }
     if (lbyte != rbyte) {
@@ -281,7 +281,7 @@ PP(pp_concat)
            if (!rcopied)
                right = newSVpvn_flags(rpv, rlen, SVs_TEMP);
            sv_utf8_upgrade_nomg(right);
-           rpv = SvPV_const(right, rlen);
+           rpv = SvPV_nomg_const(right, rlen);
        }
     }
     sv_catpvn_nomg(TARG, rpv, rlen);
@@ -329,21 +329,22 @@ PP(pp_readline)
 
 PP(pp_eq)
 {
-    dVAR; dSP; tryAMAGICbinSET(eq,0);
+    dVAR; dSP;
+    tryAMAGICbin_MG(eq_amg, AMGf_set);
 #ifndef NV_PRESERVES_UV
-    if (SvROK(TOPs) && !SvAMAGIC(TOPs) && SvROK(TOPm1s) && !SvAMAGIC(TOPm1s)) {
+    if (SvROK(TOPs) && SvROK(TOPm1s)) {
         SP--;
        SETs(boolSV(SvRV(TOPs) == SvRV(TOPp1s)));
        RETURN;
     }
 #endif
 #ifdef PERL_PRESERVE_IVUV
-    SvIV_please(TOPs);
+    SvIV_please_nomg(TOPs);
     if (SvIOK(TOPs)) {
        /* Unless the left argument is integer in range we are going
           to have to use NV maths. Hence only attempt to coerce the
           right argument if we know the left is integer.  */
-      SvIV_please(TOPm1s);
+      SvIV_please_nomg(TOPm1s);
        if (SvIOK(TOPm1s)) {
            const bool auvok = SvUOK(TOPm1s);
            const bool buvok = SvUOK(TOPs);
@@ -388,13 +389,13 @@ PP(pp_eq)
 #endif
     {
 #if defined(NAN_COMPARE_BROKEN) && defined(Perl_isnan)
-      dPOPTOPnnrl;
+      dPOPTOPnnrl_nomg;
       if (Perl_isnan(left) || Perl_isnan(right))
          RETSETNO;
       SETs(boolSV(left == right));
 #else
-      dPOPnv;
-      SETs(boolSV(TOPn == value));
+      dPOPnv_nomg;
+      SETs(boolSV(SvNV_nomg(TOPs) == value));
 #endif
       RETURN;
     }
@@ -491,9 +492,10 @@ PP(pp_defined)
 PP(pp_add)
 {
     dVAR; dSP; dATARGET; bool useleft; SV *svl, *svr;
-    tryAMAGICbin(add,opASSIGN);
-    svl = sv_2num(TOPm1s);
-    svr = sv_2num(TOPs);
+    tryAMAGICbin_MG(add_amg, AMGf_assign|AMGf_numeric);
+    svr = TOPs;
+    svl = TOPm1s;
+
     useleft = USE_LEFT(svl);
 #ifdef PERL_PRESERVE_IVUV
     /* We must see if we can perform the addition with integers if possible,
@@ -542,7 +544,8 @@ PP(pp_add)
        unsigned code below is actually shorter than the old code. :-)
     */
 
-    SvIV_please(svr);
+    SvIV_please_nomg(svr);
+
     if (SvIOK(svr)) {
        /* Unless the left argument is integer in range we are going to have to
           use NV maths. Hence only attempt to coerce the right argument if
@@ -559,7 +562,7 @@ PP(pp_add)
               lots of code to speed up what is probably a rarish case.  */
        } else {
            /* Left operand is defined, so is it IV? */
-           SvIV_please(svl);
+           SvIV_please_nomg(svl);
            if (SvIOK(svl)) {
                if ((auvok = SvUOK(svl)))
                    auv = SvUVX(svl);
@@ -642,14 +645,14 @@ PP(pp_add)
     }
 #endif
     {
-       NV value = SvNV(svr);
+       NV value = SvNV_nomg(svr);
        (void)POPs;
        if (!useleft) {
            /* left operand is undef, treat as zero. + 0.0 is identity. */
            SETn(value);
            RETURN;
        }
-       SETn( value + SvNV(svl) );
+       SETn( value + SvNV_nomg(svl) );
        RETURN;
     }
 }
index 1fe2ea9..59ec533 100644 (file)
--- a/pp_sys.c
+++ b/pp_sys.c
@@ -2950,6 +2950,53 @@ PP(pp_stat)
     RETURN;
 }
 
+#define tryAMAGICftest_MG(chr) STMT_START { \
+       if ( (SvFLAGS(TOPs) & (SVf_ROK|SVs_GMG)) \
+               && S_try_amagic_ftest(aTHX_ chr)) \
+           return NORMAL; \
+    } STMT_END
+
+STATIC bool
+S_try_amagic_ftest(pTHX_ char chr) {
+    dVAR;
+    dSP;
+    SV* const arg = TOPs;
+
+    assert(chr != '?');
+    SvGETMAGIC(arg);
+
+    if ((PL_op->op_flags & OPf_KIDS)
+           && SvAMAGIC(TOPs))
+    {
+       const char tmpchr = chr;
+       const OP *next;
+       SV * const tmpsv = amagic_call(arg,
+                               newSVpvn_flags(&tmpchr, 1, SVs_TEMP),
+                               ftest_amg, AMGf_unary);
+
+       if (!tmpsv)
+           return FALSE;
+
+       SPAGAIN;
+
+       next = PL_op->op_next;
+       if (next->op_type >= OP_FTRREAD &&
+           next->op_type <= OP_FTBINARY &&
+           next->op_private & OPpFT_STACKED
+       ) {
+           if (SvTRUE(tmpsv))
+               /* leave the object alone */
+               return TRUE;
+       }
+
+       SETs(tmpsv);
+       PUTBACK;
+       return TRUE;
+    }
+    return FALSE;
+}
+
+
 /* This macro is used by the stacked filetest operators :
  * if the previous filetest failed, short-circuit and pass its value.
  * Else, discard it from the stack and continue. --rgs
@@ -2992,7 +3039,7 @@ PP(pp_ftrread)
     case OP_FTEWRITE:  opchar = 'w'; break;
     case OP_FTEEXEC:   opchar = 'x'; break;
     }
-    tryAMAGICftest(opchar);
+    tryAMAGICftest_MG(opchar);
 
     STACKED_FTEST_CHECK;
 
@@ -3096,7 +3143,7 @@ PP(pp_ftis)
     case OP_FTCTIME:   opchar = 'C'; break;
     case OP_FTATIME:   opchar = 'A'; break;
     }
-    tryAMAGICftest(opchar);
+    tryAMAGICftest_MG(opchar);
 
     STACKED_FTEST_CHECK;
 
@@ -3153,7 +3200,7 @@ PP(pp_ftrowned)
     case OP_FTSGID:    opchar = 'g'; break;
     case OP_FTSVTX:    opchar = 'k'; break;
     }
-    tryAMAGICftest(opchar);
+    tryAMAGICftest_MG(opchar);
 
     /* I believe that all these three are likely to be defined on most every
        system these days.  */
@@ -3241,7 +3288,7 @@ PP(pp_ftlink)
     dSP;
     I32 result;
 
-    tryAMAGICftest('l');
+    tryAMAGICftest_MG('l');
     result = my_lstat();
     SPAGAIN;
 
@@ -3260,7 +3307,7 @@ PP(pp_fttty)
     GV *gv;
     SV *tmpsv = NULL;
 
-    tryAMAGICftest('t');
+    tryAMAGICftest_MG('t');
 
     STACKED_FTEST_CHECK;
 
@@ -3311,7 +3358,7 @@ PP(pp_fttext)
     GV *gv;
     PerlIO *fp;
 
-    tryAMAGICftest(PL_op->op_type == OP_FTTEXT ? 'T' : 'B');
+    tryAMAGICftest_MG(PL_op->op_type == OP_FTTEXT ? 'T' : 'B');
 
     STACKED_FTEST_CHECK;
 
diff --git a/proto.h b/proto.h
index 22aad52..fef2fcb 100644 (file)
--- a/proto.h
+++ b/proto.h
@@ -132,6 +132,8 @@ END_EXTERN_C
 /* functions with flag 'n' should come before here */
 START_EXTERN_C
 #  include "pp_proto.h"
+PERL_CALLCONV bool     Perl_try_amagic_bin(pTHX_ int method, int flags);
+PERL_CALLCONV bool     Perl_try_amagic_un(pTHX_ int method, int flags);
 PERL_CALLCONV SV*      Perl_amagic_call(pTHX_ SV* left, SV* right, int method, int dir)
                        __attribute__nonnull__(pTHX_1)
                        __attribute__nonnull__(pTHX_2);
@@ -3318,6 +3320,7 @@ PERL_CALLCONV int Perl_getcwd_sv(pTHX_ SV* sv)
        assert(sv)
 
 PERL_CALLCONV void     Perl_sv_dec(pTHX_ SV *const sv);
+PERL_CALLCONV void     Perl_sv_dec_nomg(pTHX_ SV *const sv);
 PERL_CALLCONV void     Perl_sv_dump(pTHX_ SV* sv)
                        __attribute__nonnull__(pTHX_1);
 #define PERL_ARGS_ASSERT_SV_DUMP       \
@@ -3357,6 +3360,7 @@ PERL_CALLCONV char*       Perl_sv_grow(pTHX_ SV *const sv, STRLEN newlen)
        assert(sv)
 
 PERL_CALLCONV void     Perl_sv_inc(pTHX_ SV *const sv);
+PERL_CALLCONV void     Perl_sv_inc_nomg(pTHX_ SV *const sv);
 /* PERL_CALLCONV void  Perl_sv_insert(pTHX_ SV *const bigstr, const STRLEN offset, const STRLEN len, const char *const little, const STRLEN littlelen)
                        __attribute__nonnull__(pTHX_1)
                        __attribute__nonnull__(pTHX_4); */
diff --git a/sv.c b/sv.c
index fd8a82a..6a0916f 100644 (file)
--- a/sv.c
+++ b/sv.c
@@ -7323,13 +7323,31 @@ return_string_or_null:
 =for apidoc sv_inc
 
 Auto-increment of the value in the SV, doing string to numeric conversion
-if necessary. Handles 'get' magic.
+if necessary. Handles 'get' magic and operator overloading.
 
 =cut
 */
 
 void
 Perl_sv_inc(pTHX_ register SV *const sv)
+{
+    if (!sv)
+       return;
+    SvGETMAGIC(sv);
+    sv_inc_nomg(sv);
+}
+
+/*
+=for apidoc sv_inc_nomg
+
+Auto-increment of the value in the SV, doing string to numeric conversion
+if necessary. Handles operator overloading. Skips handling 'get' magic.
+
+=cut
+*/
+
+void
+Perl_sv_inc_nomg(pTHX_ register SV *const sv)
 {
     dVAR;
     register char *d;
@@ -7337,7 +7355,6 @@ Perl_sv_inc(pTHX_ register SV *const sv)
 
     if (!sv)
        return;
-    SvGETMAGIC(sv);
     if (SvTHINKFIRST(sv)) {
        if (SvIsCOW(sv))
            sv_force_normal_flags(sv, 0);
@@ -7487,20 +7504,38 @@ Perl_sv_inc(pTHX_ register SV *const sv)
 =for apidoc sv_dec
 
 Auto-decrement of the value in the SV, doing string to numeric conversion
-if necessary. Handles 'get' magic.
+if necessary. Handles 'get' magic and operator overloading.
 
 =cut
 */
 
 void
 Perl_sv_dec(pTHX_ register SV *const sv)
+{
+    dVAR;
+    if (!sv)
+       return;
+    SvGETMAGIC(sv);
+    sv_dec_nomg(sv);
+}
+
+/*
+=for apidoc sv_dec_nomg
+
+Auto-decrement of the value in the SV, doing string to numeric conversion
+if necessary. Handles operator overloading. Skips handling 'get' magic.
+
+=cut
+*/
+
+void
+Perl_sv_dec_nomg(pTHX_ register SV *const sv)
 {
     dVAR;
     int flags;
 
     if (!sv)
        return;
-    SvGETMAGIC(sv);
     if (SvTHINKFIRST(sv)) {
        if (SvIsCOW(sv))
            sv_force_normal_flags(sv, 0);
diff --git a/sv.h b/sv.h
index 97a6c53..cc7edb9 100644 (file)
--- a/sv.h
+++ b/sv.h
@@ -1163,6 +1163,9 @@ the scalar's value cannot change unless written to.
 #define SvIV_please(sv) \
        STMT_START {if (!SvIOKp(sv) && (SvNOK(sv) || SvPOK(sv))) \
                (void) SvIV(sv); } STMT_END
+#define SvIV_please_nomg(sv) \
+       STMT_START {if (!SvIOKp(sv) && (SvNOK(sv) || SvPOK(sv))) \
+               (void) SvIV_nomg(sv); } STMT_END
 #define SvIV_set(sv, val) \
        STMT_START { assert(SvTYPE(sv) == SVt_IV || SvTYPE(sv) >= SVt_PVIV); \
                assert(SvTYPE(sv) != SVt_PVAV);         \
@@ -1419,6 +1422,9 @@ otherwise use the more efficient C<SvIV>.
 Coerce the given SV to a double and return it. See C<SvNVx> for a version
 which guarantees to evaluate sv only once.
 
+=for apidoc Am|NV|SvNV_nomg|SV* sv
+Like C<SvNV> but doesn't process magic.
+
 =for apidoc Am|NV|SvNVx|SV* sv
 Coerces the given SV to a double and returns it. Guarantees to evaluate
 C<sv> only once. Only use this if C<sv> is an expression with side effects,
@@ -1510,6 +1516,7 @@ Like sv_utf8_upgrade, but doesn't do magic on C<sv>
 
 #define SvIV_nomg(sv) (SvIOK(sv) ? SvIVX(sv) : sv_2iv_flags(sv, 0))
 #define SvUV_nomg(sv) (SvIOK(sv) ? SvUVX(sv) : sv_2uv_flags(sv, 0))
+#define SvNV_nomg(sv) (SvNOK(sv) ? SvNVX(sv) : sv_2nv_flags(sv, 0))
 
 /* ----*/