File Coverage

blib/lib/Math/BaseArith.pm

Criterion	Covered	Total	%
statement	65	73	89.0
branch	17	26	65.3
condition	5	6	83.3
subroutine	9	9	100.0
pod	4	4	100.0
total	100	118	84.7

package Math::BaseArith;

use 5.006;
use strict;
use warnings;
use integer;
use Carp;

require Exporter;

our $VERSION = '1.04';

our $DEBUG = 0;     # set to 1 to enable debug printing

our @ISA = qw(Exporter);

# The primary functions of this module were originally named encode/decode.
# They were renamed encode_base and # decode_base as of version 1.02 so there
# would be less chance of them colliding with other encode/decode functions
# from other modules.  However, since they were exported by default, it was
# necessary to keep them (and their default export) so as not to introduce
# an incompatible change.  But, they can be turned off using !:old.
our @EXPORT = ( qw(encode decode) );

# use Math::BaseArith qw(:all !:old) to get encode_base/decode_base
# and to keep encode/decode out of the namespace.
our %EXPORT_TAGS = (
    'all' => [
        'encode_base',
        'decode_base',
        ],
    'old' => [
        'encode',
        'decode',
        ],
);

# use Math::BaseArith ( qw(!:old encode_base) ) to get just encode_base
our @EXPORT_OK = ( qw(
    encode_base
    decode_base
    encode
    decode
));

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

sub encode_base {
    my ($value, $b_aref) = @_;

	croak 'Function called in void context' unless defined wantarray;

	my @b_list = @{ $b_aref }; # copy the base value list
	my @r_list;
	my @radix_list = (1);

	print {*STDERR} "encode_base($value ,[@{ $b_aref }])"
		if $Math::BaseArith::DEBUG >= 1;

	my $r = 0;
	my $b = 1;

	# Compute the radix divisors from the base list, and put in reverse order
	# [1760,3,12] miles/yards/feet/inches becomes [63360,5280,1760]
	# [2,2,2,2] becomes [16,8,4,2]
	do {
		$b *= pop @b_list;
		unshift @radix_list, $b;
	} while @b_list;

	my $i = 0;
	foreach my $b (@radix_list) {
		$i++;
		if ($b > $value) {
			printf {*STDERR} "%10d%10d%10d%10d\n", $b,$value,$r,$value%$b
				if $Math::BaseArith::DEBUG >= 2;
			push @r_list, 0 if $i > 1;
			next;
		}
		$r = $b ? int($value/$b) : 0;
		printf {*STDERR} "%10d%10d%10d%10d\n", $b,$value,$r,$b?$value%$b:0 if $Math::BaseArith::DEBUG >= 2;
		push @r_list, $r;
		$value %= $b if $b;
	}

	shift @r_list while ( scalar(@r_list) > scalar( @{ $b_aref } ) );

	return wantarray ? @r_list : \@r_list;
}

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

sub decode_base {
    my ($r_aref, $b_aref) = @_;

	print {*STDERR} "decode_base( [ @{$r_aref} ],[ @{ $b_aref} ] )"
		if $Math::BaseArith::DEBUG >= 1;

	if ( scalar( @{ $r_aref } ) > scalar( @{ $b_aref } ) &&
		 scalar( @{ $b_aref} ) != 1 )
	{
		carp 'length error';
		return;
	}

	my $value = 0;
	my $bb = 1;
	my $base = 1;
	my $r;
	my @b_list = @{ $b_aref }; # copy the base value list
	my @r_list = @{ $r_aref }; # copy the representation value list

	do {
		$r = pop @r_list;
		$value += $r * $base;
		printf {*STDERR} "%10d%10d%10d%10d\n", $r,$b,$base,$value
			if $Math::BaseArith::DEBUG >= 2;
		$bb = pop @b_list || $bb;
		$base *= $bb;
	} while @r_list;

    return $value;
}

#######################################################################
# For signature compatibility with version < 1.02

sub encode { encode_base(@_) }
sub decode { decode_base(@_) }

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

1;
__END__