File Coverage

blib/lib/bignum.pm

Criterion	Covered	Total	%
statement	148	188	78.7
branch	48	84	57.1
condition	13	20	65.0
subroutine	29	33	87.8
pod	15	15	100.0
total	253	340	74.4

package bignum;

use strict;
use warnings;

use Carp qw< carp croak >;

our $VERSION = '0.67';

use Exporter;
our @ISA            = qw( Exporter );
our @EXPORT_OK      = qw( PI e bpi bexp hex oct );
our @EXPORT         = qw( inf NaN );

use overload;

# Defaults: When a constant is an integer, Inf or NaN, it is converted to an
# object of class $int_class. When a constant is a finite non-integer, it is
# converted to an object of class $float_class.

my $int_class = 'Math::BigInt';
my $float_class = 'Math::BigFloat';

##############################################################################

sub accuracy {
    shift;
    $int_class -> accuracy(@_);
    $float_class -> accuracy(@_);
}

sub precision {
    shift;
    $int_class -> precision(@_);
    $float_class -> precision(@_);
}

sub round_mode {
    shift;
    $int_class -> round_mode(@_);
    $float_class -> round_mode(@_);
}

sub div_scale {
    shift;
    $int_class -> div_scale(@_);
    $float_class -> div_scale(@_);
}

sub upgrade {
    shift;
    $int_class -> upgrade(@_);
}

sub downgrade {
    shift;
    $float_class -> downgrade(@_);
}

sub in_effect {
    my $level = shift || 0;
    my $hinthash = (caller($level))[10];
    $hinthash->{bignum};
}

sub _float_constant {
    my $str = shift;

    # See if we can convert the input string to a string using a normalized form
    # consisting of the significand as a signed integer, the character "e", and
    # the exponent as a signed integer, e.g., "+0e+0", "+314e-2", and "-1e+3".

    my $nstr;

    if (
        # See if it is an octal number. An octal number like '0377' is also
        # accepted by the functions parsing decimal and hexadecimal numbers, so
        # handle octal numbers before decimal and hexadecimal numbers.

        $str =~ /^0(?:[Oo]|_*[0-7])/ and
        $nstr = Math::BigInt -> oct_str_to_dec_flt_str($str)

          or

        # See if it is decimal number.

        $nstr = Math::BigInt -> dec_str_to_dec_flt_str($str)

          or

        # See if it is a hexadecimal number. Every hexadecimal number has a
        # prefix, but the functions parsing numbers don't require it, so check
        # to see if it actually is a hexadecimal number.

        $str =~ /^0[Xx]/ and
        $nstr = Math::BigInt -> hex_str_to_dec_flt_str($str)

          or

        # See if it is a binary numbers. Every binary number has a prefix, but
        # the functions parsing numbers don't require it, so check to see if it
        # actually is a binary number.

        $str =~ /^0[Bb]/ and
        $nstr = Math::BigInt -> bin_str_to_dec_flt_str($str))
    {
        my $pos      = index($nstr, 'e');
        my $expo_sgn = substr($nstr, $pos + 1, 1);
        my $sign     = substr($nstr, 0, 1);
        my $mant     = substr($nstr, 1, $pos - 1);
        my $mant_len = CORE::length($mant);
        my $expo     = substr($nstr, $pos + 2);

        # The number is a non-integer if and only if the exponent is negative.

        if ($expo_sgn eq '-') {
            return $float_class -> new($str);

            my $upgrade = $int_class -> upgrade();
            return $upgrade -> new($nstr) if defined $upgrade;

            if ($mant_len <= $expo) {
                return $int_class -> bzero();                   # underflow
            } else {
                $mant = substr $mant, 0, $mant_len - $expo;     # truncate
                return $int_class -> new($sign . $mant);
            }
        } else {
            $mant .= "0" x $expo;                               # pad with zeros
            return $int_class -> new($sign . $mant);
        }
    }

    # If we get here, there is a bug in the code above this point.

    warn "Internal error: unable to handle literal constant '$str'.",
      " This is a bug, so please report this to the module author.";
    return $int_class -> bnan();
}

#############################################################################
# the following two routines are for "use bignum qw/hex oct/;":

use constant LEXICAL => $] > 5.009004;

# Internal function with the same semantics as CORE::hex(). This function is
# not used directly, but rather by other front-end functions.

sub _hex_core {
    my $str = shift;

    # Strip off, clean, and parse as much as we can from the beginning.

    my $x;
    if ($str =~ s/ ^ ( 0? [xX] )? ( [0-9a-fA-F]* ( _ [0-9a-fA-F]+ )* ) //x) {
        my $chrs = $2;
        $chrs =~ tr/_//d;
        $chrs = '0' unless CORE::length $chrs;
        $x = $int_class -> from_hex($chrs);
    } else {
        $x = $int_class -> bzero();
    }

    # Warn about trailing garbage.

    if (CORE::length($str)) {
        require Carp;
        Carp::carp(sprintf("Illegal hexadecimal digit '%s' ignored",
                           substr($str, 0, 1)));
    }

    return $x;
}

# Internal function with the same semantics as CORE::oct(). This function is
# not used directly, but rather by other front-end functions.

sub _oct_core {
    my $str = shift;

    $str =~ s/^\s*//;

    # Hexadecimal input.

    return _hex_core($str) if $str =~ /^0?[xX]/;

    my $x;

    # Binary input.

    if ($str =~ /^0?[bB]/) {

        # Strip off, clean, and parse as much as we can from the beginning.

        if ($str =~ s/ ^ ( 0? [bB] )? ( [01]* ( _ [01]+ )* ) //x) {
            my $chrs = $2;
            $chrs =~ tr/_//d;
            $chrs = '0' unless CORE::length $chrs;
            $x = $int_class -> from_bin($chrs);
        }

        # Warn about trailing garbage.

        if (CORE::length($str)) {
            require Carp;
            Carp::carp(sprintf("Illegal binary digit '%s' ignored",
                               substr($str, 0, 1)));
        }

        return $x;
    }

    # Octal input. Strip off, clean, and parse as much as we can from the
    # beginning.

    if ($str =~ s/ ^ ( 0? [oO] )? ( [0-7]* ( _ [0-7]+ )* ) //x) {
        my $chrs = $2;
        $chrs =~ tr/_//d;
        $chrs = '0' unless CORE::length $chrs;
        $x = $int_class -> from_oct($chrs);
    }

    # Warn about trailing garbage. CORE::oct() only warns about 8 and 9, but it
    # is more helpful to warn about all invalid digits.

    if (CORE::length($str)) {
        require Carp;
        Carp::carp(sprintf("Illegal octal digit '%s' ignored",
                           substr($str, 0, 1)));
    }

    return $x;
}

{
    my $proto = LEXICAL ? '_' : ';$';
    eval '
sub hex(' . $proto . ') {' . <<'.';
    my $str = @_ ? $_[0] : $_;
    _hex_core($str);
}
.

    eval '
sub oct(' . $proto . ') {' . <<'.';
    my $str = @_ ? $_[0] : $_;
    _oct_core($str);
}
.
}

#############################################################################
# the following two routines are for Perl 5.9.4 or later and are lexical

my ($prev_oct, $prev_hex, $overridden);

if (LEXICAL) { eval <<'.' }
sub _hex(_) {
    my $hh = (caller 0)[10];
    return $$hh{bignum} ? bignum::_hex_core($_[0])
         : $$hh{bigrat} ? bigrat::_hex_core($_[0])
         : $$hh{bigint} ? bigint::_hex_core($_[0])
         : $prev_hex    ? &$prev_hex($_[0])
         : CORE::hex($_[0]);
}

sub _oct(_) {
    my $hh = (caller 0)[10];
    return $$hh{bignum} ? bignum::_oct_core($_[0])
         : $$hh{bigrat} ? bigrat::_oct_core($_[0])
         : $$hh{bigint} ? bigint::_oct_core($_[0])
         : $prev_oct    ? &$prev_oct($_[0])
         : CORE::oct($_[0]);
}
.

sub _override {
    return if $overridden;
    $prev_oct = *CORE::GLOBAL::oct{CODE};
    $prev_hex = *CORE::GLOBAL::hex{CODE};
    no warnings 'redefine';
    *CORE::GLOBAL::oct = \&_oct;
    *CORE::GLOBAL::hex = \&_hex;
    $overridden = 1;
}

sub unimport {
    delete $^H{bignum};         # no longer in effect
    overload::remove_constant('binary', '', 'float', '', 'integer');
}

sub import {
    my $class = shift;

    $^H{bignum} = 1;            # we are in effect
    delete $^H{bigint};
    delete $^H{bigrat};

    # for newer Perls always override hex() and oct() with a lexical version:
    if (LEXICAL) {
        _override();
    }

    my @import     = ();                        # common options
    my @int_import = (upgrade => $float_class); # int class only options
    my @flt_import = (downgrade => $int_class); # float class only options
    my @a = ();                                 # unrecognized arguments
    my $ver;                                    # display version info?

    while (@_) {
        my $param = shift;

        # Upgrading.

        if ($param eq 'upgrade') {
            my $arg = shift;
            $float_class = $arg if defined $arg;
            push @int_import, 'upgrade', $arg;
            next;
        }

        # Downgrading.

        if ($param eq 'downgrade') {
            my $arg = shift;
            $int_class = $arg if defined $arg;
            push @flt_import, 'downgrade', $arg;
            next;
        }

        # Accuracy.

        if ($param =~ /^a(ccuracy)?$/) {
            push @import, 'accuracy', shift();
            next;
        }

        # Precision.

        if ($param =~ /^p(recision)?$/) {
            push @import, 'precision', shift();
            next;
        }

        # Rounding mode.

        if ($param eq 'round_mode') {
            push @import, 'round_mode', shift();
            next;
        }

        # Backend library.

        if ($param =~ /^(l|lib|try|only)$/) {
            push @import, $param eq 'l' ? 'lib' : $param;
            push @import, shift() if @_;
            next;
        }

        if ($param =~ /^(v|version)$/) {
            $ver = 1;
            next;
        }

        if ($param =~ /^(PI|e|bexp|bpi|hex|oct)\z/) {
            push @a, $param;
            next;
        }

        croak("Unknown option '$param'");
    }

    eval "require $int_class";
    die $@ if $@;
    $int_class -> import(@int_import, @import);

    eval "require $float_class";
    die $@ if $@;
    $float_class -> import(@flt_import, @import);

    if ($ver) {
        printf "%-31s v%s\n", $class, $class -> VERSION();
        printf " lib => %-23s v%s\n",
          $int_class -> config("lib"), $int_class -> config("lib_version");
        printf "%-31s v%s\n", $int_class, $int_class -> VERSION();
        exit;
    }

    $class -> export_to_level(1, $class, @a);   # export inf, NaN, etc.

    overload::constant

        # This takes care each number written as decimal integer and within the
        # range of what perl can represent as an integer, e.g., "314", but not
        # "3141592653589793238462643383279502884197169399375105820974944592307".

        integer => sub {
            #printf "Value '%s' handled by the 'integer' sub.\n", $_[0];
            my $str = shift;
            return $int_class -> new($str);
        },

        # This takes care of each number written with a decimal point and/or
        # using floating point notation, e.g., "3.", "3.0", "3.14e+2" (decimal),
        # "0b1.101p+2" (binary), "03.14p+2" and "0o3.14p+2" (octal), and
        # "0x3.14p+2" (hexadecimal).

        float => sub {
            #printf "# Value '%s' handled by the 'float' sub.\n", $_[0];
            _float_constant(shift);
        },

        # Take care of each number written as an integer (no decimal point or
        # exponent) using binary, octal, or hexadecimal notation, e.g., "0b101"
        # (binary), "0314" and "0o314" (octal), and "0x314" (hexadecimal).

        binary => sub {
            #printf "# Value '%s' handled by the 'binary' sub.\n", $_[0];
            my $str = shift;
            return $int_class -> new($str) if $str =~ /^0[XxBb]/;
            $int_class -> from_oct($str);
        };
}

sub inf () { $int_class -> binf(); }
sub NaN () { $int_class -> bnan(); }

# This should depend on the current accuracy/precision. Fixme!
sub PI  () { $float_class -> new('3.141592653589793238462643383279502884197'); }
sub e   () { $float_class -> new('2.718281828459045235360287471352662497757'); }

sub bpi ($) {
    my $up = Math::BigFloat -> upgrade();   # get current upgrading, if any ...
    Math::BigFloat -> upgrade(undef);       # ... and disable
    my $x = Math::BigFloat -> bpi(@_);
    Math::BigFloat -> upgrade($up);         # reset the upgrading
    return $x;
}

sub bexp ($$) {
    my $up = Math::BigFloat -> upgrade();   # get current upgrading, if any ...
    Math::BigFloat -> upgrade(undef);       # ... and disable
    my $x = Math::BigFloat -> new(shift) -> bexp(@_);
    Math::BigFloat -> upgrade($up);         # reset the upgrading
    return $x;
}

1;

__END__