/snap/gh/640/usr/share/perl/5.38.2
Edit: /snap/gh/640/usr/share/perl/5.38.2/bignum.pm (28217B)
package bignum;
use strict;
use warnings;
use Carp qw< carp croak >;
our $VERSION = '0.66';
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 {
$^H{bignum} = undef; # no longer in effect
overload::remove_constant('binary', '', 'float', '', 'integer');
}
sub import {
my $class = shift;
$^H{bignum} = 1; # we are in effect
$^H{bigint} = undef;
$^H{bigrat} = undef;
# 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__
=pod
=head1 NAME
bignum - transparent big number support for Perl
=head1 SYNOPSIS
use bignum;
$x = 2 + 4.5; # Math::BigFloat 6.5
print 2 ** 512 * 0.1; # Math::BigFloat 134...09.6
print 2 ** 512; # Math::BigInt 134...096
print inf + 42; # Math::BigInt inf
print NaN * 7; # Math::BigInt NaN
print hex("0x1234567890123490"); # Perl v5.10.0 or later
{
no bignum;
print 2 ** 256; # a normal Perl scalar now
}
# for older Perls, import into current package:
use bignum qw/hex oct/;
print hex("0x1234567890123490");
print oct("01234567890123490");
=head1 DESCRIPTION
=head2 Literal numeric constants
By default, every literal integer becomes a Math::BigInt object, and literal
non-integer becomes a Math::BigFloat object. Whether a numeric literal is
considered an integer or non-integers depends only on the value of the constant,
not on how it is represented. For instance, the constants 3.14e2 and 0x1.3ap8
become Math::BigInt objects, because they both represent the integer value
decimal 314.
The default C