File Coverage

blib/lib/Interchange6/Currency.pm

Criterion	Covered	Total	%
statement	91	92	98.9
branch	23	24	100.0
condition			n/a
subroutine	27	28	96.4
pod	12	12	100.0
total	153	156	98.7

package Interchange6::Currency;

=head1 NAME

Interchange6::Currency - Currency objects for Interchange 6

=head1 VERSION

0.100

=cut

our $VERSION = '0.100';

use Moo;
extends 'CLDR::Number::Format::Currency';

use Carp;
use Class::Load qw/load_class/;
use Math::BigFloat;
use Safe::Isa;
use Sub::Quote qw/quote_sub/;
use namespace::clean;
use overload
  '0+'  => sub { shift->value },
  '""'  => sub { shift->as_string },
  '+'   => \&_add,
  '-'   => \&_subtract,
  '*'   => \&_multiply,
  '/'   => \&_divide,
  '%'   => \&modulo,
  '<=>' => \&cmp_value,
  'cmp' => \&cmp,
  '='   => \&clone,
  ;

=head1 DESCRIPTION

Extends L with accurate calculation functions
using L.

Many useful standard operators are overloaded and return currency objects
if appropriate.

=head1 ATTRIBUTES

=head2 value

Value as simple decimal, e.g.: 3.45

All values are coerced into L.

=cut

has value => (
    is       => 'rwp',
    required => 1,
    coerce   => quote_sub(q{ $_[0]->$_isa("Math::BigFloat") ? $_[0] : Math::BigFloat->new( $_[0] ) }),
);

# check for currency objects with different currency codes and if arg
# is a currency object return its value
sub _clean_arg {
    my ( $self, $arg ) = @_;

    # uncoverable branch true
    croak "_clean_arg is a class method" unless $self->$_isa(__PACKAGE__);

    if ( $arg->$_isa(__PACKAGE__) ) {
        croak "Cannot perform calculation when currencies do not match"
          if $self->currency_code ne $arg->currency_code;
        return $arg->value;
    }
    return $arg;
}

=head2 converter_class

Defaults to L.

The class name which handles conversion to a new C.

The converter class can be any class that supports the following method
signature:

  sub convert {
      my ($self, $price, $from, $to) = @_;

      return $converted_price;
  };

=cut

has converter_class => (
    is  => 'ro',
    isa => quote_sub(q{ die "$_[0] is not a valid class name" unless ( ref(\$_[0]) eq 'SCALAR' && $_[0] =~ /^\S+$/ ) }),
    default => "Finance::Currency::Convert::WebserviceX",
);

=head2 converter

Vivified L.

=cut

has converter => (
    is       => 'lazy',
    isa      => quote_sub(q{ die "Not a valid converter class" unless $_[0]->$_can('convert') }),
    init_arg => undef,
);

sub _build_converter {
    my $self = shift;
    load_class( $self->converter_class );
    return $self->converter_class->new;
}

=head1 METHODS

=head2 BUILD

Sets precision for automatic rounding of L to
L.

=cut

sub BUILD {
    my $self = shift;

    # force cash trigger so we can reset precision on value
    $self->cash( $self->cash );
    $self->value->precision( -$self->maximum_fraction_digits );
}

=head2 clone %new_attrs?

Returns clone of the currency object possibly with new attribute values (if
any are supplied).

=cut

sub clone {
    my ( $self, %new_attrs ) = @_;
    return __PACKAGE__->new(
        value         => $self->value,
        currency_code => $self->currency_code,
        locale        => $self->locale,
        %new_attrs,
    );
}

=head2 convert $new_corrency_code

Convert to new currency using L.

B If C is called in void context then the currency object
is mutated in place. If called in list or scalar context then the original
object is not modified and a new L object is returned
instead.

=cut

sub convert {
    my ( $self, $new_code ) = @_;

    if ( $self->currency_code eq $new_code ) {

        # currency code has not changed
        if ( defined wantarray ) {

            # called in list or scalar context
            return $self->clone;
        }
        else {

            # void context
            return;
        }
    }
    else {

        # remove precision before conversion since new currency may have
        # different maximum_fraction_digits and we don't want to lose accuracy
        $self->value->precision(undef);

        # currency code has changed so convert via converter_class
        my $new_value =
          $self->converter->convert( $self->value, $self->currency_code,
            $new_code );

        croak "convert failed" unless defined $new_value;

        if ( defined wantarray ) {

            # called in list or scalar context

            return $self->clone(
                currency_code => $new_code,
                value         => $new_value,
            );
        }
        else {

            # void context

            $self->currency_code($new_code);
            $self->_set_value($new_value);

            # force cash trigger so we can reset precision on value
            $self->cash( $self->cash );
            $self->value->precision( -$self->maximum_fraction_digits );

            return;
        }
    }
}

=head2 as_string

Stringified formatted currency, e.g.: $3.45

=cut

sub as_string {
    return $_[0]->format( $_[0]->value );
}

=head2 stringify

Alias for L.

=cut

sub stringify {
    return $_[0]->as_string;
}

=head2 add $arg

Add C<$arg> to L in place.

=cut

sub add {
    my ( $self, $arg ) = @_;
    $self->value->badd( $self->_clean_arg($arg) );
}

# for overloaded '+'
sub _add {
    my ( $self, $arg ) = @_;
    $self->clone(
        value => $self->value->copy->badd( $self->_clean_arg($arg) ) );
}

=head2 subtract $arg

Subtract C<$arg> from L in place.

=cut

sub subtract {
    my ( $self, $arg ) = @_;
    $self->value->bsub( $self->_clean_arg($arg) );
}

# for overloaded '-'
sub _subtract {
    my ( $self, $arg, $swap ) = @_;
    my $result = $self->value->copy->bsub( $self->_clean_arg($arg) );
    $self->clone( value => $swap ? $result->bneg : $result );
}

=head2 multiply $arg

Multiply L by C<$arg> in place.

=cut

sub multiply {
    my ( $self, $arg ) = @_;
    $self->value->bmul( $self->_clean_arg($arg) );
}

# for overloaded '*'
sub _multiply {
    my ( $self, $arg ) = @_;
    $self->clone(
        value => $self->value->copy->bmul( $self->_clean_arg($arg) ) );
}

=head2 divide $arg

Divide L by C<$arg> in place.

=cut

sub divide {
    my ( $self, $arg ) = @_;
    $self->value->bdiv( $self->_clean_arg($arg) );
}

# for overloaded '/'
sub _divide {
    my ( $self, $arg, $swap ) = @_;
    my $result;
    if ($swap) {
        $result =
          Math::BigFloat->new( $self->_clean_arg($arg) )->bdiv( $self->value );
    }
    else {
        $result = $self->value->copy->bdiv( $self->_clean_arg($arg) );
    }
    $self->clone( value => $result );
}

=head2 modulo $arg

Return L C<%> C<$arg> as currency object.

=cut

sub modulo {
    my ( $self, $arg, $swap ) = @_;
    my $result;
    if ($swap) {
        $result =
          Math::BigFloat->new( $self->_clean_arg($arg) )->bmod( $self->value );
    }
    else {
        $result = $self->value->copy->bmod( $self->_clean_arg($arg) );
    }
    $self->clone( value => $result );
}

=head2 cmp_value $arg

Equivalent to L C<< <=> >> C<$arg>.

=cut

sub cmp_value {
    my ( $self, $arg, $swap ) = @_;
    if ($swap) {
        return Math::BigFloat->new( $self->_clean_arg($arg) )
          ->bcmp( $self->value );
    }
    else {
        return $self->value->bcmp( $self->_clean_arg($arg) );
    }
}

=head2 cmp $arg

String comparison.

Not always useful in itself since string comparison of stringified currency
objects might not produce what you expect depending on locale and currency
code.

=cut

sub cmp {
    my ( $self, $arg, $swap ) = @_;
    if ($swap) {
        return "$arg" cmp "$self";
    }
    else {
        return "$self" cmp "$arg";
    }
}

1;