bigint.pm

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

package Math::BigInt;

#
# "Mike had an infinite amount to do and a negative amount of time in which
# to do it." - Before and After
#

# The following hash values are used:
#   value: unsigned int with actual value (as a Math::BigInt::Calc or similiar)
#   sign : +,-,NaN,+inf,-inf
#   _a   : accuracy
#   _p   : precision
#   _f   : flags, used by MBF to flag parts of a float as untouchable

# Remember not to take shortcuts ala $xs = $x->{value}; $CALC->foo($xs); since
# underlying lib might change the reference!

my $class = "Math::BigInt";
use 5.006;

$VERSION = '1.88';

@ISA = qw(Exporter);
@EXPORT_OK = qw(objectify bgcd blcm); 

# _trap_inf and _trap_nan are internal and should never be accessed from the
# outside
use vars qw/$round_mode $accuracy $precision $div_scale $rnd_mode 
	    $upgrade $downgrade $_trap_nan $_trap_inf/;
use strict;

# Inside overload, the first arg is always an object. If the original code had
# it reversed (like $x = 2 * $y), then the third paramater is true.
# In some cases (like add, $x = $x + 2 is the same as $x = 2 + $x) this makes
# no difference, but in some cases it does.

# For overloaded ops with only one argument we simple use $_[0]->copy() to
# preserve the argument.

# Thus inheritance of overload operators becomes possible and transparent for
# our subclasses without the need to repeat the entire overload section there.

use overload
'='     =>      sub { $_[0]->copy(); },

# some shortcuts for speed (assumes that reversed order of arguments is routed
# to normal '+' and we thus can always modify first arg. If this is changed,
# this breaks and must be adjusted.)
'+='	=>	sub { $_[0]->badd($_[1]); },
'-='	=>	sub { $_[0]->bsub($_[1]); },
'*='	=>	sub { $_[0]->bmul($_[1]); },
'/='	=>	sub { scalar $_[0]->bdiv($_[1]); },
'%='	=>	sub { $_[0]->bmod($_[1]); },
'^='	=>	sub { $_[0]->bxor($_[1]); },
'&='	=>	sub { $_[0]->band($_[1]); },
'|='	=>	sub { $_[0]->bior($_[1]); },

'**='	=>	sub { $_[0]->bpow($_[1]); },
'<<='	=>	sub { $_[0]->blsft($_[1]); },
'>>='	=>	sub { $_[0]->brsft($_[1]); },

# not supported by Perl yet
'..'	=>	\&_pointpoint,

'<=>'	=>	sub { my $rc = $_[2] ?
                      ref($_[0])->bcmp($_[1],$_[0]) : 
                      $_[0]->bcmp($_[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]) : 
                      $_[0]->bcmp($_[1]);
		      # if there was a NaN involved, return false
		      return '' unless defined $rc;
		      $rc >= 0;
		},
'cmp'	=>	sub {
         $_[2] ? 
               "$_[1]" cmp $_[0]->bstr() :
               $_[0]->bstr() cmp "$_[1]" },

'cos'	=>	sub { $_[0]->copy->bcos(); }, 
'sin'	=>	sub { $_[0]->copy->bsin(); }, 
'atan2'	=>	sub { $_[2] ?
			ref($_[0])->new($_[1])->batan2($_[0]) :
			$_[0]->copy()->batan2($_[1]) },

# are not yet overloadable
#'hex'	=>	sub { print "hex"; $_[0]; }, 
#'oct'	=>	sub { print "oct"; $_[0]; }, 

# log(N) is log(N, e), where e is Euler's number
'log'	=>	sub { $_[0]->copy()->blog($_[1], undef); }, 
'exp'	=>	sub { $_[0]->copy()->bexp($_[1]); }, 
'int'	=>	sub { $_[0]->copy(); }, 
'neg'	=>	sub { $_[0]->copy()->bneg(); }, 
'abs'	=>	sub { $_[0]->copy()->babs(); },
'sqrt'  =>	sub { $_[0]->copy()->bsqrt(); },
'~'	=>	sub { $_[0]->copy()->bnot(); },

# for subtract it's a bit tricky to not modify b: b-a => -a+b
'-'	=>	sub { my $c = $_[0]->copy; $_[2] ?
			$c->bneg()->badd( $_[1]) :
			$c->bsub( $_[1]) },
'+'	=>	sub { $_[0]->copy()->badd($_[1]); },
'*'	=>	sub { $_[0]->copy()->bmul($_[1]); },

'/'	=>	sub { 
   $_[2] ? ref($_[0])->new($_[1])->bdiv($_[0]) : $_[0]->copy->bdiv($_[1]);
  }, 
'%'	=>	sub { 
   $_[2] ? ref($_[0])->new($_[1])->bmod($_[0]) : $_[0]->copy->bmod($_[1]);
  }, 
'**'	=>	sub { 
   $_[2] ? ref($_[0])->new($_[1])->bpow($_[0]) : $_[0]->copy->bpow($_[1]);
  }, 
'<<'	=>	sub { 
   $_[2] ? ref($_[0])->new($_[1])->blsft($_[0]) : $_[0]->copy->blsft($_[1]);
  }, 
'>>'	=>	sub { 
   $_[2] ? ref($_[0])->new($_[1])->brsft($_[0]) : $_[0]->copy->brsft($_[1]);
  }, 
'&'	=>	sub { 
   $_[2] ? ref($_[0])->new($_[1])->band($_[0]) : $_[0]->copy->band($_[1]);
  }, 
'|'	=>	sub { 
   $_[2] ? ref($_[0])->new($_[1])->bior($_[0]) : $_[0]->copy->bior($_[1]);
  }, 
'^'	=>	sub { 
   $_[2] ? ref($_[0])->new($_[1])->bxor($_[0]) : $_[0]->copy->bxor($_[1]);
  }, 

# can modify arg of ++ and --, so avoid a copy() for speed, but don't
# use $_[0]->bone(), it would modify $_[0] to be 1!
'++'	=>	sub { $_[0]->binc() },
'--'	=>	sub { $_[0]->bdec() },

# if overloaded, O(1) instead of O(N) and twice as fast for small numbers
'bool'  =>	sub {
  # this kludge is needed for perl prior 5.6.0 since returning 0 here fails :-/
  # v5.6.1 dumps on this: return !$_[0]->is_zero() || undef;		    :-(
  my $t = undef;
  $t = 1 if !$_[0]->is_zero();
  $t;
  },

# the original qw() does not work with the TIESCALAR below, why?
# Order of arguments unsignificant
'""' => sub { $_[0]->bstr(); },
'0+' => sub { $_[0]->numify(); }
;

##############################################################################
# global constants, flags and accessory

# These vars are public, but their direct usage is not recommended, use the
# accessor methods instead

$round_mode = 'even'; # one of 'even', 'odd', '+inf', '-inf', 'zero', 'trunc' or 'common'
$accuracy   = undef;
$precision  = undef;
$div_scale  = 40;

$upgrade = undef;			# default is no upgrade
$downgrade = undef;			# default is no downgrade

# These are internally, and not to be used from the outside at all

$_trap_nan = 0;				# are NaNs ok? set w/ config()
$_trap_inf = 0;				# are infs ok? set w/ config()
my $nan = 'NaN'; 			# constants for easier life

my $CALC = 'Math::BigInt::FastCalc';	# module to do the low level math
					# default is FastCalc.pm
my $IMPORT = 0;				# was import() called yet?
					# used to make require work
my %WARN;				# warn only once for low-level libs
my %CAN;				# cache for $CALC->can(...)
my %CALLBACKS;				# callbacks to notify on lib loads
my $EMU_LIB = 'Math/BigInt/CalcEmu.pm';	# emulate low-level math

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

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

BEGIN
  { 
  # tie to enable $rnd_mode to work transparently
  tie $rnd_mode, 'Math::BigInt'; 

  # set up some handy alias names
  *as_int = \&as_number;
  *is_pos = \&is_positive;
  *is_neg = \&is_negative;
  }

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

sub round_mode
  {
  no strict 'refs';
  # make Class->round_mode() work
  my $self = shift;
  my $class = ref($self) || $self || __PACKAGE__;
  if (defined $_[0])
    {
    my $m = shift;
    if ($m !~ /^(even|odd|\+inf|\-inf|zero|trunc|common)$/)
      {
      require Carp; Carp::croak ("Unknown round mode '$m'");
      }
    return ${"${class}::round_mode"} = $m;
    }
  ${"${class}::round_mode"};
  }

sub upgrade
  {
  no strict 'refs';
  # make Class->upgrade() work
  my $self = shift;
  my $class = ref($self) || $self || __PACKAGE__;
  # need to set new value?
  if (@_ > 0)
    {
    return ${"${class}::upgrade"} = $_[0];
    }
  ${"${class}::upgrade"};
  }

sub downgrade
  {
  no strict 'refs';
  # make Class->downgrade() work
  my $self = shift;
  my $class = ref($self) || $self || __PACKAGE__;
  # need to set new value?
  if (@_ > 0)
    {
    return ${"${class}::downgrade"} = $_[0];
    }
  ${"${class}::downgrade"};
  }

sub div_scale
  {
  no strict 'refs';
  # make Class->div_scale() work
  my $self = shift;
  my $class = ref($self) || $self || __PACKAGE__;
  if (defined $_[0])
    {
    if ($_[0] < 0)
      {
      require Carp; Carp::croak ('div_scale must be greater than zero');
      }
    ${"${class}::div_scale"} = $_[0];
    }
  ${"${class}::div_scale"};
  }

sub accuracy
  {
  # $x->accuracy($a);		ref($x)	$a
  # $x->accuracy();		ref($x)
  # Class->accuracy();		class
  # Class->accuracy($a);	class $a

  my $x = shift;
  my $class = ref($x) || $x || __PACKAGE__;

  no strict 'refs';
  # need to set new value?
  if (@_ > 0)
    {
    my $a = shift;
    # convert objects to scalars to avoid deep recursion. If object doesn't
    # have numify(), then hopefully it will have overloading for int() and
    # boolean test without wandering into a deep recursion path...
    $a = $a->numify() if ref($a) && $a->can('numify');

    if (defined $a)
      {
      # also croak on non-numerical
      if (!$a || $a <= 0)
        {
        require Carp;
	Carp::croak ('Argument to accuracy must be greater than zero');
        }
      if (int($a) != $a)
        {
        require Carp;
	Carp::croak ('Argument to accuracy must be an integer');
        }
      }
    if (ref($x))
      {
      # $object->accuracy() or fallback to global
      $x->bround($a) if $a;		# not for undef, 0
      $x->{_a} = $a;			# set/overwrite, even if not rounded
      delete $x->{_p};			# clear P
      $a = ${"${class}::accuracy"} unless defined $a;   # proper return value
      }
    else
      {
      ${"${class}::accuracy"} = $a;	# set global A
      ${"${class}::precision"} = undef;	# clear global P
      }
    return $a;				# shortcut
    }

  my $a;
  # $object->accuracy() or fallback to global
  $a = $x->{_a} if ref($x);
  # but don't return global undef, when $x's accuracy is 0!
  $a = ${"${class}::accuracy"} if !defined $a;
  $a;
  }

sub precision
  {
  # $x->precision($p);		ref($x)	$p
  # $x->precision();		ref($x)
  # Class->precision();		class
  # Class->precision($p);	class $p

  my $x = shift;
  my $class = ref($x) || $x || __PACKAGE__;

  no strict 'refs';
  if (@_ > 0)
    {
    my $p = shift;
    # convert objects to scalars to avoid deep recursion. If object doesn't
    # have numify(), then hopefully it will have overloading for int() and
    # boolean test without wandering into a deep recursion path...
    $p = $p->numify() if ref($p) && $p->can('numify');
    if ((defined $p) && (int($p) != $p))
      {
      require Carp; Carp::croak ('Argument to precision must be an integer');
      }
    if (ref($x))
      {
      # $object->precision() or fallback to global
      $x->bfround($p) if $p;		# not for undef, 0
      $x->{_p} = $p;			# set/overwrite, even if not rounded
      delete $x->{_a};			# clear A
      $p = ${"${class}::precision"} unless defined $p;  # proper return value
      }
    else
      {
      ${"${class}::precision"} = $p;	# set global P
      ${"${class}::accuracy"} = undef;	# clear global A
      }
    return $p;				# shortcut
    }

  my $p;
  # $object->precision() or fallback to global
  $p = $x->{_p} if ref($x);
  # but don't return global undef, when $x's precision is 0!
  $p = ${"${class}::precision"} if !defined $p;
  $p;
  }

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

  no strict 'refs';
  if (@_ > 1 || (@_ == 1 && (ref($_[0]) eq 'HASH')))
    {
    # try to set given options as arguments from hash

    my $args = $_[0];
    if (ref($args) ne 'HASH')
      {
      $args = { @_ };
      }
    # these values can be "set"
    my $set_args = {};
    foreach my $key (
     qw/trap_inf trap_nan
        upgrade downgrade precision accuracy round_mode div_scale/
     )
      {
      $set_args->{$key} = $args->{$key} if exists $args->{$key};
      delete $args->{$key};
      }
    if (keys %$args > 0)
      {
      require Carp;
      Carp::croak ("Illegal key(s) '",
       join("','",keys %$args),"' passed to $class\->config()");
      }
    foreach my $key (keys %$set_args)
      {
      if ($key =~ /^trap_(inf|nan)\z/)
        {
        ${"${class}::_trap_$1"} = ($set_args->{"trap_$1"} ? 1 : 0);
        next;
        }
      # use a call instead of just setting the $variable to check argument
      $class->$key($set_args->{$key});
      }
    }

  # now return actual configuration

  my $cfg = {
    lib => $CALC,
    lib_version => ${"${CALC}::VERSION"},
    class => $class,
    trap_nan => ${"${class}::_trap_nan"},
    trap_inf => ${"${class}::_trap_inf"},
    version => ${"${class}::VERSION"},
    };
  foreach my $key (qw/
     upgrade downgrade precision accuracy round_mode div_scale
     /)
    {
    $cfg->{$key} = ${"${class}::$key"};
    };
  if (@_ == 1 && (ref($_[0]) ne 'HASH'))
    {
    # calls of the style config('lib') return just this value
    return $cfg->{$_[0]};
    }
  $cfg;
  }

sub _scale_a
  { 
  # select accuracy parameter based on precedence,
  # used by bround() and bfround(), may return undef for scale (means no op)
  my ($x,$scale,$mode) = @_;

  $scale = $x->{_a} unless defined $scale;

  no strict 'refs';
  my $class = ref($x);

  $scale = ${ $class . '::accuracy' } unless defined $scale;
  $mode = ${ $class . '::round_mode' } unless defined $mode;

  if (defined $scale)
    {
    $scale = $scale->can('numify') ? $scale->numify() : "$scale" if ref($scale);
    $scale = int($scale);
    }

  ($scale,$mode);
  }

sub _scale_p
  { 
  # select precision parameter based on precedence,
  # used by bround() and bfround(), may return undef for scale (means no op)
  my ($x,$scale,$mode) = @_;
  
  $scale = $x->{_p} unless defined $scale;

  no strict 'refs';
  my $class = ref($x);