bigfloat.pm

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

      local $Math::BigFloat::downgrade = undef;

      # shorten the time to calculate log(10) based on the following:
      # log(1.25 * 8) = log(1.25) + log(8)
      #               = log(1.25) + log(2) + log(2) + log(2)

      # first get $l_2 (and possible compute and cache log(2))
      $LOG_2 = $self->new($LOG_2,undef,undef) unless ref $LOG_2;
      if ($scale <= $LOG_2_A)
        {
        # use cached value
        $l_2 = $LOG_2->copy();			# copy() for the mul below
        }
      else
        {
        # else: slower, compute and cache result
        $l_2 = $two->copy(); $self->_log($l_2, $scale); # scale+4, actually
        $LOG_2 = $l_2->copy();			# cache the result for later
						# the copy() is for mul below
        $LOG_2_A = $scale;
        }

      # now calculate log(1.25):
      $l_10 = $self->new('1.25'); $self->_log($l_10, $scale); # scale+4, actually

      # log(1.25) + log(2) + log(2) + log(2):
      $l_10->badd($l_2);
      $l_10->badd($l_2);
      $l_10->badd($l_2);
      $LOG_10 = $l_10->copy();		# cache the result for later
					# the copy() is for mul below
      $LOG_10_A = $scale;
      }
    $dbd-- if ($dbd > 1); 		# 20 => dbd=2, so make it dbd=1	
    $l_10->bmul( $self->new($dbd));	# log(10) * (digits_before_dot-1)
    my $dbd_sign = '+';
    if ($dbd < 0)
      {
      $dbd = -$dbd;
      $dbd_sign = '-';
      }
    ($x->{_e}, $x->{_es}) = 
	_e_sub( $x->{_e}, $MBI->_new($dbd), $x->{_es}, $dbd_sign); # 123 => 1.23
 
    }

  # Now: 0.1 <= $x < 10 (and possible correction in l_10)

  ### Since $x in the range 0.5 .. 1.5 is MUCH faster, we do a repeated div
  ### or mul by 2 (maximum times 3, since x < 10 and x > 0.1)

  $HALF = $self->new($HALF) unless ref($HALF);

  my $twos = 0;				# default: none (0 times)	
  while ($x->bacmp($HALF) <= 0)		# X <= 0.5
    {
    $twos--; $x->bmul($two);
    }
  while ($x->bacmp($two) >= 0)		# X >= 2
    {
    $twos++; $x->bdiv($two,$scale+4);		# keep all digits
    }
  # $twos > 0 => did mul 2, < 0 => did div 2 (but we never did both)
  # So calculate correction factor based on ln(2):
  if ($twos != 0)
    {
    $LOG_2 = $self->new($LOG_2,undef,undef) unless ref $LOG_2;
    if ($scale <= $LOG_2_A)
      {
      # use cached value
      $l_2 = $LOG_2->copy();			# copy() for the mul below
      }
    else
      {
      # else: slower, compute and cache result
      # also disable downgrade for this code path
      local $Math::BigFloat::downgrade = undef;
      $l_2 = $two->copy(); $self->_log($l_2, $scale); # scale+4, actually
      $LOG_2 = $l_2->copy();			# cache the result for later
						# the copy() is for mul below
      $LOG_2_A = $scale;
      }
    $l_2->bmul($twos);		# * -2 => subtract, * 2 => add
    }
  
  $self->_log($x,$scale);			# need to do the "normal" way
  $x->badd($l_10) if defined $l_10; 		# correct it by ln(10)
  $x->badd($l_2) if defined $l_2;		# and maybe by ln(2)

  # all done, $x contains now the result
  $x;
  }

sub blcm 
  { 
  # (BFLOAT or num_str, BFLOAT or num_str) return BFLOAT
  # does not modify arguments, but returns new object
  # Lowest Common Multiplicator

  my ($self,@arg) = objectify(0,@_);
  my $x = $self->new(shift @arg);
  while (@arg) { $x = Math::BigInt::__lcm($x,shift @arg); } 
  $x;
  }

sub bgcd
  {
  # (BINT or num_str, BINT or num_str) return BINT
  # does not modify arguments, but returns new object

  my $y = shift;
  $y = __PACKAGE__->new($y) if !ref($y);
  my $self = ref($y);
  my $x = $y->copy()->babs();			# keep arguments

  return $x->bnan() if $x->{sign} !~ /^[+-]$/	# x NaN?
	|| !$x->is_int();			# only for integers now

  while (@_)
    {
    my $t = shift; $t = $self->new($t) if !ref($t);
    $y = $t->copy()->babs();
    
    return $x->bnan() if $y->{sign} !~ /^[+-]$/	# y NaN?
     	|| !$y->is_int();			# only for integers now

    # greatest common divisor
    while (! $y->is_zero())
      {
      ($x,$y) = ($y->copy(), $x->copy()->bmod($y));
      }

    last if $x->is_one();
    }
  $x;
  }

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

sub _e_add
  {
  # Internal helper sub to take two positive integers and their signs and
  # then add them. Input ($CALC,$CALC,('+'|'-'),('+'|'-')), 
  # output ($CALC,('+'|'-'))
  my ($x,$y,$xs,$ys) = @_;

  # if the signs are equal we can add them (-5 + -3 => -(5 + 3) => -8)
  if ($xs eq $ys)
    {
    $x = $MBI->_add ($x, $y );		# a+b
    # the sign follows $xs
    return ($x, $xs);
    }

  my $a = $MBI->_acmp($x,$y);
  if ($a > 0)
    {
    $x = $MBI->_sub ($x , $y);				# abs sub
    }
  elsif ($a == 0)
    {
    $x = $MBI->_zero();					# result is 0
    $xs = '+';
    }
  else # a < 0
    {
    $x = $MBI->_sub ( $y, $x, 1 );			# abs sub
    $xs = $ys;
    }
  ($x,$xs);
  }

sub _e_sub
  {
  # Internal helper sub to take two positive integers and their signs and
  # then subtract them. Input ($CALC,$CALC,('+'|'-'),('+'|'-')), 
  # output ($CALC,('+'|'-'))
  my ($x,$y,$xs,$ys) = @_;

  # flip sign
  $ys =~ tr/+-/-+/;
  _e_add($x,$y,$xs,$ys);		# call add (does subtract now)
  }

###############################################################################
# is_foo methods (is_negative, is_positive are inherited from BigInt)

sub is_int
  {
  # return true if arg (BFLOAT or num_str) is an integer
  my ($self,$x) = ref($_[0]) ? (undef,$_[0]) : objectify(1,@_);

  (($x->{sign} =~ /^[+-]$/) &&			# NaN and +-inf aren't
   ($x->{_es} eq '+')) ? 1 : 0;			# 1e-1 => no integer
  }

sub is_zero
  {
  # return true if arg (BFLOAT or num_str) is zero
  my ($self,$x) = ref($_[0]) ? (undef,$_[0]) : objectify(1,@_);

  ($x->{sign} eq '+' && $MBI->_is_zero($x->{_m})) ? 1 : 0;
  }

sub is_one
  {
  # return true if arg (BFLOAT or num_str) is +1 or -1 if signis given
  my ($self,$x,$sign) = ref($_[0]) ? (undef,@_) : objectify(1,@_);

  $sign = '+' if !defined $sign || $sign ne '-';

  ($x->{sign} eq $sign && 
   $MBI->_is_zero($x->{_e}) &&
   $MBI->_is_one($x->{_m}) ) ? 1 : 0; 
  }

sub is_odd
  {
  # return true if arg (BFLOAT or num_str) is odd or false if even
  my ($self,$x) = ref($_[0]) ? (undef,$_[0]) : objectify(1,@_);
  
  (($x->{sign} =~ /^[+-]$/) &&		# NaN & +-inf aren't
   ($MBI->_is_zero($x->{_e})) &&
   ($MBI->_is_odd($x->{_m}))) ? 1 : 0; 
  }

sub is_even
  {
  # return true if arg (BINT or num_str) is even or false if odd
  my ($self,$x) = ref($_[0]) ? (undef,$_[0]) : objectify(1,@_);

  (($x->{sign} =~ /^[+-]$/) &&			# NaN & +-inf aren't
   ($x->{_es} eq '+') &&	 		# 123.45 isn't
   ($MBI->_is_even($x->{_m}))) ? 1 : 0;		# but 1200 is
  }

sub bmul
  { 
  # multiply two numbers
  
  # set up parameters
  my ($self,$x,$y,@r) = (ref($_[0]),@_);
  # objectify is costly, so avoid it
  if ((!ref($_[0])) || (ref($_[0]) ne ref($_[1])))
    {
    ($self,$x,$y,@r) = objectify(2,@_);
    }

  return $x if $x->modify('bmul');

  return $x->bnan() if (($x->{sign} eq $nan) || ($y->{sign} eq $nan));

  # inf handling
  if (($x->{sign} =~ /^[+-]inf$/) || ($y->{sign} =~ /^[+-]inf$/))
    {
    return $x->bnan() if $x->is_zero() || $y->is_zero(); 
    # result will always be +-inf:
    # +inf * +/+inf => +inf, -inf * -/-inf => +inf
    # +inf * -/-inf => -inf, -inf * +/+inf => -inf
    return $x->binf() if ($x->{sign} =~ /^\+/ && $y->{sign} =~ /^\+/);
    return $x->binf() if ($x->{sign} =~ /^-/ && $y->{sign} =~ /^-/);
    return $x->binf('-');
    }
  
  return $upgrade->bmul($x,$y,@r) if defined $upgrade &&
   ((!$x->isa($self)) || (!$y->isa($self)));

  # aEb * cEd = (a*c)E(b+d)
  $MBI->_mul($x->{_m},$y->{_m});
  ($x->{_e}, $x->{_es}) = _e_add($x->{_e}, $y->{_e}, $x->{_es}, $y->{_es});

  $r[3] = $y;				# no push!

  # adjust sign:
  $x->{sign} = $x->{sign} ne $y->{sign} ? '-' : '+';
  $x->bnorm->round(@r);
  }

sub bmuladd
  { 
  # multiply two numbers and add the third to the result
  
  # set up parameters
  my ($self,$x,$y,$z,@r) = (ref($_[0]),@_);
  # objectify is costly, so avoid it
  if ((!ref($_[0])) || (ref($_[0]) ne ref($_[1])))
    {
    ($self,$x,$y,$z,@r) = objectify(3,@_);
    }

  return $x if $x->modify('bmuladd');

  return $x->bnan() if (($x->{sign} eq $nan) ||
			($y->{sign} eq $nan) ||
			($z->{sign} eq $nan));

  # inf handling
  if (($x->{sign} =~ /^[+-]inf$/) || ($y->{sign} =~ /^[+-]inf$/))
    {
    return $x->bnan() if $x->is_zero() || $y->is_zero(); 
    # result will always be +-inf:
    # +inf * +/+inf => +inf, -inf * -/-inf => +inf
    # +inf * -/-inf => -inf, -inf * +/+inf => -inf
    return $x->binf() if ($x->{sign} =~ /^\+/ && $y->{sign} =~ /^\+/);
    return $x->binf() if ($x->{sign} =~ /^-/ && $y->{sign} =~ /^-/);
    return $x->binf('-');
    }

  return $upgrade->bmul($x,$y,@r) if defined $upgrade &&
   ((!$x->isa($self)) || (!$y->isa($self)));

  # aEb * cEd = (a*c)E(b+d)
  $MBI->_mul($x->{_m},$y->{_m});
  ($x->{_e}, $x->{_es}) = _e_add($x->{_e}, $y->{_e}, $x->{_es}, $y->{_es});

  $r[3] = $y;				# no push!

  # adjust sign:
  $x->{sign} = $x->{sign} ne $y->{sign} ? '-' : '+';

  # z=inf handling (z=NaN handled above)
  $x->{sign} = $z->{sign}, return $x if $z->{sign} =~ /^[+-]inf$/;

  # take lower of the two e's and adapt m1 to it to match m2
  my $e = $z->{_e};
  $e = $MBI->_zero() if !defined $e;		# if no BFLOAT?
  $e = $MBI->_copy($e);				# make copy (didn't do it yet)

  my $es;

  ($e,$es) = _e_sub($e, $x->{_e}, $z->{_es} || '+', $x->{_es});

  my $add = $MBI->_copy($z->{_m});

  if ($es eq '-')				# < 0
    {
    $MBI->_lsft( $x->{_m}, $e, 10);
    ($x->{_e},$x->{_es}) = _e_add($x->{_e}, $e, $x->{_es}, $es);
    }
  elsif (!$MBI->_is_zero($e))			# > 0
    {
    $MBI->_lsft($add, $e, 10);
    }
  # else: both e are the same, so just leave them

  if ($x->{sign} eq $z->{sign})
    {
    # add
    $x->{_m} = $MBI->_add($x->{_m}, $add);
    }
  else
    {
    ($x->{_m}, $x->{sign}) = 
     _e_add($x->{_m}, $add, $x->{sign}, $z->{sign});
    }

  # delete trailing zeros, then round
  $x->bnorm()->round(@r);
  }

sub bdiv 
  {
  # (dividend: BFLOAT or num_str, divisor: BFLOAT or num_str) return 
  # (BFLOAT,BFLOAT) (quo,rem) or BFLOAT (only rem)

  # set up parameters
  my ($self,$x,$y,$a,$p,$r) = (ref($_[0]),@_);
  # objectify is costly, so avoid it
  if ((!ref($_[0])) || (ref($_[0]) ne ref($_[1])))
    {
    ($self,$x,$y,$a,$p,$r) = objectify(2,@_);
    }

  return $x if $x->modify('bdiv');

  return $self->_div_inf($x,$y)
   if (($x->{sign} !~ /^[+-]$/) || ($y->{sign} !~ /^[+-]$/) || $y->is_zero());

  # x== 0 # also: or y == 1 or y == -1
  return wantarray ? ($x,$self->bzero()) : $x if $x->is_zero();

  # upgrade ?
  return $upgrade->bdiv($upgrade->new($x),$y,$a,$p,$r) if defined $upgrade;

  # we need to limit the accuracy to protect against overflow
  my $fallback = 0;
  my (@params,$scale);
  ($x,@params) = $x->_find_round_parameters($a,$p,$r,$y);

  return $x if $x->is_nan();		# error in _find_round_parameters?

  # no rounding at all, so must use fallback
  if (scalar @params == 0)
    {
    # simulate old behaviour
    $params[0] = $self->div_scale();	# and round to it as accuracy
    $scale = $params[0]+4; 		# at least four more for proper round
    $params[2] = $r;			# round mode by caller or undef
    $fallback = 1;			# to clear a/p afterwards
    }
  else
    {
    # the 4 below is empirical, and there might be cases where it is not
    # enough...
    $scale = abs($params[0] || $params[1]) + 4;	# take whatever is defined
    }

  my $rem; $rem = $self->bzero() if wantarray;

  $y = $self->new($y) unless $y->isa('Math::BigFloat');

  my $lx = $MBI->_len($x->{_m}); my $ly = $MBI->_len($y->{_m});
  $scale = $lx if $lx > $scale;
  $scale = $ly if $ly > $scale;
  my $diff = $ly - $lx;
  $scale += $diff if $diff > 0;		# if lx << ly, but not if ly << lx!

  # already handled inf/NaN/-inf above:

  # check that $y is not 1 nor -1 and cache the result:
  my $y_not_one = !($MBI->_is_zero($y->{_e}) && $MBI->_is_one($y->{_m}));

  # flipping the sign of $y will also flip the sign of $x for the special
  # case of $x->bsub($x); so we can catch it below:
  my $xsign = $x->{sign};
  $y->{sign} =~ tr/+-/-+/;

  if ($xsign ne $x->{sign})
    {
    # special case of $x /= $x results in 1
    $x->bone();			# "fixes" also sign of $y, since $x is $y
    }
  else
    {
    # correct $y's sign again
    $y->{sign} =~ tr/+-/-+/;
    # continue with normal div code:

    # make copy of $x in case of list context for later reminder calculation
    if (wantarray && $y_not_one)
      {