File Coverage

blib/lib/Number/Denominal.pm

Criterion	Covered	Total	%
statement	85	85	100.0
branch	43	46	93.4
condition	18	20	90.0
subroutine	12	12	100.0
pod	3	3	100.0
total	161	166	96.9

package Number::Denominal;

use strict;
use warnings;
use List::ToHumanString 1.002;
use Carp;
require Exporter;
our @ISA = qw(Exporter);
our @EXPORT = qw(denominal  denominal_hashref  denominal_list);

our $VERSION = '2.001001'; # VERSION

sub denominal {
    my ( $num, @den ) = @_;
    return _denominal( $num, \@den, 'string' );
}

sub denominal_list {
    my ( $num, @den ) = @_;
    return _denominal( $num, \@den, 'list' );
}

sub denominal_hashref {
    my ( $num, @den ) = @_;
    return _denominal( $num, \@den, 'hashref' );
}

sub _denominal {
    my ( $num, $den, $mode ) = @_;

    $num     =  abs $num;
    my $args = _prepare_extra_args( $den );
    $den     = _process_den( $mode, $den );

    my @bits;
    my $step = 1; # steps for precision, if enabled
    my $pre_bit;  # a "pre" bit, again for precision to handle rounding.
    my @ordered_bit_names; # need this for missing bits in denominal_list
    for my $bit ( _get_bits( @$den ) ) {
        push @ordered_bit_names, $bit->{name}[0];

        $bit->{num} = sprintf '%d', $num / $bit->{divisor};
        $num = $num - $bit->{num} * $bit->{divisor};

        if ( @bits
            and $args->{precision} and ++$step > $args->{precision}
        ) {
            last unless $bit->{num};

            # add current element and pre bit, for sake of calculations
            # I should really really refactor this crap to something sane
            unshift @bits, $pre_bit if defined $pre_bit;
            push @bits, +{ %$bit };

            for ( reverse 0 .. $#bits ) {
                # increase the previous number if we have to round
                $bits[$_-1]{num}++
                    if $bits[$_]{num} * $bits[$_]{divisor}
                        / $bits[$_-1]{divisor} >= 0.5;

                $bits[$_]{num} = 0
                    if $bits[$_]{num} * $bits[$_]{divisor}
                        / $bits[$_-1]{divisor} == 1;

                # stop checking previous numbers if we ran out of them
                # or they haven't reached their limit (divisor) yet.
                last if $_ == 0
                    or $bits[$_-1]{num} * $bits[$_-1]{divisor}
                        < $bits[$_-2]{divisor};
            }

            # pop last element off, since it was temporary
            pop @bits;

            # get rid of els with zero nums (including pre bit)
            @bits = grep $_->{num}, @bits;
            last;
        }

        $pre_bit = $bit unless $bit->{num};
        $bit->{num} or next; # don't insert the bit, if it's zero
        push @bits, +{ %$bit };
    }

    my @result;
    # process the bits into output format, depending on what type
    # ... of output is wanted
    for ( @bits ) {
        push @result, $mode eq 'hashref' ? ( $_->{name}[0] => $_->{num} )
            : $mode eq 'list' ? { num => $_->{num}, name => $_->{name}[0] }
                : $_->{num} . ' ' . $_->{name}[ $_->{num} == 1 ? 0 : 1 ];
    }

    if ( $mode eq 'list' ) {
        my @temp_result = @result;
        @result = ();
        my %bits_in_result;
        @bits_in_result{ map $_->{name}, @temp_result }
        = map $_->{num}, @temp_result;

        for ( @ordered_bit_names ) {
            push @result, exists $bits_in_result{ $_ }
                ? $bits_in_result{ $_ } : 0;
        }
    }

    return $mode eq 'hashref'
        ? +{@result} :
            $mode eq 'list'
                ? @result : to_human_string '|list|', @result;
}

sub _get_bits {
    my @den = @_;

    my @bits;
    my $divisor = 1;
    for ( grep !($_%2), 0..$#den ) {
        if ( not ref $den[ $_ ] ) {
            $den[ $_ ] = [
                $den[ $_ ],
                $den[ $_ ] . 's',
            ];
        }

        push @bits, {
            name    => $den[ $_ ],
            divisor => $divisor,
        };

        $divisor *= $den[ $_+1 ] || 1;
    }

    return reverse @bits;
}

sub _process_den {
    my ( $mode, $den ) = @_;

    if ( @$den == 1 and ref $den->[0] eq 'ARRAY' ) {
        my $idx = 0;
        @$den = map +( 'el' . $idx++ => $_ ), @{ $den->[0] };
        push @$den, 'el', $idx;
        $mode = 'list';
    }
    elsif ( @$den == 1 and ref $den->[0] eq 'SCALAR' ) {
        my $unit_shortcut = ${ $den->[0] };
        my $values_for_unit = _get_units()->{ $unit_shortcut };

        croak qq{Unknown unit shortcut ``$unit_shortcut''}
            unless $values_for_unit;
        $den = $values_for_unit;
    }

    return $den;
}

sub _prepare_extra_args {
    my $den = shift;

    return unless ref $den->[-1] eq 'HASH';

    my %extra_args = %{ delete $den->[-1] };

    if ( exists $extra_args{precision} ) {
        my $p = $extra_args{precision};
        croak q{precision argument takes positive integers only,}
            . q{ but its value is } . (defined $p ? $p : '[undefined]')
            unless $p and $p =~ /\A\d+\z/;
    }

    return \%extra_args;
}

sub _get_units {
    return {
        time    => [
            second => 60 => minute => 60 => hour => 24 => day => 7 => 'week'
        ],
        weight  => [
            gram => 1000 => kilogram => 1000 => 'tonne',
        ],
        weight_imperial => [
           ounce => 16 => pound => 14 => stone => 160 => 'ton',
        ],
        length  => [
           meter => 1000 => kilometer => 9_460_730_472.5808 => 'light year',
        ],
        length_mm  => [
           millimeter => 10 => centimeter => 100 => meter => 1000
                => kilometer => 9_460_730_472.5808 => 'light year',
        ],
        length_imperial => [
            [qw/inch  inches/] => 12 =>
                [qw/foot  feet/] => 3 => yard => 1760
                    => [qw/mile  miles/],
        ],
        volume => [
           milliliter => 1000 => 'Liter',
        ],
        volume_imperial => [
           'fluid ounce' => 20 => pint => 2 => quart => 4 => 'gallon',
        ],
        info => [
            bit => 8 => byte => 1000 => kilobyte => 1000 => megabyte => 1000
                => gigabyte => 1000 => terabyte => 1000 => petabyte => 1000
                    => exabyte => 1000 => zettabyte => 1000 => 'yottabyte',
        ],
        info_1024  => [
            bit => 8 => byte => 1024 => kibibyte => 1024 => mebibyte => 1024
                => gibibyte => 1024 => tebibyte => 1024 => pebibyte => 1024
                    => exbibyte => 1024 => zebibyte => 1024 => 'yobibyte',
        ],
    };
}

q|
  Q: how many programmers does it take to change a light bulb?
  A: none, that's a hardware problem
|;

__END__