File Coverage

blib/lib/Math/Currency.pm

Criterion	Covered	Total	%
statement	148	164	90.2
branch	74	90	82.2
condition	20	60	33.3
subroutine	21	21	100.0
pod	12	13	92.3
total	275	348	79.0

#!/usr/bin/perl -w
# vim:ts=4:sw=4:et:at:
#
# PROGRAM:	Math::Currency.pm	# - 04/26/00 9:10:AM
# PURPOSE:	Perform currency calculations without floating point
#
#------------------------------------------------------------------------------
#   Copyright (c) 2001-2008 John Peacock
#
#   You may distribute under the terms of either the GNU General Public
#   License or the Artistic License, as specified in the Perl README file,
#   with the exception that it cannot be placed on a CD-ROM or similar media
#   for commercial distribution without the prior approval of the author.
#------------------------------------------------------------------------------

package Math::Currency;
$Math::Currency::VERSION = '0.53';
# ABSTRACT: Exact Currency Math with Formatting and Rounding

use strict;
use utf8;
use base qw(Exporter Math::BigFloat);
use Math::BigFloat 1.60;
use POSIX qw(locale_h);
use Encode::Locale;
use Encode ();

use overload '""' => \&bstr;

our $LC_MONETARY = {
    en_US => {
        INT_CURR_SYMBOL   => 'USD ',
        CURRENCY_SYMBOL   => '$',
        MON_DECIMAL_POINT => '.',
        MON_THOUSANDS_SEP => ',',
        MON_GROUPING      => '3',
        POSITIVE_SIGN     => '',
        NEGATIVE_SIGN     => '-',
        INT_FRAC_DIGITS   => '2',
        FRAC_DIGITS       => '2',
        P_CS_PRECEDES     => '1',
        P_SEP_BY_SPACE    => '0',
        N_CS_PRECEDES     => '1',
        N_SEP_BY_SPACE    => '0',
        P_SIGN_POSN       => '1',
        N_SIGN_POSN       => '1',
    },
};
$LC_MONETARY->{USD} = $LC_MONETARY->{en_US};

our $FORMAT = $LC_MONETARY->{en_US} unless localize();

our @EXPORT_OK = qw(
    $LC_MONETARY
    $FORMAT
    Money
);

# Set class constants
our $round_mode = 'even';    # Banker's rounding obviously
our $accuracy   = undef;
our $precision = $FORMAT->{FRAC_DIGITS} > 0 ? -$FORMAT->{FRAC_DIGITS} : 0;
our $div_scale = 40;
our $use_int   = 0;
our $always_init = 0;        # should the localize() happen every time?


sub new {
    my $proto  = shift;
    my $class  = ref($proto) || $proto;
    my $parent = $proto if ref($proto);

    my $value = shift || 0;

    if (eval("'1.01' ne 1.01")) { # this might be a comma locale
	$value =~ tr/,/./;
    }
    $value =~ tr/-()0-9.//cd;    #strip any formatting characters
    $value = "-$value" if $value =~ s/(^\()|(\)$)//g;    # handle parens

    if ( (caller)[0] =~ /Math\::BigInt/ )    # only when called from objectify()
    {
        return Math::BigFloat->new($value);
    }

    my $self;
    my $currency = shift;
    my $format;

    if ( not defined $currency and $class->isa('Math::Currency') ) {
        # must be one of our subclasses
        $currency = $1 if ($class =~ /Math::Currency::(\w+)/);
    }

    if ( defined $currency )    #override default currency type
    {
        unless ( defined $LC_MONETARY->{$currency} ) {
            eval "require Math::Currency::$currency";
            unknown_currency($currency) if $@;
        }
        $format = $LC_MONETARY->{$currency};
    }

    if ($format) {
        $self =
          Math::BigFloat->new( $value, undef, -( $format->{FRAC_DIGITS} + 2 ) );
        bless $self, $class;
        $self->format($format);
    }
    elsif ( $parent
        and defined $parent->{format} ) # if we are cloning an existing instance
    {
        $self =
          Math::BigFloat->new( $value, undef,
            -( $parent->format->{FRAC_DIGITS} + 2 ) );
        bless $self, $class;
        $self->format( $parent->format );
    }
    else {
        $self =
          Math::BigFloat->new( $value, undef, -( $FORMAT->{FRAC_DIGITS} + 2 ) );
        bless $self, $class;
    }
    return $self;
}    ##new


sub Money {
    return __PACKAGE__->new(@_);
}

sub bstr {
    my $self     = shift;
    my $myformat = $self->format();
    my $value    = $self->as_float();
    my $neg      = ( $value =~ tr/-//d );
    my $dp       = index( $value, "." );
    my $sign     = $neg
      ? $myformat->{NEGATIVE_SIGN}
      : $myformat->{POSITIVE_SIGN};
    my $curr = $use_int
      ? $myformat->{INT_CURR_SYMBOL}
      : $myformat->{CURRENCY_SYMBOL};
    my $digits = $use_int
      ? $myformat->{INT_FRAC_DIGITS}
      : $myformat->{FRAC_DIGITS};
    my $formtab = [
        [
            [ '($value$curr)',    '($value $curr)',    '($value $curr)' ],
            [ '$sign$value$curr', '$sign$value $curr', '$sign$value $curr' ],
            [ '$value$curr$sign', '$value $curr$sign', '$value$curr $sign' ],
            [ '$value$sign$curr', '$value $sign$curr', '$value$sign $curr' ],
            [ '$value$curr$sign', '$value $curr$sign', '$value$curr $sign' ],
        ],
        [
            [ '($curr$value)',    '($curr $value)',    '($curr $value)' ],
            [ '$sign$curr$value', '$sign$curr $value', '$sign $curr$value' ],
            [ '$curr$value$sign', '$curr $value$sign', '$curr$value $sign' ],
            [ '$sign$curr$value', '$sign$curr $value', '$sign $curr$value' ],
            [ '$curr$sign$value', '$curr$sign $value', '$curr $sign$value' ],
        ],
    ];

    if ( $dp < 0 ) {
        $value .= '.' . '0' x $digits;
    }
    elsif ( ( length($value) - $dp - 1 ) < $digits ) {
        $value .= '0' x ( $digits - $dp );
    }

    ( $value = reverse "$value" ) =~ s/\+//;

    # make sure there is a leading 0 for values < 1
    if ( substr( $value, -1, 1 ) eq '.' ) {
        $value .= "0";
    }
    $value =~ s/\./$myformat->{MON_DECIMAL_POINT}/;
    $value =~
s/(\d{$myformat->{MON_GROUPING}})(?=\d)(?!\d*\.)/$1$myformat->{MON_THOUSANDS_SEP}/g;
    $value = reverse $value;

    eval '$value = "'
      . (
          $neg
        ? $formtab->[ $myformat->{N_CS_PRECEDES} ][ $myformat->{N_SIGN_POSN} ]
          [ $myformat->{N_SEP_BY_SPACE} ]
        : $formtab->[ $myformat->{P_CS_PRECEDES} ][ $myformat->{P_SIGN_POSN} ]
          [ $myformat->{P_SEP_BY_SPACE} ]
      )
      . '"';

    if ( substr( $value, -1, 1 ) eq '.' ) {    # trailing bare decimal
        chop($value);
    }

    return $value;
}    ##stringify



sub format {
    my $self  = shift;
    my $key   = shift;    # do they want to display or set?
    my $value = shift;    # did they supply a value?
    localize() if $always_init;    # always reset the global format?
    my $source = \$FORMAT;         # default format rules

    if ( ref($self) ) {
        if ( defined $self->{format} ) {
            if ( defined $key and $key eq '' ) {
                delete $self->{format};
                $source = \$FORMAT;
            }
            else {
                $source = \$self->{format};
            }
        }
        elsif ( defined $key )     # get/set a parameter
        {
            if ( defined $value
                or ref($key) eq "HASH" )    # have to copy global format
            {
                while ( my ( $k, $v ) = each %{$FORMAT} ) {
                    $self->{format}{$k} = $v;
                }
                $source = \$self->{format};
            }
        }
    }
    else { # called as class method to set the default currency
        if (defined $key && not exists $FORMAT->{$key}) {
            unless (defined $LC_MONETARY->{$key}) {
                eval "require Math::Currency::$key";
                unknown_currency($key) if $@;
            }
            $FORMAT = $LC_MONETARY->{$key};
            return $FORMAT;
        }
    }


    if ( defined $key )                     # otherwise just return
    {
        if ( ref($key) eq "HASH" )          # must be trying to replace all
        {
            $$source = $key;
        }
        else                                # get/set just one parameter
        {
            return $$source->{$key} unless defined $value;
            $$source->{$key} = $value;
        }
    }
    return $$source;
}    ##format


sub as_float {
    my $self   = shift;
    my $format = $self->format;
    my $string = $self->copy->bfround( -$format->{FRAC_DIGITS} )->SUPER::bstr();
    return $string;
}


sub copy {
    my $self = shift;

    # grab the builtin formatting
    my $myformat = ( defined $self->{format} ? $self->{format} : undef );

    # let Math::BigFloat do it's thing
    my $new = $self->SUPER::copy(@_);

    if ($myformat) {

        # make sure we keep the original formatting
        $new->format($myformat);
    }

    # done...
    return $new;
}



sub as_int {
    my $self = shift;
    (my $str = $self->as_float) =~ s/\.//o;
    $str =~ s/^(\-?)0+/$1/o;
    return $str eq '' ? '0' : $str;
}

# we override the default here because we only want to compare the precision of
# the currency we're dealing with, not the precision of the underlying object
sub bcmp {
    # See RT #115247, #115761
    # bcmp() might get called in comparison overoad as an object method with
    # one arg, or, as a class method with two args depending on the version of
    # Math::BigInt that is installed. Workaround is to check if @_ has three
    # args, and if so, the first one is the class name.  Otherwise, the first
    # arg is the left side is an object that bcmp() is called on.
    # An alternate solution to this is to require Math::BigInt >= 1.999718
    # which always uses bcmp() as an object method.
    my $class = (@_ == 3) ? shift : __PACKAGE__;

    # make sure we're dealing with two Math::Currency objects
    my ( $x, $y ) =
        map { ref $_ ne $class ? $class->new($_) : $_ } @_[ 0, 1 ];

    return $x->as_float <=> $y->as_float;
}


sub localize {
    my $self   = shift;
    my $format = shift || \$FORMAT;

    my $localeconv = POSIX::localeconv();

    # localeconv()'s character encoding depends on the current locale setting,
    # so it is necessary to decode the currency symbol.
    Encode::Locale::reinit(); # neede in case locale was changed with setlocale()

    for my $key (keys %$localeconv) {
        # POSIX::localeconv() changed behaviour between 5.20 and 5.22.  As of
        # 5.22, it sets the UTF-8 flag for localeconv() returned data if hte
        # data is in UTF-8 format, so if POSIX::localeconv() already turned on
        # the UTF-8 flag, we should not decode the data.
        unless (utf8::is_utf8($$localeconv{$key})) {
            $$localeconv{$key} = Encode::decode(locale => $$localeconv{$key});
        }
    }

    # so you can test to see if locale was effective
    return 0 if ! exists $localeconv->{'currency_symbol'} || $localeconv->{'currency_symbol'} eq '';

    $$format = {
        INT_CURR_SYMBOL   => $localeconv->{'int_curr_symbol'}   || '',
        CURRENCY_SYMBOL   => $localeconv->{'currency_symbol'}   || '',
        MON_DECIMAL_POINT => $localeconv->{'mon_decimal_point'} || '',
        MON_THOUSANDS_SEP => $localeconv->{'mon_thousands_sep'} || '',
        MON_GROUPING      => (
            exists $localeconv->{'mon_grouping'}
              and defined $localeconv->{'mon_grouping'}
              and ord( $localeconv->{'mon_grouping'} ) < 47
            ? ord( $localeconv->{'mon_grouping'} )
            : $localeconv->{'mon_grouping'}
          )
          || 0,
        POSITIVE_SIGN   => $localeconv->{'positive_sign'}   || '',
        NEGATIVE_SIGN   => $localeconv->{'negative_sign'}   || '-',
        INT_FRAC_DIGITS => $localeconv->{'int_frac_digits'} || 0,
        FRAC_DIGITS     => $localeconv->{'frac_digits'}     || 0,
        P_CS_PRECEDES   => $localeconv->{'p_cs_precedes'}   || 0,
        P_SEP_BY_SPACE  => $localeconv->{'p_sep_by_space'}  || 0,
        N_CS_PRECEDES   => $localeconv->{'n_cs_precedes'}   || 0,
        N_SEP_BY_SPACE  => $localeconv->{'n_sep_by_space'}  || 0,
        P_SIGN_POSN     => $localeconv->{'p_sign_posn'}     || 1,
        N_SIGN_POSN     => $localeconv->{'n_sign_posn'}     || 0,
    };

    return 1;
}


{
    my $locales;
    sub available_locales {
        return if $^O =~ /Win32/; # cant run locale -a on windows

        unless (defined $locales) {
            $locales = [];

            open my $fh, '-|', 'locale -a' or die $!;

            while (my $locale = <$fh>) {
                chomp $locale;
                push @$locales, $locale;
            }

            close $fh;
        }

        return @$locales;
    }
}

# if no currency module exists for the requested currency, this function tries
# to find the currency settings from the available locales
sub unknown_currency {
    my ($currency) = @_;

    # remember current locale
    my $original_locale = setlocale( LC_ALL );

    # we need to save a copy of $VERSION here becuase the effective locale can
    # render $VERSION as X,YY instead of Y.YY for exmaple
    my $version = "$Math::Currency::VERSION";

    for my $LOCALE (available_locales()) {
        setlocale( LC_ALL, $LOCALE );
        my $localeconv = POSIX::localeconv();
        if ( $LOCALE eq $currency or
            ($localeconv->{int_curr_symbol} || '') =~ /$currency/ )
        {
            my $format = \$LC_MONETARY->{$currency};
            Math::Currency->localize($format);
            (my $int_curr = $$format->{INT_CURR_SYMBOL}) =~  s/ //g;
            $LC_MONETARY->{$int_curr} = $LC_MONETARY->{$currency}
                unless exists $LC_MONETARY->{$int_curr};
            eval <<"EOP";
package Math::Currency::${LOCALE};

use base 'Math::Currency';
our \$VERSION = $version;
our \$LANG  = '$LOCALE';

1;

package Math::Currency::${int_curr};

use base 'Math::Currency';

our \$VERSION = $version;
our \$LANG  = '$LOCALE';

1;
EOP
            last;
        }
    }

    # restore the original locale
    setlocale( LC_ALL, $original_locale );
}

# additional methods needed to get/set package globals


sub always_init {
    my $class = shift;

    if (@_) {
        $always_init = shift;
    }

    return $always_init;
}


sub use_int {
    my $class = shift;

    if (@_) {
        $use_int = shift;
    }

    return $use_int;
}

1;

__END__