File Coverage

lib/Math/String.pm

Criterion	Covered	Total	%
statement	179	205	87.3
branch	65	94	69.1
condition	10	23	43.4
subroutine	31	36	86.1
pod	25	25	100.0
total	310	383	80.9

#############################################################################
# Math/String.pm -- package which defines a base class for calculating
# with big integers that are defined by arbitrary char sets.
#
# Copyright (C) 1999 - 2008 by Tels.
#############################################################################

# see:
# http://www.xray.mpe.mpg.de/mailing-lists/perl5-porters/2000-05/msg00974.html
# http://www.xray.mpe.mpg.de/mailing-lists/perl5-porters/1999-02/msg00812.html

# the following hash values are used
# _set			  : ref to charset object
# sign, value, _a, _f, _p : from BigInt
# _cache		  : caches string form for speed

package Math::String;
my $class = "Math::String";

use Exporter;
use Math::BigInt;
@ISA = qw(Exporter Math::BigInt);
@EXPORT_OK = qw(
   as_number last first string from_number bzero bone binf bnan
  );
use Math::String::Charset;
use strict;
use vars qw($VERSION $AUTOLOAD $accuracy $precision $div_scale $round_mode);
$VERSION = '1.29';	# Current version of this package
require 5.008003;	# requires this Perl version or later

$accuracy   = undef;
$precision  = undef;
$div_scale  = 0;
$round_mode = 'even';

use overload
'cmp'   =>      sub {
 		 my $str = $_[0]->bstr();
 		 return undef if !defined $str;
 		 my $str1 = $_[1]; $str1 = $str1->bstr() if ref $str1;
 		 return undef if !defined $str1;
	        $_[2] ?  $str1 cmp $str : $str cmp $str1;
	        },
# can modify arg of ++ and --, so avoid a new-copy for speed
'++'    =>      \&binc,
'--'    =>      \&bdec,
;

my $CALC = 'Math::BigInt::Calc';

sub import
  {
  my $self = shift;

  $CALC = Math::BigInt->config()->{lib} || 'Math::BigInt::Calc';

  # register us with MBI to get notified of future lib changes
  Math::BigInt::_register_callback( $self, sub { $CALC = $_[0]; } );

  Math::BigInt::import($self, @_);
  }

sub string
  {
  # exportable version of new
  $class->new(@_);
  }

sub from_number
  {
  # turn an integer into a string object
  # catches also Math::String->from_number and make it work
  my $val = shift;

  $val = "" if !defined $val;
  $val = shift if !ref($val) && $val eq $class;
  my $set = shift;

  # make a new bigint (or copy the existing one)
  my $self = Math::BigInt->new($val);
  if (ref($set) && (
    ref($set) eq 'HASH' || UNIVERSAL::isa($set,'Math::String::Charset'))
   )
    {
    $self->bdiv($set->{_scale}) if defined $set->{_scale};  # input is scaled?
    }
  bless $self, $class;         					# rebless
  $self->_set_charset($set);
  $self;
  }

sub scale
  {
  # set/get the scale of the string (from the set)
  my $self = shift;

  $self->{_set}->scale(@_);
  }

sub bzero
  {
  my $self = shift;
  if (defined $self)
    {
    # $x->bzero();	(x) (M::S)
    # $x->bzero();	(x) (M::bi or something)
    $self = $self->SUPER::bzero();
    bless $self, $class if ref($self) ne $class;	# convert aka rebless
    }
  else
    {
    # M::S::bzero();	()
    $self = Math::BigInt->bzero();
    bless $self, $class;				# rebless
    $self->_set_charset(shift);
    }
  $self->{_cache} = undef;				# invalidate cache
  $self;
  }

sub bone
  {
  my $self = shift;
  if (defined $self)
    {
    # $x->bzero();	(x) (M::S)
    # $x->bzero();	(x) (M::bi or something)
    $self->SUPER::bone();
    bless $self, $class if ref($self) ne $class;	# convert aka rebless
    }
  else
    {
    # M::S::bzero(undef,charset);
    $self = Math::BigInt->bone();
    bless $self, __PACKAGE__;
    $self->_set_charset($_[0]);
    }
  my $min = $self->{_set}->minlen();
  $min = 1 if $min <= 0;
  $self->{_cache} = $self->{_set}->first($min);		# first of minlen
  $self;
  }

sub bnan
  {
  my $self = shift;
  if (defined $self)
    {
    # $x->bnan();	(x) (M::S)
    # $x->bnan();	(x) (M::bi or something)
    $self->SUPER::bnan();
    bless $self, $class if ref($self) ne $class;         # convert aka rebless
    }
  else
    {
    # M::S::bnan();	()
    $self = $class->SUPER::bnan();
    bless $self, __PACKAGE__;
    $self->_set_charset(shift);
    }
  $self->{_cache} = undef;
  $self;
  }

sub binf
  {
  my $self = shift;
  if (defined $self)
    {
    # $x->bzero();	(x) (M::S)
    # $x->bzero();	(x) (M::bi or something)
    $self->SUPER::binf(shift);
    bless $self, $class if ref($self) ne $class;         # convert aka rebless
    }
  else
    {
    # M::S::bzero();	()
    $self = $class->SUPER::binf(shift);
    bless $self, __PACKAGE__;
    $self->_set_charset(shift);
    }
  $self->{_cache} = undef;
  $self;
  }

###############################################################################
# constructor

sub new
  {
  my $class = shift;
  $class = ref($class) || $class;
  my $value = shift; $value = '' if !defined $value;

  my $self = {};
  if (ref($value) eq 'HASH')
    {
    $self = Math::BigInt->new($value->{num});	# number form
    bless $self, $class;			# rebless
    $self->_set_charset(shift);			# if given charset, copy over
    $self->bdiv($self->{_set}->{_scale})
      if defined $self->{_set}->{_scale};  	# input is scaled?
    $self->{_cache} = $value->{str};		# string form
    }
  elsif (ref($value))
    {
    $self = $value->copy(); 			# got an object, so make copy
    bless $self, $class;			# rebless
    $self->_set_charset(shift) if defined $_[0];# if given charset, copy over
    $self->{_cache} = undef;
    }
  else
    {
    bless $self, $class;
    $self->_set_charset(shift);			# if given charset, copy over
    $self->_initialize($value);
    }
  $self;
  }

sub _set_charset
  {
  # store reference to charset object, or make one if given array/hash ref
  # first method should be prefered for speed/memory reasons
  my $self = shift;
  my $cs = shift;

  $cs = ['a'..'z'] if !defined $cs;		# default a-z
  $cs = Math::String::Charset->new( $cs ) if ref($cs) =~ /^(ARRAY|HASH)$/;
  die "charset '$cs' is not a reference" unless ref($cs);
  $self->{_set} = $cs;
  $self;
  }

#############################################################################
# private, initialize self

sub _initialize
  {
  # set yourself to the value represented by the given string
  my $self = shift;
  my $value = shift;

  my $cs = $self->{_set};

  return $self->bnan() if !$cs->is_valid($value);

  my $int = $cs->str2num($value);
  if (!ref($int))
    {
    require Carp;
    Carp::croak ("$int is not a reference to a Big* object");
    }
  foreach my $c (keys %$int) { $self->{$c} = $int->{$c}; }

  $self->{_cache} = $cs->norm($value);		# caching normalized form
  $self;
  }

sub copy
  {
  # for speed reasons, do not make a copy of a charset, but share it instead
  my ($c,$x);
  if (@_ > 1)
    {
    # if two arguments, the first one is the class to "swallow" subclasses
    ($c,$x) = @_;
    }
  else
    {
    $x = shift;
    $c = ref($x);
    }
  return unless ref($x); # only for objects

  my $self = {}; bless $self,$c;
  foreach my $k (keys %$x)
    {
    my $ref = ref($x->{$k});
    if ($k eq 'value')
      {
      $self->{$k} = $CALC->_copy($x->{$k});
      }
    #elsif (ref($x->{$k}) eq 'SCALAR')
    elsif ($ref eq 'SCALAR')
      {
      $self->{$k} = \${$x->{$k}};
      }
    #elsif (ref($x->{$k}) eq 'ARRAY')
    elsif ($ref eq 'ARRAY')
      {
      $self->{$k} = [ @{$x->{$k}} ];
      }
    #elsif (ref($x->{$k}) eq 'HASH')
    elsif ($ref eq 'HASH')
      {
      # only one level deep!
      foreach my $h (keys %{$x->{$k}})
        {
        $self->{$k}->{$h} = $x->{$k}->{$h};
        }
      }
    #elsif (ref($x->{$k}) =~ /^Math::String::Charset/)
    elsif ($ref =~ /^Math::String::Charset/)
      {
      $self->{$k} = $x->{$k};           # for speed reasons share this
      }
    #elsif (ref($x->{$k}))
    elsif ($ref)
      {
      # my $c = ref($x->{$k});
      $self->{$k} = $ref->new($x->{$k});  # no copy() due to deep rec
      }
    else
      {
      $self->{$k} = $x->{$k};
      }
    }
  $self;
  }

sub charset
  {
  my $self = shift;
  $self->{_set};
  }

sub class
  {
  my $self = shift;
  $self->{_set}->class(@_);
  }

sub minlen
  {
  my $x = shift;
  $x->{_set}->minlen();
  }

sub maxlen
  {
  my $x = shift;
  $x->{_set}->minlen();
  }

sub length
  {
  # return number of characters in output
  my $x = shift;

  $x->{_set}->chars($x);
  }

sub bstr
  {
  my $x = shift;

  return $x unless ref $x;			# scalars get simple returned
  return undef if $x->{sign} !~ /^[+-]$/;	# short cut

  return $x->{_cache} if defined $x->{_cache};

  # num2str needs (due to overloading "$x-1") a Math::BigInt object, so make it
  # positively happy
  my $int = Math::BigInt->bzero();
  $int->{value} = $x->{value};
  $x->{_cache} = $x->{_set}->num2str($int);

  $x->{_cache};
  }

sub as_number
  {
  # return yourself as MBI
  my $self = shift;

  # make a copy of us and delete any specific (non-MBI) keys
  my $x = $self->copy();
  delete $x->{_cache};
  delete $x->{_set};
  bless $x, 'Math::BigInt';	# convert it to the new religion
  $x->bmul($self->{_set}->{_scale})
    if exists $self->{_set}->{_scale}; 	# scale it?
  $x;
  }

sub order
  {
  my $x = shift;
  $x->{_set}->order();
  }

sub type
  {
  my $x = shift;
  $x->{_set}->type();
  }

sub last
  {
  my $x = $_[0];
  if (!ref($_[0]) && $_[0] eq __PACKAGE__)
    {
    # Math::String length charset
    $x = Math::String->new('',$_[2]);	# Math::String->first(3,$set);
    }
  my $es = $x->{_set}->last($_[1]);
  $x->_initialize($es);
  }

sub first
  {
  my $x = $_[0];
  if (!ref($_[0]) && $_[0] eq __PACKAGE__)
    {
    # Math::String length charset
    $x = Math::String->new('',$_[2]);	# Math::String->first(3,$set);
    }
  my $es = $x->{_set}->first($_[1]);
  $x->_initialize($es);
  }

sub error
  {
  my $x = shift;
  $x->{_set}->error();
  }

sub is_valid
  {
  my $x = shift;

  # What does charset say to string?
  if (defined $x->{_cache})
    {
    # XXX TODO: cached string should always be valid?
    return $x->{_set}->is_valid($x->{_cache});
    }
  else
    {
    $x->{_cache} = $x->bstr();		# create cache
    }
  my $l = $x->length();
  return 0 if ($l < $x->minlen() || $l > $x->maxlen());
  1;					# all okay
  }

#############################################################################
# binc/bdec for caching

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

  # binc calls modify, and thus destroys the cache, so store it
  my $str = $x->{_cache};
  $x->SUPER::binc();

  # if old value cached and no rounding happens
 if ((defined $str)
#   && (!defined $a) && (!defined $p)
#   && (!defined $x->accuracy()) && (!defined $x->precision())
   )
    {
    $x->{_cache} = $str;		# restore cache
    $x->{_set}->next($x);		# update string cache
    }
  $x;
  }

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

  # bdec calls modify, and thus destroys the cache, so store it
  my $str = $x->{_cache};
  $x->SUPER::bdec();

  # if old value cached and no rounding happens
  if ((defined $str)
#   && (!defined $a) && (!defined $p)
 #  && (!defined $x->accuracy()) && (!defined $x->precision())
   )
    {
    $x->{_cache} = $str;		# restore cache
    $x->{_set}->prev($x);		# update string cache
    }
  $x;
  }

#############################################################################
# cache management

sub modify
  {
  $_[0]->{_cache} = undef;	# invalidate cache
  0;				# go ahead, modify
  }

__END__