bigint.pm

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

  no strict 'refs';

  # now pick $a or $p, but only if we have got "arguments"
  if (!defined $a)
    {
    foreach ($self,@args)
      {
      # take the defined one, or if both defined, the one that is smaller
      $a = $_->{_a} if (defined $_->{_a}) && (!defined $a || $_->{_a} < $a);
      }
    }
  if (!defined $p)
    {
    # even if $a is defined, take $p, to signal error for both defined
    foreach ($self,@args)
      {
      # take the defined one, or if both defined, the one that is bigger
      # -2 > -3, and 3 > 2
      $p = $_->{_p} if (defined $_->{_p}) && (!defined $p || $_->{_p} > $p);
      }
    }
  # if still none defined, use globals (#2)
  $a = ${"$c\::accuracy"} unless defined $a;
  $p = ${"$c\::precision"} unless defined $p;
 
  # A == 0 is useless, so undef it to signal no rounding
  $a = undef if defined $a && $a == 0;
  
  # no rounding today? 
  return $self unless defined $a || defined $p;		# early out

  # set A and set P is an fatal error
  return $self->bnan() if defined $a && defined $p;

  $r = ${"$c\::round_mode"} unless defined $r;
  if ($r !~ /^(even|odd|\+inf|\-inf|zero|trunc|common)$/)
    {
    require Carp; Carp::croak ("Unknown round mode '$r'");
    }

  # now round, by calling either fround or ffround:
  if (defined $a)
    {
    $self->bround(int($a),$r) if !defined $self->{_a} || $self->{_a} >= $a;
    }
  else # both can't be undefined due to early out
    {
    $self->bfround(int($p),$r) if !defined $self->{_p} || $self->{_p} <= $p;
    }
  # bround() or bfround() already callled bnorm() if nec.
  $self;
  }

sub bnorm
  { 
  # (numstr or BINT) return BINT
  # Normalize number -- no-op here
  my ($self,$x) = ref($_[0]) ? (undef,$_[0]) : objectify(1,@_);
  $x;
  }

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

  return $x if $x->modify('babs');
  # post-normalized abs for internal use (does nothing for NaN)
  $x->{sign} =~ s/^-/+/;
  $x;
  }

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 '+' && $CALC->_is_zero($x->{value}));
  $x;
  }

sub bcmp 
  {
  # Compares 2 values.  Returns one of undef, <0, =0, >0. (suitable for sort)
  # (BINT or num_str, BINT or num_str) return cond_code
  
  # 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 

  # have same sign, so compare absolute values. Don't make tests for zero here
  # because it's actually slower than testin in Calc (especially w/ Pari et al)

  # post-normalized compare for internal use (honors signs)
  if ($x->{sign} eq '+') 
    {
    # $x and $y both > 0
    return $CALC->_acmp($x->{value},$y->{value});
    }

  # $x && $y both < 0
  $CALC->_acmp($y->{value},$x->{value});	# swaped acmp (lib returns 0,1,-1)
  }

sub bacmp 
  {
  # Compares 2 values, ignoring their signs. 
  # Returns one of undef, <0, =0, >0. (suitable for sort)
  # (BINT, BINT) return cond_code
  
  # 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)));

  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} =~ /^[+-]inf$/ && $y->{sign} =~ /^[+-]inf$/;
    return 1 if $x->{sign} =~ /^[+-]inf$/ && $y->{sign} !~ /^[+-]inf$/;
    return -1;
    }
  $CALC->_acmp($x->{value},$y->{value});	# lib does only 0,1,-1
  }

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

  # 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');
  return $upgrade->badd($upgrade->new($x),$upgrade->new($y),@r) if defined $upgrade &&
    ((!$x->isa($self)) || (!$y->isa($self)));

  $r[3] = $y;				# no push!
  # 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;
    }
    
  my ($sx, $sy) = ( $x->{sign}, $y->{sign} ); 		# get signs

  if ($sx eq $sy)  
    {
    $x->{value} = $CALC->_add($x->{value},$y->{value});	# same sign, abs add
    }
  else 
    {
    my $a = $CALC->_acmp ($y->{value},$x->{value});	# absolute compare
    if ($a > 0)                           
      {
      $x->{value} = $CALC->_sub($y->{value},$x->{value},1); # abs sub w/ swap
      $x->{sign} = $sy;
      } 
    elsif ($a == 0)
      {
      # speedup, if equal, set result to 0
      $x->{value} = $CALC->_zero();
      $x->{sign} = '+';
      }
    else # a < 0
      {
      $x->{value} = $CALC->_sub($x->{value}, $y->{value}); # abs sub
      }
    }
  $x->round(@r);
  }

sub bsub 
  {
  # (BINT or num_str, BINT or num_str) return BINT
  # subtract second arg from first, modify first
  
  # 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('bsub');

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

  return $x->round(@r) if $y->is_zero();

  # To correctly handle the lone special case $x->bsub($x), we note the sign
  # of $x, then flip the sign from $y, and if the sign of $x did change, too,
  # then we caught the special case:
  my $xsign = $x->{sign};
  $y->{sign} =~ tr/+\-/-+/; 	# does nothing for NaN
  if ($xsign ne $x->{sign})
    {
    # special case of $x->bsub($x) results in 0
    return $x->bzero(@r) if $xsign =~ /^[+-]$/;
    return $x->bnan();          # NaN, -inf, +inf
    }
  $x->badd($y,@r); 		# badd does not leave internal zeros
  $y->{sign} =~ tr/+\-/-+/; 	# refix $y (does nothing for NaN)
  $x;				# already rounded by badd() or no round nec.
  }

sub binc
  {
  # increment arg by one
  my ($self,$x,$a,$p,$r) = ref($_[0]) ? (ref($_[0]),@_) : objectify(1,@_);
  return $x if $x->modify('binc');

  if ($x->{sign} eq '+')
    {
    $x->{value} = $CALC->_inc($x->{value});
    return $x->round($a,$p,$r);
    }
  elsif ($x->{sign} eq '-')
    {
    $x->{value} = $CALC->_dec($x->{value});
    $x->{sign} = '+' if $CALC->_is_zero($x->{value}); # -1 +1 => -0 => +0
    return $x->round($a,$p,$r);
    }
  # inf, nan handling etc
  $x->badd($self->bone(),$a,$p,$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->{sign} eq '-')
    {
    # x already < 0
    $x->{value} = $CALC->_inc($x->{value});
    } 
  else
    {
    return $x->badd($self->bone('-'),@r) unless $x->{sign} eq '+'; 	# inf or NaN
    # >= 0
    if ($CALC->_is_zero($x->{value}))
      {
      # == 0
      $x->{value} = $CALC->_one(); $x->{sign} = '-';		# 0 => -1
      }
    else
      {
      # > 0
      $x->{value} = $CALC->_dec($x->{value});
      }
    }
  $x->round(@r);
  }

sub blog
  {
  # calculate $x = $a ** $base + $b and return $a (e.g. the log() to base
  # $base of $x)

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

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

  $base = $self->new($base) if defined $base && !ref $base;

  # inf, -inf, NaN, <0 => NaN
  return $x->bnan()
   if $x->{sign} ne '+' || (defined $base && $base->{sign} ne '+');

  return $upgrade->blog($upgrade->new($x),$base,@r) if 
    defined $upgrade;

  # fix for bug #24969:
  # the default base is e (Euler's number) which is not an integer
  if (!defined $base)
    {
    require Math::BigFloat;
    my $u = Math::BigFloat->blog(Math::BigFloat->new($x))->as_int();
    # modify $x in place
    $x->{value} = $u->{value};
    $x->{sign} = $u->{sign};
    return $x;
    }
  
  my ($rc,$exact) = $CALC->_log_int($x->{value},$base->{value});
  return $x->bnan() unless defined $rc;		# not possible to take log?
  $x->{value} = $rc;
  $x->round(@r);
  }

sub bnok
  {
  # Calculate n over k (binomial coefficient or "choose" function) as integer.
  # 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('bnok');
  return $x->bnan() if $x->{sign} eq 'NaN' || $y->{sign} eq 'NaN';
  return $x->binf() if $x->{sign} eq '+inf';

  # k > n or k < 0 => 0
  my $cmp = $x->bacmp($y);
  return $x->bzero() if $cmp < 0 || $y->{sign} =~ /^-/;
  # k == n => 1
  return $x->bone(@r) if $cmp == 0;

  if ($CALC->can('_nok'))
    {
    $x->{value} = $CALC->_nok($x->{value},$y->{value});
    }
  else
    {
    # ( 7 )    7!          7*6*5 * 4*3*2*1   7 * 6 * 5
    # ( - ) = --------- =  --------------- = ---------
    # ( 3 )   3! (7-3)!    3*2*1 * 4*3*2*1   3 * 2 * 1 

    # compute n - k + 2 (so we start with 5 in the example above)
    my $z = $x - $y;
    if (!$z->is_one())
      {
      $z->binc();
      my $r = $z->copy(); $z->binc();
      my $d = $self->new(2);
      while ($z->bacmp($x) <= 0)		# f < x ?
        {
        $r->bmul($z); $r->bdiv($d);
        $z->binc(); $d->binc();
        }
      $x->{value} = $r->{value}; $x->{sign} = '+';
      }
    else { $x->bone(); }
    }
  $x->round(@r);
  }

sub bexp
  {
  # Calculate e ** $x (Euler's number to the power of X), truncated to
  # an integer value.
  my ($self,$x,@r) = ref($_[0]) ? (ref($_[0]),@_) : objectify(1,@_);
  return $x if $x->modify('bexp');

  # inf, -inf, NaN, <0 => NaN
  return $x->bnan() if $x->{sign} eq 'NaN';
  return $x->bone() if $x->is_zero();
  return $x if $x->{sign} eq '+inf';
  return $x->bzero() if $x->{sign} eq '-inf';

  my $u;
  {
    # run through Math::BigFloat unless told otherwise
    require Math::BigFloat unless defined $upgrade;
    local $upgrade = 'Math::BigFloat' unless defined $upgrade;
    # calculate result, truncate it to integer
    $u = $upgrade->bexp($upgrade->new($x),@r);
  }

  if (!defined $upgrade)
    {
    $u = $u->as_int();
    # modify $x in place
    $x->{value} = $u->{value};
    $x->round(@r);
    }
  else { $x = $u; }
  }

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

  my $y = shift; my ($x);
  if (ref($y))
    {
    $x = $y->copy();
    }
  else
    {
    $x = $class->new($y);
    }
  my $self = ref($x);
  while (@_) 
    {
    my $y = shift; $y = $self->new($y) if !ref ($y);
    $x = __lcm($x,$y);
    } 
  $x;
  }

sub bgcd 
  { 
  # (BINT or num_str, BINT or num_str) return BINT
  # does not modify arguments, but returns new object
  # GCD -- Euclids algorithm, variant C (Knuth Vol 3, pg 341 ff)

  my $y = shift;
  $y = $class->new($y) if !ref($y);
  my $self = ref($y);
  my $x = $y->copy()->babs();			# keep arguments
  return $x->bnan() if $x->{sign} !~ /^[+-]$/;	# x NaN?