/* 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
|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
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
#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)
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
Perl_sv_compile_2op
Perl_getcwd_sv
Perl_sv_dec
+Perl_sv_dec_nomg
Perl_sv_dump
Perl_sv_derived_from
Perl_sv_does
Perl_sv_gets
Perl_sv_grow
Perl_sv_inc
+Perl_sv_inc_nomg
Perl_sv_insert
Perl_sv_insert_flags
Perl_sv_isa
}
+/* 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)
{
if (( (method + assignshift == off)
&& (assign || (method == inc_amg) || (method == dec_amg)))
|| force_cpy)
+ {
RvDEEPCP(left);
+ }
+
{
dSP;
BINOP myop;
package main;
$| = 1;
-use Test::More tests => 607;
+use Test::More tests => 1970;
$a = new Oscalar "087";
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
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))
SvFLAGS(TOPs) &= ~(SVp_NOK|SVp_POK);
}
else
- sv_dec(TOPs);
+ sv_dec_nomg(TOPs);
SvSETMAGIC(TOPs);
SETs(TARG);
return NORMAL;
#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;
}
SP--;
SETn( result );
- SvIV_please(svr);
+ SvIV_please_nomg(svr);
RETURN;
} else {
register unsigned int highbit = 8 * sizeof(UV);
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)
#ifdef PERL_PRESERVE_IVUV
if (is_int)
- SvIV_please(svr);
+ SvIV_please_nomg(svr);
#endif
RETURN;
}
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);
} /* 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;
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
#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);
} /* 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)
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;
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) {
}
}
else {
- dright = SvNV(svr);
+ dright = SvNV_nomg(svr);
right_neg = dright < 0;
if (right_neg)
dright = -dright;
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);
}
}
else {
- dleft = SvNV(svl);
+ dleft = SvNV_nomg(svl);
left_neg = dleft < 0;
if (left_neg)
dleft = -dleft;
}
}
}
- sp--;
+ sp -= 2;
if (use_double) {
NV dans;
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
}
}
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";
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)
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
/* 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);
}
#endif
{
- NV value = SvNV(svr);
+ NV value = SvNV_nomg(svr);
(void)POPs;
if (!useleft) {
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;
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;
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);
#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;
#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;
}
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);
#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;
#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;
}
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);
#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;
#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;
}
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);
#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;
#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;
}
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);
#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;
}
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));
#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);
}
#endif
{
- dPOPTOPnnrl;
+ dPOPTOPnnrl_nomg;
I32 value;
#ifdef Perl_isnan
break;
}
- tryAMAGICbinSET_var(amg_type,0);
+ tryAMAGICbin_MG(amg_type, AMGf_set);
{
dPOPTOPssrl;
const int cmp = (IN_LOCALE_RUNTIME
PP(pp_seq)
{
- dVAR; dSP; tryAMAGICbinSET(seq,0);
+ dVAR; dSP;
+ tryAMAGICbin_MG(seq_amg, AMGf_set);
{
dPOPTOPssrl;
SETs(boolSV(sv_eq(left, right)));
PP(pp_sne)
{
- dVAR; dSP; tryAMAGICbinSET(sne,0);
+ dVAR; dSP;
+ tryAMAGICbin_MG(sne_amg, AMGf_set);
{
dPOPTOPssrl;
SETs(boolSV(!sv_eq(left, right)));
PP(pp_scmp)
{
- dVAR; dSP; dTARGET; tryAMAGICbin(scmp,0);
+ dVAR; dSP; dTARGET;
+ tryAMAGICbin_MG(scmp_amg, 0);
{
dPOPTOPssrl;
const int cmp = (IN_LOCALE_RUNTIME
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);
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);
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:
#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);
(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. */
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;
}
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;
}
}
#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 */
/* 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 */
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... */
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;
}
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;
}
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;
}
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;
}
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;
}
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;
}
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;
}
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;
}
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)
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;
}
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();
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
}
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));
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);
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);
}
}
} else{
- const NV value = SvNV(sv);
+ const NV value = SvNV_nomg(sv);
if (value < 0.0)
SETn(-value);
else
#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
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)
#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))
#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); \
#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); \
#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
#define tryAMAGICregexp(rx) \
STMT_START { \
+ SvGETMAGIC(rx); \
if (SvROK(rx) && SvAMAGIC(rx)) { \
SV *sv = AMG_CALLun(rx, regexp); \
if (sv) { \
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;
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)) {
PP(pp_concat)
{
- dVAR; dSP; dATARGET; tryAMAGICbin(concat,opASSIGN);
+ dVAR; dSP; dATARGET; tryAMAGICbin_MG(concat_amg, AMGf_assign);
{
dPOPTOPssrl;
bool lbyte;
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 */
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)
}
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);
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) {
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);
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);
#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;
}
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,
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
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);
}
#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;
}
}
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
case OP_FTEWRITE: opchar = 'w'; break;
case OP_FTEEXEC: opchar = 'x'; break;
}
- tryAMAGICftest(opchar);
+ tryAMAGICftest_MG(opchar);
STACKED_FTEST_CHECK;
case OP_FTCTIME: opchar = 'C'; break;
case OP_FTATIME: opchar = 'A'; break;
}
- tryAMAGICftest(opchar);
+ tryAMAGICftest_MG(opchar);
STACKED_FTEST_CHECK;
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. */
dSP;
I32 result;
- tryAMAGICftest('l');
+ tryAMAGICftest_MG('l');
result = my_lstat();
SPAGAIN;
GV *gv;
SV *tmpsv = NULL;
- tryAMAGICftest('t');
+ tryAMAGICftest_MG('t');
STACKED_FTEST_CHECK;
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;
/* 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);
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 \
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); */
=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;
int flags;
if (!sv)
return;
- SvGETMAGIC(sv);
if (SvTHINKFIRST(sv)) {
if (SvIsCOW(sv))
sv_force_normal_flags(sv, 0);
=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
*/
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);
#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); \
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,
#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))
/* ----*/
projects / p5sagit/p5-mst-13.2.git / commitdiff