package bigint;
use 5.010;
use strict;
use warnings;
our $VERSION = '0.51';
use Exporter;
our @ISA = qw( Exporter );
our @EXPORT_OK = qw( PI e bpi bexp hex oct );
our @EXPORT = qw( inf NaN );
use overload;
##############################################################################
# These are all alike, and thus faked by AUTOLOAD
my @faked = qw/round_mode accuracy precision div_scale/;
our ($AUTOLOAD, $_lite); # _lite for testsuite
sub AUTOLOAD {
my $name = $AUTOLOAD;
$name =~ s/.*:://; # split package
no strict 'refs';
foreach my $n (@faked) {
if ($n eq $name) {
*{"bigint::$name"} =
sub {
my $self = shift;
no strict 'refs';
if (defined $_[0]) {
return Math::BigInt->$name($_[0]);
}
return Math::BigInt->$name();
};
return &$name;
}
}
# delayed load of Carp and avoid recursion
require Carp;
Carp::croak ("Can't call bigint\-\>$name, not a valid method");
}
sub upgrade {
$Math::BigInt::upgrade;
}
sub _binary_constant {
# this takes a binary/hexadecimal/octal constant string and returns it
# as string suitable for new. Basically it converts octal to decimal, and
# passes every thing else unmodified back.
my $string = shift;
return Math::BigInt->new($string) if $string =~ /^0[bx]/;
# so it must be an octal constant
Math::BigInt->from_oct($string);
}
sub _float_constant {
# this takes a floating point constant string and returns it truncated to
# integer. For instance, '4.5' => '4', '1.234e2' => '123' etc
my $float = shift;
# some simple cases first
return $float if ($float =~ /^[+-]?[0-9]+$/); # '+123','-1','0' etc
return $float
if ($float =~ /^[+-]?[0-9]+\.?[eE]\+?[0-9]+$/); # 123e2, 123.e+2
return '0' if ($float =~ /^[+-]?[0]*\.[0-9]+$/); # .2, 0.2, -.1
if ($float =~ /^[+-]?[0-9]+\.[0-9]*$/) { # 1., 1.23, -1.2 etc
$float =~ s/\..*//;
return $float;
}
my ($mis, $miv, $mfv, $es, $ev) = Math::BigInt::_split($float);
return $float if !defined $mis; # doesn't look like a number to me
my $ec = int($$ev);
my $sign = $$mis;
$sign = '' if $sign eq '+';
if ($$es eq '-') {
# ignore fraction part entirely
if ($ec >= length($$miv)) { # 123.23E-4
return '0';
}
return $sign . substr($$miv, 0, length($$miv) - $ec); # 1234.45E-2 = 12
}
# xE+y
if ($ec >= length($$mfv)) {
$ec -= length($$mfv);
return $sign.$$miv.$$mfv if $ec == 0; # 123.45E+2 => 12345
return $sign.$$miv.$$mfv.'E'.$ec; # 123.45e+3 => 12345e1
}
$mfv = substr($$mfv, 0, $ec);
$sign.$$miv.$mfv; # 123.45e+1 => 1234
}
sub unimport {
$^H{bigint} = undef; # no longer in effect
overload::remove_constant('binary', '', 'float', '', 'integer');
}
sub in_effect {
my $level = shift || 0;
my $hinthash = (caller($level))[10];
$hinthash->{bigint};
}
#############################################################################
# the following two routines are for "use bigint 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 = Math::BigInt -> from_hex($chrs);
} else {
$x = Math::BigInt -> 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 = Math::BigInt -> 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-7]* ( _ [0-7]+ )* ) //x) {
my $chrs = $1;
$chrs =~ tr/_//d;
$chrs = '0' unless CORE::length $chrs;
$x = Math::BigInt -> from_oct($chrs);
}
# Warn about trailing garbage. CORE::oct() only warns about 8 and 9.
if (CORE::length($str)) {
my $chr = substr($str, 0, 1);
if ($chr eq '8' || $chr eq '9') {
require Carp;
Carp::carp(sprintf("Illegal octal digit '%s' ignored", $chr));
}
}
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 $prev_hex ? &$prev_hex($_[0]) : CORE::hex($_[0])
unless $$hh{bigint}||$$hh{bignum}||$$hh{bigrat};
_hex_core($_[0]);
}
sub _oct(_) {
my $hh = (caller 0)[10];
return $prev_oct ? &$prev_oct($_[0]) : CORE::oct($_[0])
unless $$hh{bigint}||$$hh{bignum}||$$hh{bigrat};
_oct_core($_[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++;
}
sub import {
my $self = shift;
$^H{bigint} = 1; # we are in effect
# for newer Perls always override hex() and oct() with a lexical version:
if (LEXICAL) {
_override();
}
# some defaults
my $lib = '';
my $lib_kind = 'try';
my @import = (':constant'); # drive it w/ constant
my @a = @_;
my $l = scalar @_;
my $j = 0;
my ($ver, $trace); # version? trace?
my ($a, $p); # accuracy, precision
for (my $i = 0; $i < $l; $i++, $j++) {
if ($_[$i] =~ /^(l|lib|try|only)$/) {
# this causes a different low lib to take care...
$lib_kind = $1;
$lib_kind = 'lib' if $lib_kind eq 'l';
$lib = $_[$i + 1] || '';
my $s = 2;
$s = 1 if @a - $j < 2; # avoid "can not modify non-existent..."
splice @a, $j, $s;
$j -= $s;
$i++;
} elsif ($_[$i] =~ /^(a|accuracy)$/) {
$a = $_[$i + 1];
my $s = 2;
$s = 1 if @a - $j < 2; # avoid "can not modify non-existent..."
splice @a, $j, $s;
$j -= $s;
$i++;
} elsif ($_[$i] =~ /^(p|precision)$/) {
$p = $_[$i + 1];
my $s = 2;
$s = 1 if @a - $j < 2; # avoid "can not modify non-existent..."
splice @a, $j, $s;
$j -= $s;
$i++;
} elsif ($_[$i] =~ /^(v|version)$/) {
$ver = 1;
splice @a, $j, 1;
$j--;
} elsif ($_[$i] =~ /^(t|trace)$/) {
$trace = 1;
splice @a, $j, 1;
$j--;
} elsif ($_[$i] !~ /^(PI|e|bpi|bexp|hex|oct)\z/) {
die ("unknown option $_[$i]");
}
}
my $class;
$_lite = 0; # using M::BI::L ?
if ($trace) {
require Math::BigInt::Trace;
$class = 'Math::BigInt::Trace';
} else {
# see if we can find Math::BigInt::Lite
if (!defined $a && !defined $p) { # rounding won't work to well
local @INC = @INC;
pop @INC if $INC[-1] eq '.';
if (eval { require Math::BigInt::Lite; 1 }) {
@import = (); # :constant in Lite, not MBI
Math::BigInt::Lite->import(':constant');
$_lite = 1; # signal okay
}
}
require Math::BigInt if $_lite == 0; # not already loaded?
$class = 'Math::BigInt'; # regardless of MBIL or not
}
push @import, $lib_kind => $lib if $lib ne '';
# Math::BigInt::Trace or plain Math::BigInt
$class->import(@import);
bigint->accuracy($a) if defined $a;
bigint->precision($p) if defined $p;
if ($ver) {
print "bigint\t\t\t v$VERSION\n";
print "Math::BigInt::Lite\t v$Math::BigInt::Lite::VERSION\n" if $_lite;
print "Math::BigInt\t\t v$Math::BigInt::VERSION";
my $config = Math::BigInt->config();
print " lib => $config->{lib} v$config->{lib_version}\n";
exit;
}
# we take care of floating point constants, since BigFloat isn't available
# and BigInt doesn't like them:
overload::constant float =>
sub {
Math::BigInt->new(_float_constant(shift));
};
# Take care of octal/hexadecimal constants
overload::constant binary =>
sub {
_binary_constant(shift);
};
# if another big* was already loaded:
my ($package) = caller();
no strict 'refs';
if (!defined *{"${package}::inf"}) {
$self->export_to_level(1, $self, @a); # export inf and NaN, e and PI
}
}
sub inf () { Math::BigInt->binf(); }
sub NaN () { Math::BigInt->bnan(); }
sub PI () { Math::BigInt->new(3); }
sub e () { Math::BigInt->new(2); }
sub bpi ($) { Math::BigInt->new(3); }
sub bexp ($$) {
my $x = Math::BigInt->new($_[0]);
$x->bexp($_[1]);
}
1;
__END__
=pod
=head1 NAME
bigint - Transparent BigInteger support for Perl
=head1 SYNOPSIS
use bigint;
$x = 2 + 4.5,"\n"; # BigInt 6
print 2 ** 512,"\n"; # really is what you think it is
print inf + 42,"\n"; # inf
print NaN * 7,"\n"; # NaN
print hex("0x1234567890123490"),"\n"; # Perl v5.10.0 or later
{
no bigint;
print 2 ** 256,"\n"; # a normal Perl scalar now
}
# Import into current package:
use bigint qw/hex oct/;
print hex("0x1234567890123490"),"\n";
print oct("01234567890123490"),"\n";
=head1 DESCRIPTION
All operators (including basic math operations) except the range operator C<..>
are overloaded. Integer constants are created as proper BigInts.
Floating point constants are truncated to integer. All parts and results of
expressions are also truncated.
Unlike L, this pragma creates integer constants that are only
limited in their size by the available memory and CPU time.
=head2 use integer vs. use bigint
There is one small difference between C