File Coverage

blib/lib/Math/Ryu.pm

Criterion	Covered	Total	%
statement	102	137	74.4
branch	60	84	71.4
condition	12	24	50.0
subroutine	20	26	76.9
pod	0	13	0.0
total	194	284	68.3

## This file generated by InlineX::C2XS (version 0.26) using Inline::C (version 0.79_001)
package Math::Ryu;
use warnings;
use strict;
use Config;

BEGIN {
  # In this BEGIN{} block we check for the presence of a
  # perl bug that can set the POK flag when it should not.
  use B qw(svref_2object);

  if($] < 5.035010) { # TODO - Check if this value can be reduced (to around 5.02 ?)
    my %flags;
    {
      no strict 'refs';
      for my $flag (qw(
        SVf_IOK
        SVf_NOK
        SVf_POK
        SVp_IOK
        SVp_NOK
        SVp_POK
                )) {
        if (defined &{'B::'.$flag}) {
          $flags{$flag} = &{'B::'.$flag};
        }
      }
    }

    my $test_nv = 1.3;
    my $buggery = "$test_nv";
    my $flags = B::svref_2object(\$test_nv)->FLAGS;
    my $fstr = join ' ', sort grep $flags & $flags{$_}, keys %flags;

    if($fstr =~ /SVf_POK/) {
      $Math::Ryu::PV_NV_BUG = 1;
    }
    else {
      $Math::Ryu::PV_NV_BUG = 0;
    }
  } # close if{} block
  else {
    $Math::Ryu::PV_NV_BUG = 0;
  }
};  # close BEGIN{} block

BEGIN {
  if($Config{nvsize} == 8)               { $::max_dig = 17 }
  elsif($Config{nvtype} eq '__float128') { $::max_dig = 36 }
  elsif(defined($Config{longdblkind})
        && $Config{longdblkind} < 3)     { $::max_dig = 36 }
  else                                   { $::max_dig = 21 }

};  # close BEGIN{} block

use constant PV_NV_BUG   => $Math::Ryu::PV_NV_BUG;
use constant IVSIZE      => $Config{ivsize};
use constant MAX_DEC_DIG => $::max_dig; # set in second BEGIN{} block
use constant RYU_MAX_INT => $Config{ivsize} == 4 ? 4294967295
                                                 : 18446744073709551615;
use constant RYU_MIN_INT => $Config{ivsize} == 4 ? -2147483648
                                                 : -9223372036854775808;

require Exporter;
*import = \&Exporter::import;
require DynaLoader;

our $VERSION = '1.09';

DynaLoader::bootstrap Math::Ryu $VERSION;

my @tagged = qw(
  d2s ld2s q2s nv2s fx2s
  is_NV
  pn pnv pany sn snv sany
  spanyf
  n2s
  s2d
  fmtpy fmtpy_pp
  ryu_lln ryu_refcnt ryu_SvIOK ryu_SvNOK ryu_SvPOK ryu_SvIOKp
  );

@Math::Ryu::EXPORT = ();
@Math::Ryu::EXPORT_OK = @tagged;
%Math::Ryu::EXPORT_TAGS = (all => \@tagged);

my $double_inf = 2 ** 1500;
my $double_nan = $double_inf / $double_inf;

# If $Math::Ryu::PERL_INFNAN is set to 0, then the string "inf" represents
# positive infinity, the string "-inf" represents negative infinity, and the
# string "nan" represents a NaN (not a number).
# If $Math::Ryu::PERL_INFNAN is set to a true value then the strings will be
# whatever perl uses to signify positive infinity, negative infinity and nan.

$Math::Ryu::PERL_INFNAN = 0; # Default setting. You can override this
                             # setting in your code.

my $pinf = 1e5000;
my $ninf = -$pinf;
my $nanv =  $pinf / $pinf;
$Math::Ryu::pinfstr = "$pinf";
$Math::Ryu::ninfstr = "$ninf";
$Math::Ryu::nanvstr = "$nanv";

sub dl_load_flags {0} # Prevent DynaLoader from complaining and croaking

sub nv2s {
  my $nv = shift;
  return fmtpy( d2s($nv)) if MAX_DEC_DIG == 17;
  return fmtpy(ld2s($nv)) if MAX_DEC_DIG == 21;
  return fmtpy( q2s($nv));
}

sub n2s {
  my $arg = shift;
  die "The n2s() function does not accept ", ref($arg), " references"
    if ref($arg);
  if(!ryu_SvPOK($arg)) {
    return $arg if ryu_SvIOK($arg);
    return _from_NV($arg) if _NV_fits_IV($arg);
  }
  return nv2s($arg) if ryu_SvNOK($arg);
  # When this sub is called by pany() or sany(), it
  # will have returned before reaching here.
  # $arg is neither integer nor float nor reference.
  # If the numified $arg fits into an IV, return the
  # stringification of that value.
  # Else, return nv2s($arg), which will coerce $arg
  # to an NV.
  my $ret = $arg + 0;
  return "$ret"     if ryu_SvIOK($ret);
  #return nv2s($ret) if ryu_SvNOK($ret);
  return nv2s($arg);
}

sub fmtpy_pp {
  # Pure perl rendition of the fmtpy function. Not exported.
  # The given argument will be either 'Infinity', '-Infinity', 'NaN'
  # or a finite value of the form "mantissaEexponent".
  # The mantissa portion will include a decimal point (with that decimal
  # point being the second character in the mantissa) unless the
  # mantissa consists of only one decimal significant decimal digit,
  # in which case there is no decimal point and the mantissa consists
  # solely of that digit.

  my $s = shift;
  my $sign = '';
  my $bitpos = 0;

  $sign = '-' if $s =~ s/^\-//;

  $bitpos = 1 if substr($s, 1, 1) eq '.'; # else there isn't a decimal point.

  if($bitpos) {
    # Mantissa's second character is the decimal point.
    # Split into mantissa and exponent
    my @parts = split /E/i, $s;
    if($parts[1] > 0 && $parts[1] < MAX_DEC_DIG) {
      # We want, eg,  a value like 1.1E-3 to be returned as "0.0011".
      my $zero_pad = $parts[1] - (length($parts[0]) - 2);
      if($zero_pad >= 0 && ($zero_pad + length($parts[0])) < MAX_DEC_DIG + 1 ) {
        substr($parts[0], 1, 1, '');
        return $sign . $parts[0] . ('0' x $zero_pad) . '.0';
      }
      elsif($zero_pad < 0) {
        # We want, eg,  a value like 1.23625E2 to be returned as "123.625".
        # relocate the decimal point
        substr($parts[0], 1, 1, '');
        substr($parts[0], $zero_pad, 0, '.');
        return $sign . $parts[0];
      }
    }

    # Return as is, except that we replace the 'E' with 'e', ensuring also
    # that the exponent is preceded by a '+' or '-' sign, and that
    # negative exponents consist of at least 2 digits.
    $s =~ s/e/e\+/i if $parts[1] > 0;
    if ($parts[1] < -4 || $parts[1] >= 0) {
      $s =~ s/E0$//i;
      substr($s, -1, 0, '0') if substr($s, -2, 1) eq '-'; # pad exponent with a leading '0'.
      return $sign . lc($s);
    }
    # Return, eg 6.25E1 as "0.625"
    substr($parts[0], 1, 1, ''); # remove decimal point.
    return $sign . '0.' . ('0' x (abs($parts[1]) - 1)) . $parts[0] ;
  }
  else {
    # Return '-inf', 'inf', or 'nan' if (and as) appropriate.
    if($s =~ /n/i) {
      if($Math::Ryu::PERL_INFNAN) {
        return $Math::Ryu::nanvstr if $s =~ /a/i;
        return $Math::Ryu::ninfstr if $sign;
        return $Math::Ryu::pinfstr;
      }
      return $sign . lc(substr($s, 0, 3));
    }

    # Append '.0' to the mantissa and return it if the exponent is 0.
    return $sign . $s . '.0' if $s =~ s/E0$//i;
    my @parts = split /E/i, $s;

    # Return as is, except that we replace the 'E' with 'e', ensuring also
    # that the exponent is preceded by a '+' or '-' sign, and that
    # negative exponents consist of at least 2 digits.
    $s =~ s/e/e\+/i if $parts[1] > 0;
    $s =~ s/e\-/e\-0/i if ($parts[1] < -4 && $parts[1] > -10);
    return $sign . lc($s) if ($parts[1] < -4 || $parts[1] > MAX_DEC_DIG - 2);

    if($parts[1] >= 0 ) { # $parts[1] is in the range 1..(MAX_DEC_DIG - 2)
      return $sign . $parts[0] . (0 x $parts[1]) . '.0';
    }

    # Return, eg, 6E-3 as "0.006".
    return $sign . '0.' . ('0' x (abs($parts[1]) - 1)) . $parts[0] ;
  }
}

sub s2d {
  die "s2d() is available only to perls whose NV is of type 'double'"
    unless MAX_DEC_DIG == 17;
  my $str = shift;

  die("Strings passed to s2d() must \"look like a number\"")
    unless ryu_lln($str);
  # For _s2d, we need to remove all leading and trailing whitespace.
  # If $str contained internal whitespace, then s2d has already died.
  $str =~ s/\s//g;

  # _s2d doesn't handle inf/nan, so we attend to that first.
  # However, if perl recognizes these strings as numeric, then it's
  # not really necessary to assign them using s2d.
  # And if perl does NOT recognize these strings as numeric, then s2d
  # is simply going to croak.
  # Anyway, here they are:
  return $double_inf  if $str =~ /^\+?inf/i;
  return -$double_inf if $str =~ /^\-inf/i;
  return $double_nan  if $str =~ /^(\-|\+)?nan/i;

  return _s2d($str);
}

sub pn {
  my $arg = shift;
  print n2s($arg);
}

sub sn {
  my $arg = shift;
  print n2s($arg), "\n";
}

sub pnv {
  my $nv = shift;
  print nv2s($nv);
}

sub snv {
  my $nv = shift;
  print nv2s($nv), "\n";
}

sub pany { # "p"rint "any"
  print spanyf(@_)
}

sub sany {
  print spanyf(@_) . "\n";
}

sub spanyf {
  # Prepares the string that pany/sany will print.
  my $ret = '';

  for my $arg (@_) {
    if(is_NV($arg)) {
      if(_NV_fits_IV($arg)) { $ret .= _from_NV($arg) } # nv2s($arg) would append a ".0"
      else { $ret .= nv2s($arg) }
    }
    else {
      $ret .= "$arg";
    }
  }
  return $ret;
}

sub _NV_fits_IV {
  # Called only when the argument is an NV
  my $nv = shift;
  return 0 if $nv != int($nv);
  return 1 if ( $nv <= RYU_MAX_INT && $nv >= RYU_MIN_INT );
  return 0;
}

sub is_NV {
  my $arg = shift;

  return 1
    if(PV_NV_BUG && ryu_SvPOK($arg) && ryu_SvNOK($arg) && !ryu_SvIOKp($arg));

  if(ryu_lln($arg)) { # Wraps the perl API function looks_like_number(),
                      # which differs from Scalar::Util::looks_like_number().
    return 0
      if(ryu_SvPOK($arg) || ryu_SvIOK($arg));

    # At this point we know that $arg looks like a number
    # and neither its POK flag nor its IOK flag is set.
    # It must be an NV.
    return 1;
  }
  return 0;
}

1;