bigfloat.pm

视频监控网络部分的协议ddns,的模块的实现代码,请大家大胆指正.

package Math::BigFloat;

# 
# Mike grinned. 'Two down, infinity to go' - Mike Nostrus in 'Before and After'
#

# The following hash values are internally used:
#   _e	: exponent (ref to $CALC object)
#   _m	: mantissa (ref to $CALC object)
#   _es	: sign of _e
# sign	: +,-,+inf,-inf, or "NaN" if not a number
#   _a	: accuracy
#   _p	: precision

$VERSION = '1.59';
require 5.006;

require Exporter;
@ISA		= qw/Math::BigInt/;
@EXPORT_OK	= qw/bpi/;

use strict;
# $_trap_inf/$_trap_nan are internal and should never be accessed from outside
use vars qw/$AUTOLOAD $accuracy $precision $div_scale $round_mode $rnd_mode
	    $upgrade $downgrade $_trap_nan $_trap_inf/;
my $class = "Math::BigFloat";

use overload
'<=>'	=>	sub { my $rc = $_[2] ?
                      ref($_[0])->bcmp($_[1],$_[0]) : 
                      ref($_[0])->bcmp($_[0],$_[1]); 
		      $rc = 1 unless defined $rc;
		      $rc <=> 0;
		},
# we need '>=' to get things like "1 >= NaN" right:
'>='	=>	sub { my $rc = $_[2] ?
                      ref($_[0])->bcmp($_[1],$_[0]) : 
                      ref($_[0])->bcmp($_[0],$_[1]);
		      # if there was a NaN involved, return false
		      return '' unless defined $rc;
		      $rc >= 0;
		},
'int'	=>	sub { $_[0]->as_number() },		# 'trunc' to bigint
;

##############################################################################
# global constants, flags and assorted stuff

# the following are public, but their usage is not recommended. Use the
# accessor methods instead.

# class constants, use Class->constant_name() to access
# one of 'even', 'odd', '+inf', '-inf', 'zero', 'trunc' or 'common'
$round_mode = 'even';
$accuracy   = undef;
$precision  = undef;
$div_scale  = 40;

$upgrade = undef;
$downgrade = undef;
# the package we are using for our private parts, defaults to:
# Math::BigInt->config()->{lib}
my $MBI = 'Math::BigInt::FastCalc';

# are NaNs ok? (otherwise it dies when encountering an NaN) set w/ config()
$_trap_nan = 0;
# the same for infinity
$_trap_inf = 0;

# constant for easier life
my $nan = 'NaN'; 

my $IMPORT = 0;	# was import() called yet? used to make require work

# some digits of accuracy for blog(undef,10); which we use in blog() for speed
my $LOG_10 = 
 '2.3025850929940456840179914546843642076011014886287729760333279009675726097';
my $LOG_10_A = length($LOG_10)-1;
# ditto for log(2)
my $LOG_2 = 
 '0.6931471805599453094172321214581765680755001343602552541206800094933936220';
my $LOG_2_A = length($LOG_2)-1;
my $HALF = '0.5';			# made into an object if nec.

##############################################################################
# the old code had $rnd_mode, so we need to support it, too

sub TIESCALAR   { my ($class) = @_; bless \$round_mode, $class; }
sub FETCH       { return $round_mode; }
sub STORE       { $rnd_mode = $_[0]->round_mode($_[1]); }

BEGIN
  {
  # when someone sets $rnd_mode, we catch this and check the value to see
  # whether it is valid or not. 
  $rnd_mode   = 'even'; tie $rnd_mode, 'Math::BigFloat';

  # we need both of them in this package:
  *as_int = \&as_number;
  }
 
##############################################################################

{
  # valid method aliases for AUTOLOAD
  my %methods = map { $_ => 1 }  
   qw / fadd fsub fmul fdiv fround ffround fsqrt fmod fstr fsstr fpow fnorm
        fint facmp fcmp fzero fnan finf finc fdec ffac fneg
	fceil ffloor frsft flsft fone flog froot fexp
      /;
  # valid methods that can be handed up (for AUTOLOAD)
  my %hand_ups = map { $_ => 1 }  
   qw / is_nan is_inf is_negative is_positive is_pos is_neg
        accuracy precision div_scale round_mode fabs fnot
        objectify upgrade downgrade
	bone binf bnan bzero
	bsub
      /;

  sub _method_alias { exists $methods{$_[0]||''}; } 
  sub _method_hand_up { exists $hand_ups{$_[0]||''}; } 
}

##############################################################################
# constructors

sub new 
  {
  # create a new BigFloat object from a string or another bigfloat object. 
  # _e: exponent
  # _m: mantissa
  # sign  => sign (+/-), or "NaN"

  my ($class,$wanted,@r) = @_;

  # avoid numify-calls by not using || on $wanted!
  return $class->bzero() if !defined $wanted;	# default to 0
  return $wanted->copy() if UNIVERSAL::isa($wanted,'Math::BigFloat');

  $class->import() if $IMPORT == 0;             # make require work

  my $self = {}; bless $self, $class;
  # shortcut for bigints and its subclasses
  if ((ref($wanted)) && UNIVERSAL::can( $wanted, "as_number"))
    {
    $self->{_m} = $wanted->as_number()->{value}; # get us a bigint copy
    $self->{_e} = $MBI->_zero();
    $self->{_es} = '+';
    $self->{sign} = $wanted->sign();
    return $self->bnorm();
    }
  # else: got a string or something maskerading as number (with overload)

  # handle '+inf', '-inf' first
  if ($wanted =~ /^[+-]?inf\z/)
    {
    return $downgrade->new($wanted) if $downgrade;

    $self->{sign} = $wanted;		# set a default sign for bstr()
    return $self->binf($wanted);
    }

  # shortcut for simple forms like '12' that neither have trailing nor leading
  # zeros
  if ($wanted =~ /^([+-]?)([1-9][0-9]*[1-9])$/)
    {
    $self->{_e} = $MBI->_zero();
    $self->{_es} = '+';
    $self->{sign} = $1 || '+';
    $self->{_m} = $MBI->_new($2);
    return $self->round(@r) if !$downgrade;
    }

  my ($mis,$miv,$mfv,$es,$ev) = Math::BigInt::_split($wanted);
  if (!ref $mis)
    {
    if ($_trap_nan)
      {
      require Carp;
      Carp::croak ("$wanted is not a number initialized to $class");
      }
    
    return $downgrade->bnan() if $downgrade;
    
    $self->{_e} = $MBI->_zero();
    $self->{_es} = '+';
    $self->{_m} = $MBI->_zero();
    $self->{sign} = $nan;
    }
  else
    {
    # make integer from mantissa by adjusting exp, then convert to int
    $self->{_e} = $MBI->_new($$ev);		# exponent
    $self->{_es} = $$es || '+';
    my $mantissa = "$$miv$$mfv"; 		# create mant.
    $mantissa =~ s/^0+(\d)/$1/;			# strip leading zeros
    $self->{_m} = $MBI->_new($mantissa); 	# create mant.

    # 3.123E0 = 3123E-3, and 3.123E-2 => 3123E-5
    if (CORE::length($$mfv) != 0)
      {
      my $len = $MBI->_new( CORE::length($$mfv));
      ($self->{_e}, $self->{_es}) =
	_e_sub ($self->{_e}, $len, $self->{_es}, '+');
      }
    # we can only have trailing zeros on the mantissa if $$mfv eq ''
    else
      {
      # Use a regexp to count the trailing zeros in $$miv instead of _zeros()
      # because that is faster, especially when _m is not stored in base 10.
      my $zeros = 0; $zeros = CORE::length($1) if $$miv =~ /[1-9](0*)$/; 
      if ($zeros != 0)
        {
        my $z = $MBI->_new($zeros);
        # turn '120e2' into '12e3'
        $MBI->_rsft ( $self->{_m}, $z, 10);
        ($self->{_e}, $self->{_es}) =
	  _e_add ( $self->{_e}, $z, $self->{_es}, '+');
        }
      }
    $self->{sign} = $$mis;

    # for something like 0Ey, set y to 1, and -0 => +0
    # Check $$miv for being '0' and $$mfv eq '', because otherwise _m could not
    # have become 0. That's faster than to call $MBI->_is_zero().
    $self->{sign} = '+', $self->{_e} = $MBI->_one()
     if $$miv eq '0' and $$mfv eq '';

    return $self->round(@r) if !$downgrade;
    }
  # if downgrade, inf, NaN or integers go down

  if ($downgrade && $self->{_es} eq '+')
    {
    if ($MBI->_is_zero( $self->{_e} ))
      {
      return $downgrade->new($$mis . $MBI->_str( $self->{_m} ));
      }
    return $downgrade->new($self->bsstr()); 
    }
  $self->bnorm()->round(@r);			# first normalize, then round
  }

sub copy
  {
  # if two arguments, the first one is the class to "swallow" subclasses
  if (@_ > 1)
    {
    my  $self = bless {
	sign => $_[1]->{sign}, 
	_es => $_[1]->{_es}, 
	_m => $MBI->_copy($_[1]->{_m}),
	_e => $MBI->_copy($_[1]->{_e}),
    }, $_[0] if @_ > 1;

    $self->{_a} = $_[1]->{_a} if defined $_[1]->{_a};
    $self->{_p} = $_[1]->{_p} if defined $_[1]->{_p};
    return $self;
    }

  my $self = bless {
	sign => $_[0]->{sign}, 
	_es => $_[0]->{_es}, 
	_m => $MBI->_copy($_[0]->{_m}),
	_e => $MBI->_copy($_[0]->{_e}),
	}, ref($_[0]);

  $self->{_a} = $_[0]->{_a} if defined $_[0]->{_a};
  $self->{_p} = $_[0]->{_p} if defined $_[0]->{_p};
  $self;
  }

sub _bnan
  {
  # used by parent class bone() to initialize number to NaN
  my $self = shift;
  
  if ($_trap_nan)
    {
    require Carp;
    my $class = ref($self);
    Carp::croak ("Tried to set $self to NaN in $class\::_bnan()");
    }

  $IMPORT=1;					# call our import only once
  $self->{_m} = $MBI->_zero();
  $self->{_e} = $MBI->_zero();
  $self->{_es} = '+';
  }

sub _binf
  {
  # used by parent class bone() to initialize number to +-inf
  my $self = shift;
  
  if ($_trap_inf)
    {
    require Carp;
    my $class = ref($self);
    Carp::croak ("Tried to set $self to +-inf in $class\::_binf()");
    }

  $IMPORT=1;					# call our import only once
  $self->{_m} = $MBI->_zero();
  $self->{_e} = $MBI->_zero();
  $self->{_es} = '+';
  }

sub _bone
  {
  # used by parent class bone() to initialize number to 1
  my $self = shift;
  $IMPORT=1;					# call our import only once
  $self->{_m} = $MBI->_one();
  $self->{_e} = $MBI->_zero();
  $self->{_es} = '+';
  }

sub _bzero
  {
  # used by parent class bone() to initialize number to 0
  my $self = shift;
  $IMPORT=1;					# call our import only once
  $self->{_m} = $MBI->_zero();
  $self->{_e} = $MBI->_one();
  $self->{_es} = '+';
  }

sub isa
  {
  my ($self,$class) = @_;
  return if $class =~ /^Math::BigInt/;		# we aren't one of these
  UNIVERSAL::isa($self,$class);
  }

sub config
  {
  # return (later set?) configuration data as hash ref
  my $class = shift || 'Math::BigFloat';

  if (@_ == 1 && ref($_[0]) ne 'HASH')
    {
    my $cfg = $class->SUPER::config();
    return $cfg->{$_[0]};
    }

  my $cfg = $class->SUPER::config(@_);

  # now we need only to override the ones that are different from our parent
  $cfg->{class} = $class;
  $cfg->{with} = $MBI;
  $cfg;
  }

##############################################################################
# string conversation

sub bstr 
  {
  # (ref to BFLOAT or num_str ) return num_str
  # Convert number from internal format to (non-scientific) string format.
  # internal format is always normalized (no leading zeros, "-0" => "+0")
  my ($self,$x) = ref($_[0]) ? (undef,$_[0]) : objectify(1,@_);

  if ($x->{sign} !~ /^[+-]$/)
    {
    return $x->{sign} unless $x->{sign} eq '+inf';      # -inf, NaN
    return 'inf';                                       # +inf
    }

  my $es = '0'; my $len = 1; my $cad = 0; my $dot = '.';

  # $x is zero?
  my $not_zero = !($x->{sign} eq '+' && $MBI->_is_zero($x->{_m}));
  if ($not_zero)
    {
    $es = $MBI->_str($x->{_m});
    $len = CORE::length($es);
    my $e = $MBI->_num($x->{_e});	
    $e = -$e if $x->{_es} eq '-';
    if ($e < 0)
      {
      $dot = '';
      # if _e is bigger than a scalar, the following will blow your memory
      if ($e <= -$len)
        {
        my $r = abs($e) - $len;
        $es = '0.'. ('0' x $r) . $es; $cad = -($len+$r);
        }
      else
        {
        substr($es,$e,0) = '.'; $cad = $MBI->_num($x->{_e});
        $cad = -$cad if $x->{_es} eq '-';
        }
      }
    elsif ($e > 0)
      {
      # expand with zeros
      $es .= '0' x $e; $len += $e; $cad = 0;
      }
    } # if not zero

  $es = '-'.$es if $x->{sign} eq '-';
  # if set accuracy or precision, pad with zeros on the right side
  if ((defined $x->{_a}) && ($not_zero))
    {
    # 123400 => 6, 0.1234 => 4, 0.001234 => 4
    my $zeros = $x->{_a} - $cad;		# cad == 0 => 12340
    $zeros = $x->{_a} - $len if $cad != $len;
    $es .= $dot.'0' x $zeros if $zeros > 0;
    }
  elsif ((($x->{_p} || 0) < 0))
    {
    # 123400 => 6, 0.1234 => 4, 0.001234 => 6
    my $zeros = -$x->{_p} + $cad;
    $es .= $dot.'0' x $zeros if $zeros > 0;
    }
  $es;
  }

sub bsstr
  {
  # (ref to BFLOAT or num_str ) return num_str
  # Convert number from internal format to scientific string format.
  # internal format is always normalized (no leading zeros, "-0E0" => "+0E0")
  my ($self,$x) = ref($_[0]) ? (undef,$_[0]) : objectify(1,@_);

  if ($x->{sign} !~ /^[+-]$/)
    {
    return $x->{sign} unless $x->{sign} eq '+inf';      # -inf, NaN
    return 'inf';                                       # +inf
    }
  my $sep = 'e'.$x->{_es};
  my $sign = $x->{sign}; $sign = '' if $sign eq '+';
  $sign . $MBI->_str($x->{_m}) . $sep . $MBI->_str($x->{_e});
  }
    
sub numify 
  {
  # Make a number from a BigFloat object
  # simple return a string and let Perl's atoi()/atof() handle the rest