File Coverage

blib/lib/Data/Str2Num.pm

Criterion	Covered	Total	%
statement	25	117	21.3
branch	0	86	0.0
condition	0	30	0.0
subroutine	9	13	69.2
pod	3	5	60.0
total	37	251	14.7

#!perl
#
# The copyright notice and plain old documentation (POD)
# are at the end of this file.
#
package  Data::Str2Num;

use strict;
use 5.001;
use warnings;
use warnings::register;

#####
# Connect up with the event log.
#
use vars qw( $VERSION $DATE $FILE);
$VERSION = '0.08';
$DATE = '2004/05/22';
$FILE = __FILE__;

use vars qw(@ISA @EXPORT_OK);
require Exporter;
@ISA=('Exporter');
@EXPORT_OK = qw(str2float str2int str2integer);

use Data::Startup;

use vars qw($default_options);
$default_options = new();

######
# Provide a way to module wide configure
#
sub config
{
     shift if UNIVERSAL::isa($_[0],__PACKAGE__);
     $default_options = new() unless $default_options;
     $default_options->config(@_);
}


#######
# Object used to set default, startup, options values.
#
sub new
{
   Data::Startup->new(

      ######
      # Make Test variables visible to tech_config
      #
      ascii_float => 0
   );

}


######
# Covert a string to floats.
#
sub str2float
{
     shift if UNIVERSAL::isa($_[0],__PACKAGE__);
     return '',() unless @_;

     $default_options = Data::Str2Num->new() unless ref($default_options);
     my $options = $default_options->override(pop @_) if ref($_[-1]);

     #########
     # Drop leading empty strings
     #
     my @strs = @_;
     while (@strs && $strs[0] !~ /^\s*\S/) {
          shift @strs;
     }
     @strs = () unless(@strs); # do not shift @strs out of existance

     my @floats = ();
     my $early_exit unless wantarray;
     my ($sign,$integer,$fraction,$exponent);
     foreach (@strs) {
         next unless defined $_;
         while ( length($_) ) {

             ($sign, $integer,$fraction,$exponent) = ('',undef,undef,undef);

             #######
             # Parse the integer part
             #
             if($_  =~ s/^\s*(-?)\s*(0[0-7]+|0?b[0-1]+|0x[0-9A-Fa-f]+)\s*[,;\n]?//) {
                 $integer = 0+oct($1 . $2);
                 $sign = $1 if $integer =~ s/^\s*-//;
             }
             elsif ($_ =~ s/^\s*(-?)\s*([0-9]+)\s*[,;\n]?//) {
                 ($sign,$integer) = ($1,$2);
             }

             ######
             # Parse the decimal part
             #
             $fraction = $1 if $_ =~ s/^\.([0-9]+)\s*[,;\n]?// ;

             ######
             # Parse the exponent part
             $exponent = $1 . $2 if $_ =~ s/^E(-?)([0-9]+)\s*[,;\n]?//;

             goto LAST unless defined($integer) || defined($fraction) || defined($exponent);

             $integer = '' unless defined($integer);
             $fraction = '' unless defined($fraction);
             $exponent = 0 unless defined($exponent);

             if($options->{ascii_float} ) {
                 $integer .= '.' . $fraction if( $fraction);
                 $integer .= 'E' . $exponent if( $exponent);
                 push @floats,$sign . $integer;
             }
             else {
                 ############
                 # Normalize decimal float so that there is only one digit to the
                 # left of the decimal point.
                 #
                 while($integer  && substr($integer,0,1) == 0) {
                    $integer = substr($integer,1);
                 }
                 if( $integer ) {
                     $exponent += length($integer) - 1;
                 }
                 else {
                     while($fraction && substr($fraction,0,1) == 0) {
                         $fraction = substr($fraction,1);
                         $exponent--;
                     }
                     $exponent--;
                 }
                 $integer .= $fraction;
                 while($integer  && substr($integer,0,1) == 0) {
                    $integer = substr($integer,1);
                 }
                 $integer = 0 unless $integer;
                 push @floats,[$sign . $integer,  $exponent];
             }
             goto LAST if $early_exit;
         }
         last if $early_exit;
     }

LAST:
     #########
     # Drop leading empty strings
     #
     while (@strs && $strs[0] !~ /^\s*\S/) {
          shift @strs;
     }
     @strs = () unless(@strs); # do not shift @strs out of existance

     return (\@strs, @floats) unless $early_exit;
     ($integer,$fraction,$exponent) = @{$floats[0]};
     "${integer}${fraction}E${exponent}"
}



######
# Convert number (oct, bin, hex, decimal) to decimal
#
sub str2int
{
     shift if UNIVERSAL::isa($_[0],__PACKAGE__);
     ####
     # do no let the wantarray kink in
     my $num = str2integer(@_);
     $num;
}



######
# Convert number (oct, bin, hex, decimal) to decimal
#
sub str2integer
{
     shift  if UNIVERSAL::isa($_[0],__PACKAGE__);
     unless( wantarray ) {
         return undef unless(defined($_[0]));
         my $str = $_[0];
         return 0+oct($1) if($str =~ /^\s*(-?\s*0[0-7]+|0?b[0-1]+|0x[0-9A-Fa-f]+)\s*[,;\n]?$/);
         return 0+$1 if ($str =~ /^\s*(-?\s*[0-9]+)\s*[,;:\n]?$/ );
         return undef;
     }

     #######
     # Pick up input strings
     #
     return [],() unless @_;

     $default_options = Data::Str2num->new() unless ref($default_options);
     my $options = $default_options->override(pop @_) if ref($_[-1]);
     my @strs = @_;

     #########
     # Drop leading empty strings
     #
     while (@strs && $strs[0] !~ /^\s*\S/) {
          shift @strs;
     }
     @strs = () unless(@strs); # do not shift @strs out of existance

     my ($int,$num);
     my @integers = ();
     foreach $_ (@strs) {
         next unless defined $_;
         while ( length($_) ) {
             if($_  =~ s/^\s*(-?)\s*(0[0-7]+|0?b[0-1]+|0x[0-9A-Fa-f]+)\s*[,;\n]?//) {
                 $int = $1 . $2;
                 $num = 0+oct($int);
             }
             elsif ($_ =~ s/^\s*(-?)\s*([0-9]+)\s*[,;\n]?// ) {
                 $int = $1 . $2;
                 $num = 0+$int;

             }
             else {
                 goto LAST;
             }

             #######
             # If the integer is so large that Perl converted it to a float,
             # repair the str so that the large integer may be dealt as a string
             # or converted to a float. The using routine may be using Math::BigInt
             # instead of using the native Perl floats and this automatic conversion
             # would cause major damage.
             #
             if($num =~ /\s*[\.E]\d+/) {
                 $_ = $int;
                 goto LAST;
             }

             #######
             # If there is a string float instead of an int  repair the str to
             # perserve the float. The using routine may decide to use str2float
             # to parse out the float.
             #
             elsif($_ =~ /^\s*[\.E]\d+/) {
                 $_ = $int . $_;
                 goto LAST;
             }
             push @integers,$num;
         }
     }

LAST:
     #########
     # Drop leading empty strings
     #
     while (@strs && (!defined($strs[0]) || $strs[0] !~ /^\s*\S/)) {
          shift @strs;
     }
     @strs = ('') unless(@strs); # do not shift @strs out of existance

     (\@strs, @integers);
}

1

__END__