Fix RT 62764: Math::BigFloat->bcmp() fails.

Why: The Math::BigFloat->bcmp() method returns the wrong result when the
exponent is too large to be represented exactly as a Perl numerical
scalar. In such cases, bcmp() returns 0 because it fails to distinguish
between the two exponents.

How: With this fix, bcmp() does not convert the exponents to Perl
numerical scalars, but keeps them as arbitrary precision integers, thus
returning the correct result regardsless of the number of digits in the
exponent.

Test: Two tests added. These tests fail with the old code.

Files:

- lib/Math/BigFloat.pm: New version of bcmp().

- t/bigfltpm.inc: Add two tests confirming desired behaviour.

- t/bare_mbf.t: Increment test count.

- t/bigfltpm.t: Increment test count.

- t/sub_mbf.t: Increment test count.

- t/with_sub.t Increment test count.

6 files changed, 146 insertions, 51 deletions

diff --git a/dist/Math-BigInt/lib/Math/BigFloat.pm b/dist/Math-BigInt/lib/Math/BigFloat.pm
index 89dc84256f..1ccd381680 100644
--- a/dist/Math-BigInt/lib/Math/BigFloat.pm
+++ b/dist/Math-BigInt/lib/Math/BigFloat.pm
@@ -473,6 +473,7 @@ sub bcmp
 
   # set up parameters
   my ($self,$x,$y) = (ref($_[0]),@_);
+
   # objectify is costly, so avoid it
   if ((!ref($_[0])) || (ref($_[0]) ne ref($_[1])))
     {
@@ -482,58 +483,150 @@ sub bcmp
   return $upgrade->bcmp($x,$y) if defined $upgrade &&
     ((!$x->isa($self)) || (!$y->isa($self)));
 
-  if (($x->{sign} !~ /^[+-]$/) || ($y->{sign} !~ /^[+-]$/))
-    {
-    # handle +-inf and NaN
-    return undef if (($x->{sign} eq $nan) || ($y->{sign} eq $nan));
-    return 0 if ($x->{sign} eq $y->{sign}) && ($x->{sign} =~ /^[+-]inf$/);
-    return +1 if $x->{sign} eq '+inf';
-    return -1 if $x->{sign} eq '-inf';
-    return -1 if $y->{sign} eq '+inf';
-    return +1;
-    }
+  # Handle all 'nan' cases.
 
-  # check sign for speed first
-  return 1 if $x->{sign} eq '+' && $y->{sign} eq '-';	# does also 0 <=> -y
-  return -1 if $x->{sign} eq '-' && $y->{sign} eq '+';	# does also -x <=> 0
+  return undef if ($x->{sign} eq $nan) || ($y->{sign} eq $nan);
+
+  # Handle all '+inf' and '-inf' cases.
+
+  return  0 if ($x->{sign} eq '+inf' && $y->{sign} eq '+inf' ||
+                $x->{sign} eq '-inf' && $y->{sign} eq '-inf');
+  return +1 if $x->{sign} eq '+inf';    # x = +inf and y < +inf
+  return -1 if $x->{sign} eq '-inf';    # x = -inf and y > -inf
+  return -1 if $y->{sign} eq '+inf';    # x < +inf and y = +inf
+  return +1 if $y->{sign} eq '-inf';    # x > -inf and y = -inf
+
+  # Handle all cases with opposite signs.
+
+  return +1 if $x->{sign} eq '+' && $y->{sign} eq '-';  # also does 0 <=> -y
+  return -1 if $x->{sign} eq '-' && $y->{sign} eq '+';  # also does -x <=> 0
+
+  # Handle all remaining zero cases.
 
-  # shortcut 
   my $xz = $x->is_zero();
   my $yz = $y->is_zero();
-  return 0 if $xz && $yz;				# 0 <=> 0
-  return -1 if $xz && $y->{sign} eq '+';		# 0 <=> +y
-  return 1 if $yz && $x->{sign} eq '+';			# +x <=> 0
+  return  0 if $xz && $yz;                              # 0 <=> 0
+  return -1 if $xz && $y->{sign} eq '+';                # 0 <=> +y
+  return +1 if $yz && $x->{sign} eq '+';                # +x <=> 0
+
+  # Both arguments are now finite, non-zero numbers with the same sign.
+
+  my $cmp;
+
+  # The next step is to compare the exponents, but since each mantissa is an
+  # integer of arbitrary value, the exponents must be normalized by the length
+  # of the mantissas before we can compare them.
+
+  my $mxl = $MBI->_len($x->{_m});
+  my $myl = $MBI->_len($y->{_m});
+
+  # If the mantissas have the same length, there is no point in normalizing the
+  # exponents by the length of the mantissas, so treat that as a special case.
+
+  if ($mxl == $myl) {
+
+      # First handle the two cases where the exponents have different signs.
+
+      if ($x->{_es} eq '+' && $y->{_es} eq '-') {
+          $cmp = +1;
+      }
+
+      elsif ($x->{_es} eq '-' && $y->{_es} eq '+') {
+          $cmp = -1;
+      }
+
+      # Then handle the case where the exponents have the same sign.
+
+      else {
+          $cmp = $MBI->_acmp($x->{_e}, $y->{_e});
+          $cmp = -$cmp if $x->{_es} eq '-';
+      }
+
+      # Adjust for the sign, which is the same for x and y, and bail out if
+      # we're done.
+
+      $cmp = -$cmp if $x->{sign} eq '-';        # 124 > 123, but -124 < -123
+      return $cmp if $cmp;
+
+  }
+
+  # We must normalize each exponent by the length of the corresponding
+  # mantissa. Life is a lot easier if we first make both exponents
+  # non-negative. We do this by adding the same positive value to both
+  # exponent. This is safe, because when comparing the exponents, only the
+  # relative difference is important.
+
+  my $ex;
+  my $ey;
+
+  if ($x->{_es} eq '+') {
+
+      # If the exponent of x is >= 0 and the exponent of y is >= 0, there is no
+      # need to do anything special.
+
+      if ($y->{_es} eq '+') {
+          $ex = $MBI->_copy($x->{_e});
+          $ey = $MBI->_copy($y->{_e});
+      }
+
+      # If the exponent of x is >= 0 and the exponent of y is < 0, add the
+      # absolute value of the exponent of y to both.
+
+      else {
+          $ex = $MBI->_copy($x->{_e});
+          $ex = $MBI->_add($ex, $y->{_e});      # ex + |ey|
+          $ey = $MBI->_zero();                  # -ex + |ey| = 0
+      }
+
+  } else {
+
+      # If the exponent of x is < 0 and the exponent of y is >= 0, add the
+      # absolute value of the exponent of x to both.
+
+      if ($y->{_es} eq '+') {
+          $ex = $MBI->_zero();                  # -ex + |ex| = 0
+          $ey = $MBI->_copy($y->{_e});
+          $ey = $MBI->_add($ey, $x->{_e});      # ey + |ex|
+      }
+
+      # If the exponent of x is < 0 and the exponent of y is < 0, add the
+      # absolute values of both exponents to both exponents.
+
+      else {
+          $ex = $MBI->_copy($y->{_e});          # -ex + |ey| + |ex| = |ey|
+          $ey = $MBI->_copy($x->{_e});          # -ey + |ex| + |ey| = |ex|
+      }
+
+  }
+
+  # Now we can normalize the exponents by adding lengths of the mantissas.
+
+  $MBI->_add($ex, $MBI->_new($mxl));
+  $MBI->_add($ey, $MBI->_new($myl));
+
+  # We're done if the exponents are different.
+
+  $cmp = $MBI->_acmp($ex, $ey);
+  $cmp = -$cmp if $x->{sign} eq '-';            # 124 > 123, but -124 < -123
+  return $cmp if $cmp;
+
+  # Compare the mantissas, but first normalize them by padding the shorter
+  # mantissa with zeros (shift left) until it has the same length as the longer
+  # mantissa.
+
+  my $mx = $x->{_m};
+  my $my = $y->{_m};
+
+  if ($mxl > $myl) {
+      $my = $MBI->_lsft($MBI->_copy($my), $MBI->_new($mxl - $myl), 10);
+  } elsif ($mxl < $myl) {
+      $mx = $MBI->_lsft($MBI->_copy($mx), $MBI->_new($myl - $mxl), 10);
+  }
+
+  $cmp = $MBI->_acmp($mx, $my);
+  $cmp = -$cmp if $x->{sign} eq '-';            # 124 > 123, but -124 < -123
+  return $cmp;
 
-  # adjust so that exponents are equal
-  my $lxm = $MBI->_len($x->{_m});
-  my $lym = $MBI->_len($y->{_m});
-  # the numify somewhat limits our length, but makes it much faster
-  my ($xes,$yes) = (1,1);
-  $xes = -1 if $x->{_es} ne '+';
-  $yes = -1 if $y->{_es} ne '+';
-  my $lx = $lxm + $xes * $MBI->_num($x->{_e});
-  my $ly = $lym + $yes * $MBI->_num($y->{_e});
-  my $l = $lx - $ly; $l = -$l if $x->{sign} eq '-';
-  return $l <=> 0 if $l != 0;
-  
-  # lengths (corrected by exponent) are equal
-  # so make mantissa equal length by padding with zero (shift left)
-  my $diff = $lxm - $lym;
-  my $xm = $x->{_m};		# not yet copy it
-  my $ym = $y->{_m};
-  if ($diff > 0)
-    {
-    $ym = $MBI->_copy($y->{_m});
-    $ym = $MBI->_lsft($ym, $MBI->_new($diff), 10);
-    }
-  elsif ($diff < 0)
-    {
-    $xm = $MBI->_copy($x->{_m});
-    $xm = $MBI->_lsft($xm, $MBI->_new(-$diff), 10);
-    }
-  my $rc = $MBI->_acmp($xm,$ym);
-  $rc = -$rc if $x->{sign} eq '-';		# -124 < -123
-  $rc <=> 0;
   }
 
 sub bacmp 
diff --git a/dist/Math-BigInt/t/bare_mbf.t b/dist/Math-BigInt/t/bare_mbf.t
index 8ecfc9f469..e9cead6461 100644
--- a/dist/Math-BigInt/t/bare_mbf.t
+++ b/dist/Math-BigInt/t/bare_mbf.t
@@ -1,7 +1,7 @@
 #!/usr/bin/perl -w
 
 use strict;
-use Test::More tests => 2320;
+use Test::More tests => 2322;
 
 BEGIN { unshift @INC, 't'; }
 
diff --git a/dist/Math-BigInt/t/bigfltpm.inc b/dist/Math-BigInt/t/bigfltpm.inc
index bb5384bc9f..8c349c951b 100644
--- a/dist/Math-BigInt/t/bigfltpm.inc
+++ b/dist/Math-BigInt/t/bigfltpm.inc
@@ -1064,6 +1064,8 @@ fcmpNaN:+0:
 2:1.5:1
 1.54321:234:-1
 234:1.54321:1
+1e1234567890987654321:1e1234567890987654320:1
+1e-1234567890987654321:1e-1234567890987654320:-1
 # infinity
 -inf:5432112345:-1
 +inf:5432112345:1
diff --git a/dist/Math-BigInt/t/bigfltpm.t b/dist/Math-BigInt/t/bigfltpm.t
index 34fa0f0c69..e0b939e5fe 100644
--- a/dist/Math-BigInt/t/bigfltpm.t
+++ b/dist/Math-BigInt/t/bigfltpm.t
@@ -1,7 +1,7 @@
 #!/usr/bin/perl -w
 
 use strict;
-use Test::More tests => 2320
+use Test::More tests => 2322
     + 5;		# own tests
 
 
diff --git a/dist/Math-BigInt/t/sub_mbf.t b/dist/Math-BigInt/t/sub_mbf.t
index c556b5c04f..67ba192746 100644
--- a/dist/Math-BigInt/t/sub_mbf.t
+++ b/dist/Math-BigInt/t/sub_mbf.t
@@ -1,7 +1,7 @@
 #!/usr/bin/perl -w
 
 use strict;
-use Test::More tests => 2320
+use Test::More tests => 2322
     + 6;	# + our own tests
 
 
diff --git a/dist/Math-BigInt/t/with_sub.t b/dist/Math-BigInt/t/with_sub.t
index 97cabab5d2..dc28d7703c 100644
--- a/dist/Math-BigInt/t/with_sub.t
+++ b/dist/Math-BigInt/t/with_sub.t
@@ -3,7 +3,7 @@
 # Test use Math::BigFloat with => 'Math::BigInt::SomeSubclass';
 
 use strict;
-use Test::More tests => 2320 + 1;
+use Test::More tests => 2322 + 1;
 
 use Math::BigFloat with => 'Math::BigInt::Subclass', lib => 'Calc';