lib/open3.pl Open a three-ended pipe (uses IPC::Open3)
lib/open.pm Pragma to specify default I/O layers
lib/open.t See if the open pragma works
+lib/overload64.t See if operator overloading works with 64-bit ints
lib/overload.pm Module for overloading perl operators
lib/overload.t See if operator overloading works
lib/Package/Constants.pm Package::Constants
Apd |IV |sv_2iv_flags |NN SV* sv|I32 flags
Apd |SV* |sv_2mortal |NULLOK SV* sv
Apd |NV |sv_2nv |NN SV* sv
+pMd |SV* |sv_2num |NN SV* sv
Amb |char* |sv_2pv |NN SV* sv|NULLOK STRLEN* lp
Apd |char* |sv_2pv_flags |NN SV* sv|NULLOK STRLEN* lp|I32 flags
Apd |char* |sv_2pvutf8 |NN SV* sv|NULLOK STRLEN* lp
#define sv_2iv_flags Perl_sv_2iv_flags
#define sv_2mortal Perl_sv_2mortal
#define sv_2nv Perl_sv_2nv
+#ifdef PERL_CORE
+#define sv_2num Perl_sv_2num
+#endif
#define sv_2pv_flags Perl_sv_2pv_flags
#define sv_2pvutf8 Perl_sv_2pvutf8
#define sv_2pvbyte Perl_sv_2pvbyte
#define sv_2iv_flags(a,b) Perl_sv_2iv_flags(aTHX_ a,b)
#define sv_2mortal(a) Perl_sv_2mortal(aTHX_ a)
#define sv_2nv(a) Perl_sv_2nv(aTHX_ a)
+#ifdef PERL_CORE
+#define sv_2num(a) Perl_sv_2num(aTHX_ a)
+#endif
#define sv_2pv_flags(a,b,c) Perl_sv_2pv_flags(aTHX_ a,b,c)
#define sv_2pvutf8(a,b) Perl_sv_2pvutf8(aTHX_ a,b)
#define sv_2pvbyte(a,b) Perl_sv_2pvbyte(aTHX_ a,b)
package main;
$| = 1;
-use Test::More tests => 536;
+use Test::More tests => 556;
$a = new Oscalar "087";
package numify_other;
use overload "0+" => sub { $_[0][0]++; $_[0][1] = bless [], 'numify_int' };
package numify_by_fallback;
- use overload "-" => sub { 1 }, fallback => 1;
+ use overload fallback => 1;
package main;
my $o = bless [], 'numify_int';
my $m = bless $aref, 'numify_by_fallback';
is(int($m), $num_val, 'numifies to usual reference value');
+ is(abs($m), $num_val, 'numifies to usual reference value');
+ is(-$m, -$num_val, 'numifies to usual reference value');
+ is(0+$m, $num_val, 'numifies to usual reference value');
+ is($m+0, $num_val, 'numifies to usual reference value');
+ is($m+$m, 2*$num_val, 'numifies to usual reference value');
+ is(0-$m, -$num_val, 'numifies to usual reference value');
+ is(1*$m, $num_val, 'numifies to usual reference value');
+ is($m/1, $num_val, 'numifies to usual reference value');
+ is($m%100, $num_val%100, 'numifies to usual reference value');
+ is($m**1, $num_val, 'numifies to usual reference value');
+
+ is(abs($aref), $num_val, 'abs() of ref');
+ is(-$aref, -$num_val, 'negative of ref');
+ is(0+$aref, $num_val, 'ref addition');
+ is($aref+0, $num_val, 'ref addition');
+ is($aref+$aref, 2*$num_val, 'ref addition');
+ is(0-$aref, -$num_val, 'subtraction of ref');
+ is(1*$aref, $num_val, 'multiplicaton of ref');
+ is($aref/1, $num_val, 'division of ref');
+ is($aref%100, $num_val%100, 'modulo of ref');
+ is($aref**1, $num_val, 'exponentiation of ref');
}
+
+# EOF
--- /dev/null
+#!./perl
+
+BEGIN {
+ chdir 't' if -d 't';
+ @INC = '../lib';
+ require Config;
+ if ($Config::Config{'uvsize'} != 8) {
+ print "1..0 # Skip -- Perl configured with 32-bit ints\n";
+ exit 0;
+ }
+}
+
+$| = 1;
+use Test::More 'tests' => 100;
+
+
+my $ii = 36028797018963971; # 2^55 + 3
+
+
+### Tests with numerifying large positive int
+{ package Oobj;
+ use overload '0+' => sub { ${$_[0]} += 1; $ii },
+ 'fallback' => 1;
+}
+my $oo = bless(\do{my $x = 0}, 'Oobj');
+my $cnt = 1;
+
+is("$oo", "$ii", '0+ overload with stringification');
+is($$oo, $cnt++, 'overload called once');
+
+is($oo>>3, $ii>>3, '0+ overload with bit shift right');
+is($$oo, $cnt++, 'overload called once');
+
+is($oo<<2, $ii<<2, '0+ overload with bit shift left');
+is($$oo, $cnt++, 'overload called once');
+
+is($oo|0xFF00, $ii|0xFF00, '0+ overload with bitwise or');
+is($$oo, $cnt++, 'overload called once');
+
+is($oo&0xFF03, $ii&0xFF03, '0+ overload with bitwise and');
+is($$oo, $cnt++, 'overload called once');
+
+ok($oo == $ii, '0+ overload with equality');
+is($$oo, $cnt++, 'overload called once');
+
+is(int($oo), $ii, '0+ overload with int()');
+is($$oo, $cnt++, 'overload called once');
+
+is(abs($oo), $ii, '0+ overload with abs()');
+is($$oo, $cnt++, 'overload called once');
+
+is(-$oo, -$ii, '0+ overload with unary minus');
+is($$oo, $cnt++, 'overload called once');
+
+is(0+$oo, $ii, '0+ overload with addition');
+is($$oo, $cnt++, 'overload called once');
+is($oo+0, $ii, '0+ overload with addition');
+is($$oo, $cnt++, 'overload called once');
+is($oo+$oo, 2*$ii, '0+ overload with addition');
+$cnt++;
+is($$oo, $cnt++, 'overload called once');
+
+is(0-$oo, -$ii, '0+ overload with subtraction');
+is($$oo, $cnt++, 'overload called once');
+is($oo-99, $ii-99, '0+ overload with subtraction');
+is($$oo, $cnt++, 'overload called once');
+
+is(2*$oo, 2*$ii, '0+ overload with multiplication');
+is($$oo, $cnt++, 'overload called once');
+is($oo*3, 3*$ii, '0+ overload with multiplication');
+is($$oo, $cnt++, 'overload called once');
+
+is($oo/1, $ii, '0+ overload with division');
+is($$oo, $cnt++, 'overload called once');
+is($ii/$oo, 1, '0+ overload with division');
+is($$oo, $cnt++, 'overload called once');
+
+is($oo%100, $ii%100, '0+ overload with modulo');
+is($$oo, $cnt++, 'overload called once');
+is($ii%$oo, 0, '0+ overload with modulo');
+is($$oo, $cnt++, 'overload called once');
+
+is($oo**1, $ii, '0+ overload with exponentiation');
+is($$oo, $cnt++, 'overload called once');
+
+
+### Tests with numerifying large negative int
+{ package Oobj2;
+ use overload '0+' => sub { ${$_[0]} += 1; -$ii },
+ 'fallback' => 1;
+}
+$oo = bless(\do{my $x = 0}, 'Oobj2');
+$cnt = 1;
+
+is(int($oo), -$ii, '0+ overload with int()');
+is($$oo, $cnt++, 'overload called once');
+
+is(abs($oo), $ii, '0+ overload with abs()');
+is($$oo, $cnt++, 'overload called once');
+
+is(-$oo, $ii, '0+ overload with unary -');
+is($$oo, $cnt++, 'overload called once');
+
+is(0+$oo, -$ii, '0+ overload with addition');
+is($$oo, $cnt++, 'overload called once');
+is($oo+0, -$ii, '0+ overload with addition');
+is($$oo, $cnt++, 'overload called once');
+is($oo+$oo, -2*$ii, '0+ overload with addition');
+$cnt++;
+is($$oo, $cnt++, 'overload called once');
+
+is(0-$oo, $ii, '0+ overload with subtraction');
+is($$oo, $cnt++, 'overload called once');
+
+is(2*$oo, -2*$ii, '0+ overload with multiplication');
+is($$oo, $cnt++, 'overload called once');
+is($oo*3, -3*$ii, '0+ overload with multiplication');
+is($$oo, $cnt++, 'overload called once');
+
+is($oo/1, -$ii, '0+ overload with division');
+is($$oo, $cnt++, 'overload called once');
+is($ii/$oo, -1, '0+ overload with division');
+is($$oo, $cnt++, 'overload called once');
+
+is($oo%100, (-$ii)%100, '0+ overload with modulo');
+is($$oo, $cnt++, 'overload called once');
+is($ii%$oo, 0, '0+ overload with modulo');
+is($$oo, $cnt++, 'overload called once');
+
+is($oo**1, -$ii, '0+ overload with exponentiation');
+is($$oo, $cnt++, 'overload called once');
+
+### Tests with overloading but no fallback
+{ package Oobj3;
+ use overload
+ 'int' => sub { ${$_[0]} += 1; $ii },
+ 'abs' => sub { ${$_[0]} += 1; $ii },
+ 'neg' => sub { ${$_[0]} += 1; -$ii },
+ '+' => sub {
+ ${$_[0]} += 1;
+ my $res = (ref($_[0]) eq __PACKAGE__) ? $ii : $_[0];
+ $res += (ref($_[1]) eq __PACKAGE__) ? $ii : $_[1];
+ },
+ '-' => sub {
+ ${$_[0]} += 1;
+ my ($l, $r) = ($_[2]) ? (1, 0) : (0, 1);
+ my $res = (ref($_[$l]) eq __PACKAGE__) ? $ii : $_[$l];
+ $res -= (ref($_[$r]) eq __PACKAGE__) ? $ii : $_[$r];
+ },
+ '*' => sub {
+ ${$_[0]} += 1;
+ my $res = (ref($_[0]) eq __PACKAGE__) ? $ii : $_[0];
+ $res *= (ref($_[1]) eq __PACKAGE__) ? $ii : $_[1];
+ },
+ '/' => sub {
+ ${$_[0]} += 1;
+ my ($l, $r) = ($_[2]) ? (1, 0) : (0, 1);
+ my $res = (ref($_[$l]) eq __PACKAGE__) ? $ii+1 : $_[$l];
+ $res /= (ref($_[$r]) eq __PACKAGE__) ? $ii+1 : $_[$r];
+ },
+ '%' => sub {
+ ${$_[0]} += 1;
+ my ($l, $r) = ($_[2]) ? (1, 0) : (0, 1);
+ my $res = (ref($_[$l]) eq __PACKAGE__) ? $ii : $_[$l];
+ $res %= (ref($_[$r]) eq __PACKAGE__) ? $ii : $_[$r];
+ },
+ '**' => sub {
+ ${$_[0]} += 1;
+ my ($l, $r) = ($_[2]) ? (1, 0) : (0, 1);
+ my $res = (ref($_[$l]) eq __PACKAGE__) ? $ii : $_[$l];
+ $res **= (ref($_[$r]) eq __PACKAGE__) ? $ii : $_[$r];
+ },
+}
+$oo = bless(\do{my $x = 0}, 'Oobj3');
+$cnt = 1;
+
+is(int($oo), $ii, 'int() overload');
+is($$oo, $cnt++, 'overload called once');
+
+is(abs($oo), $ii, 'abs() overload');
+is($$oo, $cnt++, 'overload called once');
+
+is(-$oo, -$ii, 'neg overload');
+is($$oo, $cnt++, 'overload called once');
+
+is(0+$oo, $ii, '+ overload');
+is($$oo, $cnt++, 'overload called once');
+is($oo+0, $ii, '+ overload');
+is($$oo, $cnt++, 'overload called once');
+is($oo+$oo, 2*$ii, '+ overload');
+is($$oo, $cnt++, 'overload called once');
+
+is(0-$oo, -$ii, '- overload');
+is($$oo, $cnt++, 'overload called once');
+is($oo-99, $ii-99, '- overload');
+is($$oo, $cnt++, 'overload called once');
+
+is($oo*2, 2*$ii, '* overload');
+is($$oo, $cnt++, 'overload called once');
+is(-3*$oo, -3*$ii, '* overload');
+is($$oo, $cnt++, 'overload called once');
+
+is($oo/2, ($ii+1)/2, '/ overload');
+is($$oo, $cnt++, 'overload called once');
+is(($ii+1)/$oo, 1, '/ overload');
+is($$oo, $cnt++, 'overload called once');
+
+is($oo%100, $ii%100, '% overload');
+is($$oo, $cnt++, 'overload called once');
+is($ii%$oo, 0, '% overload');
+is($$oo, $cnt++, 'overload called once');
+
+is($oo**1, $ii, '** overload');
+is($$oo, $cnt++, 'overload called once');
+
+# EOF
=back
+=head1 SV-Body Allocation
+
+=over 8
+
+=item sv_2num
+X<sv_2num>
+
+Return an SV with the numeric value of the source SV, doing any necessary
+reference or overload conversion.
+
+ SV* sv_2num(SV* sv)
+
+=for hackers
+Found in file sv.c
+
+
+=back
+
=head1 Unicode Support
=over 8
PP(pp_pow)
{
- dVAR; dSP; dATARGET;
+ dVAR; dSP; dATARGET; SV *svl, *svr;
#ifdef PERL_PRESERVE_IVUV
bool is_int = 0;
#endif
tryAMAGICbin(pow,opASSIGN);
+ svl = sv_2num(TOPm1s);
+ svr = sv_2num(TOPs);
#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(TOPs);
- if (SvIOK(TOPs)) {
- SvIV_please(TOPm1s);
- if (SvIOK(TOPm1s)) {
+ SvIV_please(svr);
+ if (SvIOK(svr)) {
+ SvIV_please(svl);
+ if (SvIOK(svl)) {
UV power;
bool baseuok;
UV baseuv;
- if (SvUOK(TOPs)) {
- power = SvUVX(TOPs);
+ if (SvUOK(svr)) {
+ power = SvUVX(svr);
} else {
- const IV iv = SvIVX(TOPs);
+ const IV iv = SvIVX(svr);
if (iv >= 0) {
power = iv;
} else {
}
}
- baseuok = SvUOK(TOPm1s);
+ baseuok = SvUOK(svl);
if (baseuok) {
- baseuv = SvUVX(TOPm1s);
+ baseuv = SvUVX(svl);
} else {
- const IV iv = SvIVX(TOPm1s);
+ const IV iv = SvIVX(svl);
if (iv >= 0) {
baseuv = iv;
baseuok = TRUE; /* effectively it's a UV now */
}
SP--;
SETn( result );
- SvIV_please(TOPs);
+ SvIV_please(svr);
RETURN;
} else {
register unsigned int highbit = 8 * sizeof(UV);
#ifdef PERL_PRESERVE_IVUV
if (is_int)
- SvIV_please(TOPs);
+ SvIV_please(svr);
#endif
RETURN;
}
PP(pp_multiply)
{
- dVAR; dSP; dATARGET; tryAMAGICbin(mult,opASSIGN);
+ dVAR; dSP; dATARGET; SV *svl, *svr;
+ tryAMAGICbin(mult,opASSIGN);
+ svl = sv_2num(TOPm1s);
+ svr = sv_2num(TOPs);
#ifdef PERL_PRESERVE_IVUV
- SvIV_please(TOPs);
- if (SvIOK(TOPs)) {
+ SvIV_please(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(TOPm1s);
- if (SvIOK(TOPm1s)) {
- bool auvok = SvUOK(TOPm1s);
- bool buvok = SvUOK(TOPs);
+ SvIV_please(svl);
+ if (SvIOK(svl)) {
+ bool auvok = SvUOK(svl);
+ bool buvok = SvUOK(svr);
const UV topmask = (~ (UV)0) << (4 * sizeof (UV));
const UV botmask = ~((~ (UV)0) << (4 * sizeof (UV)));
UV alow;
UV bhigh;
if (auvok) {
- alow = SvUVX(TOPm1s);
+ alow = SvUVX(svl);
} else {
- const IV aiv = SvIVX(TOPm1s);
+ const IV aiv = SvIVX(svl);
if (aiv >= 0) {
alow = aiv;
auvok = TRUE; /* effectively it's a UV now */
}
}
if (buvok) {
- blow = SvUVX(TOPs);
+ blow = SvUVX(svr);
} else {
- const IV biv = SvIVX(TOPs);
+ const IV biv = SvIVX(svr);
if (biv >= 0) {
blow = biv;
buvok = TRUE; /* effectively it's a UV now */
}
} /* product_middle too large */
} /* ahigh && bhigh */
- } /* SvIOK(TOPm1s) */
- } /* SvIOK(TOPs) */
+ } /* SvIOK(svl) */
+ } /* SvIOK(svr) */
#endif
{
dPOPTOPnnrl;
PP(pp_divide)
{
- dVAR; dSP; dATARGET; tryAMAGICbin(div,opASSIGN);
+ dVAR; dSP; dATARGET; SV *svl, *svr;
+ tryAMAGICbin(div,opASSIGN);
+ svl = sv_2num(TOPm1s);
+ svr = sv_2num(TOPs);
/* 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(TOPs);
- if (SvIOK(TOPs)) {
- SvIV_please(TOPm1s);
- if (SvIOK(TOPm1s)) {
- bool left_non_neg = SvUOK(TOPm1s);
- bool right_non_neg = SvUOK(TOPs);
+ SvIV_please(svr);
+ if (SvIOK(svr)) {
+ SvIV_please(svl);
+ if (SvIOK(svl)) {
+ bool left_non_neg = SvUOK(svl);
+ bool right_non_neg = SvUOK(svr);
UV left;
UV right;
if (right_non_neg) {
- right = SvUVX(TOPs);
+ right = SvUVX(svr);
}
else {
- const IV biv = SvIVX(TOPs);
+ const IV biv = SvIVX(svr);
if (biv >= 0) {
right = biv;
right_non_neg = TRUE; /* effectively it's a UV now */
DIE(aTHX_ "Illegal division by zero");
if (left_non_neg) {
- left = SvUVX(TOPm1s);
+ left = SvUVX(svl);
}
else {
- const IV aiv = SvIVX(TOPm1s);
+ const IV aiv = SvIVX(svl);
if (aiv >= 0) {
left = aiv;
left_non_neg = TRUE; /* effectively it's a UV now */
bool dright_valid = FALSE;
NV dright = 0.0;
NV dleft = 0.0;
-
- SvIV_please(TOPs);
- if (SvIOK(TOPs)) {
- right_neg = !SvUOK(TOPs);
+ SV * svl;
+ SV * const svr = sv_2num(TOPs);
+ SvIV_please(svr);
+ if (SvIOK(svr)) {
+ right_neg = !SvUOK(svr);
if (!right_neg) {
- right = SvUVX(POPs);
+ right = SvUVX(svr);
} else {
- const IV biv = SvIVX(POPs);
+ const IV biv = SvIVX(svr);
if (biv >= 0) {
right = biv;
right_neg = FALSE; /* effectively it's a UV now */
right = -biv;
}
}
+ sp--;
}
else {
dright = POPn;
/* 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. */
- SvIV_please(TOPs);
- if (!use_double && SvIOK(TOPs)) {
- if (SvIOK(TOPs)) {
- left_neg = !SvUOK(TOPs);
+ svl = sv_2num(TOPs);
+ SvIV_please(svl);
+ if (!use_double && SvIOK(svl)) {
+ if (SvIOK(svl)) {
+ left_neg = !SvUOK(svl);
if (!left_neg) {
- left = SvUVX(POPs);
+ left = SvUVX(svl);
} else {
- const IV aiv = SvIVX(POPs);
+ const IV aiv = SvIVX(svl);
if (aiv >= 0) {
left = aiv;
left_neg = FALSE; /* effectively it's a UV now */
left = -aiv;
}
}
+ sp--;
}
}
else {
PP(pp_subtract)
{
- dVAR; dSP; dATARGET; bool useleft; tryAMAGICbin(subtr,opASSIGN);
- useleft = USE_LEFT(TOPm1s);
+ dVAR; dSP; dATARGET; bool useleft; SV *svl, *svr;
+ tryAMAGICbin(subtr,opASSIGN);
+ svl = sv_2num(TOPm1s);
+ svr = sv_2num(TOPs);
+ 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(TOPs);
- if (SvIOK(TOPs)) {
+ SvIV_please(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 undef, treat as zero. */
} else {
/* Left operand is defined, so is it IV? */
- SvIV_please(TOPm1s);
- if (SvIOK(TOPm1s)) {
- if ((auvok = SvUOK(TOPm1s)))
- auv = SvUVX(TOPm1s);
+ SvIV_please(svl);
+ if (SvIOK(svl)) {
+ if ((auvok = SvUOK(svl)))
+ auv = SvUVX(svl);
else {
- register const IV aiv = SvIVX(TOPm1s);
+ register const IV aiv = SvIVX(svl);
if (aiv >= 0) {
auv = aiv;
auvok = 1; /* Now acting as a sign flag. */
bool result_good = 0;
UV result;
register UV buv;
- bool buvok = SvUOK(TOPs);
+ bool buvok = SvUOK(svr);
if (buvok)
- buv = SvUVX(TOPs);
+ buv = SvUVX(svr);
else {
- register const IV biv = SvIVX(TOPs);
+ register const IV biv = SvIVX(svr);
if (biv >= 0) {
buv = biv;
buvok = 1;
}
}
#endif
- useleft = USE_LEFT(TOPm1s);
{
dPOPnv;
if (!useleft) {
{
dVAR; dSP; dTARGET; tryAMAGICun(neg);
{
- dTOPss;
+ SV * const sv = sv_2num(TOPs);
const int flags = SvFLAGS(sv);
SvGETMAGIC(sv);
if ((flags & SVf_IOK) || ((flags & (SVp_IOK | SVp_NOK)) == SVp_IOK)) {
{
dVAR; dSP; dTARGET; tryAMAGICun(int);
{
- dTOPss;
- IV iv;
+ SV * const sv = sv_2num(TOPs);
+ const IV iv = SvIV(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
relying on floating point to be accurate is a bug. */
- while (SvAMAGIC(sv)) {
- SV *tsv = AMG_CALLun(sv,numer);
- if (!tsv)
- break;
- if (SvROK(tsv) && SvRV(tsv) == SvRV(sv)) {
- SETu(PTR2UV(SvRV(sv)));
- RETURN;
- }
- else
- sv = tsv;
- }
- iv = SvIV(sv); /* attempt to convert to IV if possible. */
-
if (!SvOK(sv)) {
SETu(0);
}
else
SETi(iv);
}
- else if (SvROK(sv)) {
- SETu(PTR2UV(SvRV(sv)));
- }
else {
const NV value = SvNV(sv);
if (value >= 0.0) {
{
dVAR; dSP; dTARGET; tryAMAGICun(abs);
{
+ SV * const sv = sv_2num(TOPs);
/* This will cache the NV value if string isn't actually integer */
- const IV iv = TOPi;
+ const IV iv = SvIV(sv);
- if (!SvOK(TOPs))
+ if (!SvOK(sv)) {
SETu(0);
- else if (SvIOK(TOPs)) {
+ }
+ else if (SvIOK(sv)) {
/* IVX is precise */
- if (SvIsUV(TOPs)) {
- SETu(TOPu); /* force it to be numeric only */
+ if (SvIsUV(sv)) {
+ SETu(SvUV(sv)); /* force it to be numeric only */
} else {
if (iv >= 0) {
SETi(iv);
}
}
} else{
- const NV value = TOPn;
+ const NV value = SvNV(sv);
if (value < 0.0)
SETn(-value);
else
PP(pp_add)
{
- dVAR; dSP; dATARGET; bool useleft; tryAMAGICbin(add,opASSIGN);
- useleft = USE_LEFT(TOPm1s);
+ dVAR; dSP; dATARGET; bool useleft; SV *svl, *svr;
+ tryAMAGICbin(add,opASSIGN);
+ svl = sv_2num(TOPm1s);
+ svr = sv_2num(TOPs);
+ useleft = USE_LEFT(svl);
#ifdef PERL_PRESERVE_IVUV
/* We must see if we can perform the addition with integers if possible,
as the integer code detects overflow while the NV code doesn't.
unsigned code below is actually shorter than the old code. :-)
*/
- SvIV_please(TOPs);
- if (SvIOK(TOPs)) {
+ SvIV_please(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. */
lots of code to speed up what is probably a rarish case. */
} else {
/* Left operand is defined, so is it IV? */
- SvIV_please(TOPm1s);
- if (SvIOK(TOPm1s)) {
- if ((auvok = SvUOK(TOPm1s)))
- auv = SvUVX(TOPm1s);
+ SvIV_please(svl);
+ if (SvIOK(svl)) {
+ if ((auvok = SvUOK(svl)))
+ auv = SvUVX(svl);
else {
- register const IV aiv = SvIVX(TOPm1s);
+ register const IV aiv = SvIVX(svl);
if (aiv >= 0) {
auv = aiv;
auvok = 1; /* Now acting as a sign flag. */
bool result_good = 0;
UV result;
register UV buv;
- bool buvok = SvUOK(TOPs);
+ bool buvok = SvUOK(svr);
if (buvok)
- buv = SvUVX(TOPs);
+ buv = SvUVX(svr);
else {
- register const IV biv = SvIVX(TOPs);
+ register const IV biv = SvIVX(svr);
if (biv >= 0) {
buv = biv;
buvok = 1;
PERL_CALLCONV NV Perl_sv_2nv(pTHX_ SV* sv)
__attribute__nonnull__(pTHX_1);
+PERL_CALLCONV SV* Perl_sv_2num(pTHX_ SV* sv)
+ __attribute__nonnull__(pTHX_1);
+
/* PERL_CALLCONV char* Perl_sv_2pv(pTHX_ SV* sv, STRLEN* lp)
__attribute__nonnull__(pTHX_1); */
return SvNVX(sv);
}
+/*
+=for apidoc sv_2num
+
+Return an SV with the numeric value of the source SV, doing any necessary
+reference or overload conversion.
+
+=cut
+*/
+
+SV *
+Perl_sv_2num(pTHX_ register SV *sv)
+{
+ if (!SvROK(sv))
+ return sv;
+
+ if (SvAMAGIC(sv)) {
+ SV * const tmpsv = AMG_CALLun(sv,numer);
+ if (tmpsv && (!SvROK(tmpsv) || (SvRV(tmpsv) != SvRV(sv))))
+ return sv_2num(tmpsv);
+ }
+ return sv_2mortal(newSVuv(PTR2UV(SvRV(sv))));
+}
+
/* uiv_2buf(): private routine for use by sv_2pv_flags(): print an IV or
* UV as a string towards the end of buf, and return pointers to start and
* end of it.
projects / p5sagit/p5-mst-13.2.git / commitdiff