From 6f1401dc2acd2a2b85df22b0a74e5f7e6e0a33aa Mon Sep 17 00:00:00 2001 From: David Mitchell Date: Fri, 21 May 2010 14:18:21 +0100 Subject: [PATCH] make overload respect get magic 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, <>. --- embed.fnc | 4 + embed.h | 6 + global.sym | 4 + gv.c | 96 ++++++++++++++ lib/overload.t | 241 ++++++++++++++++++++++++++++++++++- pp.c | 395 ++++++++++++++++++++++++++++++++------------------------- pp.h | 34 +++++ pp_ctl.c | 26 ++-- pp_hot.c | 49 +++---- pp_sys.c | 59 ++++++++- proto.h | 4 + sv.c | 43 ++++++- sv.h | 7 + 13 files changed, 748 insertions(+), 220 deletions(-) diff --git a/embed.fnc b/embed.fnc index 87143f0..00629fdb 100644 --- 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 --- a/embed.h +++ b/embed.h @@ -952,6 +952,7 @@ #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 @@ -963,6 +964,7 @@ #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 @@ -2465,6 +2467,8 @@ #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) @@ -3365,6 +3369,7 @@ #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) @@ -3376,6 +3381,7 @@ #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) diff --git a/global.sym b/global.sym index 116fb19..5cbfe3f 100644 --- a/global.sym +++ b/global.sym @@ -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 --- 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; diff --git a/lib/overload.t b/lib/overload.t index 734e8b1..2b28c5a 100644 --- a/lib/overload.t +++ b/lib/overload.t @@ -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 --- 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 --- a/pp.h +++ b/pp.h @@ -328,6 +328,7 @@ Does not use C. See also C, C and C. #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. See also C, C and C. 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. See also C, C and C. #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. See also C, C and C. #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. See also C, C and C. #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. See also C, C and C. #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 diff --git a/pp_ctl.c b/pp_ctl.c index 05c5310..2408a7b 100644 --- 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)) { diff --git a/pp_hot.c b/pp_hot.c index ab36593..52d0d8d 100644 --- 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; } } diff --git a/pp_sys.c b/pp_sys.c index 1fe2ea9..59ec533 100644 --- 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 --- 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 --- a/sv.c +++ b/sv.c @@ -7323,7 +7323,7 @@ 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 */ @@ -7331,13 +7331,30 @@ if necessary. Handles 'get' magic. 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; int flags; if (!sv) return; - SvGETMAGIC(sv); if (SvTHINKFIRST(sv)) { if (SvIsCOW(sv)) sv_force_normal_flags(sv, 0); @@ -7487,7 +7504,7 @@ 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 */ @@ -7496,11 +7513,29 @@ 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 --- 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. Coerce the given SV to a double and return it. See C for a version which guarantees to evaluate sv only once. +=for apidoc Am|NV|SvNV_nomg|SV* sv +Like C 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 only once. Only use this if C is an expression with side effects, @@ -1510,6 +1516,7 @@ Like sv_utf8_upgrade, but doesn't do magic on C #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)) /* ----*/ -- 1.8.3.1