bigfloat.pm

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

  my ($self,$x) = ref($_[0]) ? (undef,$_[0]) : objectify(1,@_);
  $x->bsstr(); 
  }

##############################################################################
# public stuff (usually prefixed with "b")

sub bneg
  {
  # (BINT or num_str) return BINT
  # negate number or make a negated number from string
  my ($self,$x) = ref($_[0]) ? (undef,$_[0]) : objectify(1,@_);

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

  # for +0 dont negate (to have always normalized +0). Does nothing for 'NaN'
  $x->{sign} =~ tr/+-/-+/ unless ($x->{sign} eq '+' && $MBI->_is_zero($x->{_m}));
  $x;
  }

# tels 2001-08-04 
# XXX TODO this must be overwritten and return NaN for non-integer values
# band(), bior(), bxor(), too
#sub bnot
#  {
#  $class->SUPER::bnot($class,@_);
#  }

sub bcmp 
  {
  # Compares 2 values.  Returns one of undef, <0, =0, >0. (suitable for sort)

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

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

  if (($x->{sign} !~ /^[+-]$/) || ($y->{sign} !~ /^[+-]$/))
    {
    # handle +-inf and NaN
    return undef if (($x->{sign} eq $nan) || ($y->{sign} eq $nan));
    return 0 if ($x->{sign} eq $y->{sign}) && ($x->{sign} =~ /^[+-]inf$/);
    return +1 if $x->{sign} eq '+inf';
    return -1 if $x->{sign} eq '-inf';
    return -1 if $y->{sign} eq '+inf';
    return +1;
    }

  # check sign for speed first
  return 1 if $x->{sign} eq '+' && $y->{sign} eq '-';	# does also 0 <=> -y
  return -1 if $x->{sign} eq '-' && $y->{sign} eq '+';	# does also -x <=> 0

  # shortcut 
  my $xz = $x->is_zero();
  my $yz = $y->is_zero();
  return 0 if $xz && $yz;				# 0 <=> 0
  return -1 if $xz && $y->{sign} eq '+';		# 0 <=> +y
  return 1 if $yz && $x->{sign} eq '+';			# +x <=> 0

  # adjust so that exponents are equal
  my $lxm = $MBI->_len($x->{_m});
  my $lym = $MBI->_len($y->{_m});
  # the numify somewhat limits our length, but makes it much faster
  my ($xes,$yes) = (1,1);
  $xes = -1 if $x->{_es} ne '+';
  $yes = -1 if $y->{_es} ne '+';
  my $lx = $lxm + $xes * $MBI->_num($x->{_e});
  my $ly = $lym + $yes * $MBI->_num($y->{_e});
  my $l = $lx - $ly; $l = -$l if $x->{sign} eq '-';
  return $l <=> 0 if $l != 0;
  
  # lengths (corrected by exponent) are equal
  # so make mantissa equal length by padding with zero (shift left)
  my $diff = $lxm - $lym;
  my $xm = $x->{_m};		# not yet copy it
  my $ym = $y->{_m};
  if ($diff > 0)
    {
    $ym = $MBI->_copy($y->{_m});
    $ym = $MBI->_lsft($ym, $MBI->_new($diff), 10);
    }
  elsif ($diff < 0)
    {
    $xm = $MBI->_copy($x->{_m});
    $xm = $MBI->_lsft($xm, $MBI->_new(-$diff), 10);
    }
  my $rc = $MBI->_acmp($xm,$ym);
  $rc = -$rc if $x->{sign} eq '-';		# -124 < -123
  $rc <=> 0;
  }

sub bacmp 
  {
  # Compares 2 values, ignoring their signs. 
  # Returns one of undef, <0, =0, >0. (suitable for sort)
  
  # set up parameters
  my ($self,$x,$y) = (ref($_[0]),@_);
  # objectify is costly, so avoid it
  if ((!ref($_[0])) || (ref($_[0]) ne ref($_[1])))
    {
    ($self,$x,$y) = objectify(2,@_);
    }

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

  # handle +-inf and NaN's
  if ($x->{sign} !~ /^[+-]$/ || $y->{sign} !~ /^[+-]$/)
    {
    return undef if (($x->{sign} eq $nan) || ($y->{sign} eq $nan));
    return 0 if ($x->is_inf() && $y->is_inf());
    return 1 if ($x->is_inf() && !$y->is_inf());
    return -1;
    }

  # shortcut 
  my $xz = $x->is_zero();
  my $yz = $y->is_zero();
  return 0 if $xz && $yz;				# 0 <=> 0
  return -1 if $xz && !$yz;				# 0 <=> +y
  return 1 if $yz && !$xz;				# +x <=> 0

  # adjust so that exponents are equal
  my $lxm = $MBI->_len($x->{_m});
  my $lym = $MBI->_len($y->{_m});
  my ($xes,$yes) = (1,1);
  $xes = -1 if $x->{_es} ne '+';
  $yes = -1 if $y->{_es} ne '+';
  # the numify somewhat limits our length, but makes it much faster
  my $lx = $lxm + $xes * $MBI->_num($x->{_e});
  my $ly = $lym + $yes * $MBI->_num($y->{_e});
  my $l = $lx - $ly;
  return $l <=> 0 if $l != 0;
  
  # lengths (corrected by exponent) are equal
  # so make mantissa equal-length by padding with zero (shift left)
  my $diff = $lxm - $lym;
  my $xm = $x->{_m};		# not yet copy it
  my $ym = $y->{_m};
  if ($diff > 0)
    {
    $ym = $MBI->_copy($y->{_m});
    $ym = $MBI->_lsft($ym, $MBI->_new($diff), 10);
    }
  elsif ($diff < 0)
    {
    $xm = $MBI->_copy($x->{_m});
    $xm = $MBI->_lsft($xm, $MBI->_new(-$diff), 10);
    }
  $MBI->_acmp($xm,$ym);
  }

sub badd 
  {
  # add second arg (BFLOAT or string) to first (BFLOAT) (modifies first)
  # return result as BFLOAT

  # 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('badd');

  # inf and NaN handling
  if (($x->{sign} !~ /^[+-]$/) || ($y->{sign} !~ /^[+-]$/))
    {
    # NaN first
    return $x->bnan() if (($x->{sign} eq $nan) || ($y->{sign} eq $nan));
    # inf handling
    if (($x->{sign} =~ /^[+-]inf$/) && ($y->{sign} =~ /^[+-]inf$/))
      {
      # +inf++inf or -inf+-inf => same, rest is NaN
      return $x if $x->{sign} eq $y->{sign};
      return $x->bnan();
      }
    # +-inf + something => +inf; something +-inf => +-inf
    $x->{sign} = $y->{sign}, return $x if $y->{sign} =~ /^[+-]inf$/;
    return $x;
    }

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

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

  # speed: no add for 0+y or x+0
  return $x->bround(@r) if $y->is_zero();		# x+0
  if ($x->is_zero())					# 0+y
    {
    # make copy, clobbering up x (modify in place!)
    $x->{_e} = $MBI->_copy($y->{_e});
    $x->{_es} = $y->{_es};
    $x->{_m} = $MBI->_copy($y->{_m});
    $x->{sign} = $y->{sign} || $nan;
    return $x->round(@r);
    }
 
  # take lower of the two e's and adapt m1 to it to match m2
  my $e = $y->{_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}, $y->{_es} || '+', $x->{_es});

  my $add = $MBI->_copy($y->{_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 $y->{sign})
    {
    # add
    $x->{_m} = $MBI->_add($x->{_m}, $add);
    }
  else
    {
    ($x->{_m}, $x->{sign}) = 
     _e_add($x->{_m}, $add, $x->{sign}, $y->{sign});
    }

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

# sub bsub is inherited from Math::BigInt!

sub binc
  {
  # increment arg by one
  my ($self,$x,@r) = ref($_[0]) ? (ref($_[0]),@_) : objectify(1,@_);

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

  if ($x->{_es} eq '-')
    {
    return $x->badd($self->bone(),@r);	#  digits after dot
    }

  if (!$MBI->_is_zero($x->{_e}))		# _e == 0 for NaN, inf, -inf
    {
    # 1e2 => 100, so after the shift below _m has a '0' as last digit
    $x->{_m} = $MBI->_lsft($x->{_m}, $x->{_e},10);	# 1e2 => 100
    $x->{_e} = $MBI->_zero();				# normalize
    $x->{_es} = '+';
    # we know that the last digit of $x will be '1' or '9', depending on the
    # sign
    }
  # now $x->{_e} == 0
  if ($x->{sign} eq '+')
    {
    $MBI->_inc($x->{_m});
    return $x->bnorm()->bround(@r);
    }
  elsif ($x->{sign} eq '-')
    {
    $MBI->_dec($x->{_m});
    $x->{sign} = '+' if $MBI->_is_zero($x->{_m}); # -1 +1 => -0 => +0
    return $x->bnorm()->bround(@r);
    }
  # inf, nan handling etc
  $x->badd($self->bone(),@r);			# badd() does round 
  }

sub bdec
  {
  # decrement arg by one
  my ($self,$x,@r) = ref($_[0]) ? (ref($_[0]),@_) : objectify(1,@_);

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

  if ($x->{_es} eq '-')
    {
    return $x->badd($self->bone('-'),@r);	#  digits after dot
    }

  if (!$MBI->_is_zero($x->{_e}))
    {
    $x->{_m} = $MBI->_lsft($x->{_m}, $x->{_e},10);	# 1e2 => 100
    $x->{_e} = $MBI->_zero();				# normalize
    $x->{_es} = '+';
    }
  # now $x->{_e} == 0
  my $zero = $x->is_zero();
  # <= 0
  if (($x->{sign} eq '-') || $zero)
    {
    $MBI->_inc($x->{_m});
    $x->{sign} = '-' if $zero;				# 0 => 1 => -1
    $x->{sign} = '+' if $MBI->_is_zero($x->{_m});	# -1 +1 => -0 => +0
    return $x->bnorm()->round(@r);
    }
  # > 0
  elsif ($x->{sign} eq '+')
    {
    $MBI->_dec($x->{_m});
    return $x->bnorm()->round(@r);
    }
  # inf, nan handling etc
  $x->badd($self->bone('-'),@r);		# does round
  } 

sub DEBUG () { 0; }

sub blog
  {
  my ($self,$x,$base,$a,$p,$r) = ref($_[0]) ? (ref($_[0]),@_) : objectify(1,@_);

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

  # $base > 0, $base != 1; if $base == undef default to $base == e
  # $x >= 0

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

  # also takes care of the "error in _find_round_parameters?" case
  return $x->bnan() if $x->{sign} ne '+' || $x->is_zero();

  # 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
    $params[1] = undef;			# P = undef
    $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
    }

  return $x->bzero(@params) if $x->is_one();
  # base not defined => base == Euler's number e
  if (defined $base)
    {
    # make object, since we don't feed it through objectify() to still get the
    # case of $base == undef
    $base = $self->new($base) unless ref($base);
    # $base > 0; $base != 1
    return $x->bnan() if $base->is_zero() || $base->is_one() ||
      $base->{sign} ne '+';
    # if $x == $base, we know the result must be 1.0
    if ($x->bcmp($base) == 0)
      {
      $x->bone('+',@params);
      if ($fallback)
        {
        # clear a/p after round, since user did not request it
        delete $x->{_a}; delete $x->{_p};
        }
      return $x;
      }
    }

  # when user set globals, they would interfere with our calculation, so
  # disable them and later re-enable them
  no strict 'refs';
  my $abr = "$self\::accuracy"; my $ab = $$abr; $$abr = undef;
  my $pbr = "$self\::precision"; my $pb = $$pbr; $$pbr = undef;
  # we also need to disable any set A or P on $x (_find_round_parameters took
  # them already into account), since these would interfere, too
  delete $x->{_a}; delete $x->{_p};
  # need to disable $upgrade in BigInt, to avoid deep recursion
  local $Math::BigInt::upgrade = undef;
  local $Math::BigFloat::downgrade = undef;

  # upgrade $x if $x is not a BigFloat (handle BigInt input)
  # XXX TODO: rebless!
  if (!$x->isa('Math::BigFloat'))
    {
    $x = Math::BigFloat->new($x);
    $self = ref($x);
    }
  
  my $done = 0;

  # If the base is defined and an integer, try to calculate integer result
  # first. This is very fast, and in case the real result was found, we can
  # stop right here.
  if (defined $base && $base->is_int() && $x->is_int())
    {
    my $i = $MBI->_copy( $x->{_m} );
    $MBI->_lsft( $i, $x->{_e}, 10 ) unless $MBI->_is_zero($x->{_e});
    my $int = Math::BigInt->bzero();
    $int->{value} = $i;
    $int->blog($base->as_number());
    # if ($exact)
    if ($base->as_number()->bpow($int) == $x)
      {
      # found result, return it
      $x->{_m} = $int->{value};
      $x->{_e} = $MBI->_zero();
      $x->{_es} = '+';
      $x->bnorm();
      $done = 1;
      }
    }

  if ($done == 0)
    {
    # base is undef, so base should be e (Euler's number), so first calculate the
    # log to base e (using reduction by 10 (and probably 2)):
    $self->_log_10($x,$scale);

    # and if a different base was requested, convert it
    if (defined $base)
      {
      $base = Math::BigFloat->new($base) unless $base->isa('Math::BigFloat');
      # not ln, but some other base (don't modify $base)
      $x->bdiv( $base->copy()->blog(undef,$scale), $scale );
      }
    }
 
  # shortcut to not run through _find_round_parameters again