File Coverage

blib/lib/Finance/Budget.pm

Criterion	Covered	Total	%
statement	45	294	15.3
branch	0	96	0.0
condition	0	26	0.0
subroutine	15	45	33.3
pod	4	5	80.0
total	64	466	13.7

package Finance::Budget;

use strict;
use warnings;
our $VERSION = '0.06';
{   use Carp;
    use Text::CSV;
    use Date::Manip;
    use File::Slurp;
}

sub new
{
    my ( $class, $param_hr ) = @_;

    croak sprintf 'usage: %s->new()', $class
        if ref $param_hr ne 'HASH';

    my %self = (
        days              => 365,
        currency_symbol   => '$',
        date_format       => '%m/%d/%Y',
        markup_callback   => sub { return $_[0]->{string} },
        opening_balance   => 0,
        transaction_types => [],
        exceptions        => [],
        recent_history    => [],
        categorizer       => {},
    );

    for my $opt (keys %{$param_hr})
    {
        croak sprintf '%s is not a recognized option among %s',
            $opt, ( join ',', keys %self )
            if not exists $self{$opt};

        my $type = ref $param_hr->{$opt};

        if ( !$type && stat $param_hr->{$opt} )
        {
            if ( $param_hr->{$opt} =~ m{ [.] csv \z}xmsi )
            {
                my @lines = File::Slurp::slurp( $param_hr->{$opt} );

                $param_hr->{$opt} = \@lines;
            }
            else
            {
                $param_hr->{$opt} = do $param_hr->{$opt};
            }

            $type = ref $param_hr->{$opt};

            if ( $type eq 'ARRAY' )
            {
                chomp @{ $param_hr->{$opt} };
            }
        }

        if ( ref $self{$opt} )
        {
            croak sprintf '%s should be of type %s ref',
                $opt, ( ref $self{$opt} )
                if $type ne ref $self{$opt};
        }
        elsif ( $self{$opt} =~ m{\A [%] }xms )
        {
            croak sprintf '%s should be a format string', $opt
                if $param_hr->{$opt} !~ m{ [%][a-z] }xmsi;
        }
        elsif ( $self{$opt} =~ m{\A \d }xms )
        {
            croak sprintf '%s should be a number', $opt
                if $param_hr->{$opt} !~ m{\A \d+ (?: [.] \d+ )? \z}xms;
        }

        $self{$opt} = $param_hr->{$opt};
    }

    croak 'there must be 1+ transaction types'
        if 0 == @{ $self{transaction_types} };

    croak 'there must be 1+ recent history for each transaction type'
        if @{ $self{recent_history} } < 1 + @{ $self{transaction_types} };

    $self{opening_balance} *= 100;    # dollars to cents

    _set_base_dates( \%self );

    _build_transactions( \%self );

    return bless \%self, $class;
}

sub get_last_occurences {
    my ($self) = @_;

    my %last_occurred;

    TYPE:
    for my $type_hr (@{ $self->{transaction_types} })
    {
        my $category   = $type_hr->{category};
        my $base_date  = $type_hr->{base_date};

        next TYPE
            if not $category;

        $last_occurred{$category} = $base_date->printf('%m/%d/%Y');
    }

    return \%last_occurred;
}

sub opening_balance
{
    my ($self) = @_;
    return _format_currency( $self->{opening_balance}, $self->{currency_symbol} );
}

sub next
{
    my ($self) = @_;

    return
        if not @{ $self->{transactions} };

    return shift @{ $self->{transactions} };
}

sub get_chokepoints
{
    my ($self) = @_;

    croak "no chokepoints encountered"
        if not exists $self->{chokepoints};

    return Finance::Budget::Chokepoints->new(
        {   chokepoints => $self->{chokepoints},
            markup      => $self->{markup_callback},
        }
    );
}

sub _set_base_dates
{
    my ($self) = @_;

    my %base_date_for
        = map { $_->{category} => 0 }
        grep { exists $_->{category} }
        @{ $self->{transaction_types} };

    if ( @{ $self->{recent_history} } )
    {
        my $csv = Text::CSV->new()
            || die sprintf "Text::CSV: %s\n",
                Text::CSV->error_diag();

        chomp @{ $self->{recent_history} };

        my @cols;
        {
            my ($header) = shift @{ $self->{recent_history} };

            $csv->parse(lc $header)
                || die sprintf "Text::CSV::parse %s\n",
                    Text::CSV->error_diag();

            @cols = $csv->fields();
        }

        croak "recent history CSV header must have a 'date' column"
            if 0 == grep { $_ eq 'date' } @cols;

        croak "recent history CSV header must have a 'description' column"
            if 0 == grep { $_ eq 'description' } @cols;

        my $categorize = sub {
            my ($event_hr) = @_;
            for my $category (sort keys %{ $self->{categorizer} })
            {
                my $categorizer = $self->{categorizer}->{$category};
                my $type = ref $categorizer;

                croak 'categorizer should be a %s or a %s',
                    'hash of array refs', 'hash of code refs'
                    if $type ne 'ARRAY' && $type ne 'CODE';

                if ( $type eq 'CODE' )
                {
                    return $category
                        if $categorizer->($event_hr);
                }
                else
                {
                    for my $regex (@{$categorizer})
                    {
                        return $category
                            if $event_hr->{description} =~ m/$regex/xmsi;
                    }
                }
            }

            TYPE:
            for my $type_hr ( @{ $self->{transaction_types} } )
            {
                my $category = $type_hr->{category};

                next TYPE
                    if exists $self->{categorizer}->{$category};

                my ( $amount, $cents ) = $type_hr->{amount} =~ m{
                    ( \d+ [.] ( \d+ ) )
                }xms;

                next TYPE
                    if not $cents;

                return $category
                    if 1 == grep { $amount eq $_ } values %{$event_hr};
            }

            return;
        };

        EVENT:
        for my $event_csv (@{ $self->{recent_history} })
        {
            $csv->parse($event_csv)
                || die sprintf "Text::CSV::parse %s\n",
                    Text::CSV->error_diag();

            my %event;
            @event{@cols} = $csv->fields();

            my $category = $categorize->( \%event ) // "";

            next EVENT
                if not $category;

            next EVENT
                if ref $base_date_for{$category};

            my $date = Date::Manip::Date->new();

            my $err = $date->parse($event{date});

            die sprintf "Date::Manip::Date::parse %s -- %s\n",
                $event{date}, $err
                if $err;

            $base_date_for{$category} = $date;
        }
    }

    EXC:
    for my $except_hr (@{ $self->{exceptions} })
    {
        my $category = $except_hr->{category};

        next EXC
            if ref $base_date_for{$category};

        my $date = Date::Manip::Date->new();

        my $err = $date->parse($except_hr->{date});

        die sprintf "Date::Manip::Date::parse %s -- %s\n",
            $except_hr->{date}, $err
            if $err;

        $base_date_for{$category} = $date;
    }

    CAT:
    for my $category (keys %base_date_for)
    {
        croak sprintf 'failed to find base date for %s in recent history',
            $category
            if not ref $base_date_for{$category};

        for my $type_hr (@{ $self->{transaction_types} })
        {
            if ( $type_hr->{category} eq $category )
            {
                $type_hr->{base_date} = $base_date_for{$category};

                next CAT;
            }
        }
    }

    return;
}

sub _build_transactions {
    my ($self) = @_;

    my $width = 0;
    my $balance = $self->{opening_balance};
    my ( %events_for, @transactions, @chokepoints );

    my $start_date = ParseDate('today');
    my $end_date   = DateCalc('today', sprintf '+%dD', $self->{days});

    my ($major_income)
        = map { $_->{category} }
        sort  { $b->{amount} <=> $a->{amount} }
        @{ $self->{transaction_types} };

    my ($major_payment)
        = map { $_->{category} }
        sort  { $a->{amount} <=> $b->{amount} }
        @{ $self->{transaction_types} };

    my %amount_for;

    for my $except_hr (@{ $self->{exceptions} })
    {
        for my $field ( keys %{$except_hr} )
        {
            croak "exceptions must have: { date, category, amount }"
                if not exists $except_hr->{$field};
        }

        my $date = Date::Manip::Date->new();

        my $err = $date->parse($except_hr->{date});

        die sprintf "Date::Manip::Date::parse %s -- %s\n",
            $except_hr->{date}, $err
            if $err;

        my $category = lc $except_hr->{category};

        $amount_for{ $date->printf("$category:%s") } = $except_hr->{amount};
    }

    my $find_amount_cr = sub {
        my ( $category, $epoch, $default ) = @_;

        my $exception_key = lc "$category:$epoch";

        return $amount_for{$exception_key}
            if exists $amount_for{$exception_key};

        return $default;
    };

    my $type_help
        = "transaction_types must have { category, amount, recurrence }";

    my $major_payment_hit = 0;

    for my $type_hr (@{ $self->{transaction_types} })
    {
        my $category   = $type_hr->{category} || die "$type_help\n";
        my $amount     = $type_hr->{amount} // die "$type_help\n";
        my $recurrence = $type_hr->{recurrence} || die "$type_help\n";
        my $base_date  = $type_hr->{base_date};

        $width = $width < length $category ? length $category : $width;

        my $recur = Date::Manip::Recur->new();

        $recur->parse( $recurrence, $base_date, $start_date, $end_date );

        my @dates = $recur->dates();

        for my $date (@dates)
        {
            my $epoch = $date->printf('%s');

            $amount = $find_amount_cr->(
                $type_hr->{category},
                $epoch,
                $type_hr->{amount},
            );

            $events_for{$epoch} //= [];

            push @{ $events_for{$epoch} },
                {   category    => $type_hr->{category},
                    cents       => ( 100 * $amount ),
                    date        => $date,
                };
        }
    }

    for my $epoch (sort { $a <=> $b } keys %events_for)
    {
        my @events
            = sort { $b->{cents} <=> $a->{cents} } @{ $events_for{$epoch} };

        for my $event_hr (@events)
        {
            if ( $event_hr->{category} eq $major_income )
            {
                if ( $major_payment_hit )
                {
                    my $past_hr = $transactions[-1]->{event};

                    push @chokepoints,
                        {   date        => $past_hr->{date},
                            date_str    => $past_hr->{date_str},
                            cents       => $balance,
                            balance     => $balance,
                            balance_str => _format_currency(
                                $balance,
                                $self->{currency_symbol}
                            ),
                        };
                }

                $major_payment_hit = 0;
            }
            elsif ( $event_hr->{category} eq $major_payment )
            {
                $major_payment_hit = 1;
            }

            $balance += $event_hr->{cents};

            push @transactions,
                Finance::Budget::Transaction->new(
                    {   event           => $event_hr,
                        balance         => $balance,
                        width           => $width,
                        date_format     => $self->{date_format},
                        markup          => $self->{markup_callback},
                        currency_symbol => $self->{currency_symbol},
                    }
                );
        }
    }

    $self->{chokepoints}  = \@chokepoints;
    $self->{transactions} = \@transactions;

    return;
}

sub _format_currency {
    my ($cents, $currency) = @_;

    my $sign = $cents < 0 ? '-' : '';

    $cents = abs $cents;

    my ( $dollars, $pennies );

    if ( $cents < 99 )
    {
        $dollars = substr 0, 1, sprintf '0.%02d', $cents;
        $dollars ||= '0.00';
    }
    else
    {
        $dollars = sprintf '%.2f', ( $cents / 100 );
    }

    return sprintf '% 10s', "${sign}${currency}${dollars}";
}

package Finance::Budget::Transaction;

use strict;
use warnings;
use overload (
    q{""} => \&_stringify,
    q{<}  => \&_lt,
    q{==} => \&_eq,
    q{!=} => sub { !_eq( @_ ) },
    q{>}  => sub { !_eq( @_ ) && !_lt( @_ ) },
);

sub new {
    my ($class, $conf_hr) = @_;

    $conf_hr->{width} += 1;

    $conf_hr->{event}->{date_str}
        = $conf_hr->{event}->{date}->printf($conf_hr->{date_format});

    $conf_hr->{event}->{title}
        = sprintf "% $conf_hr->{width}s", $conf_hr->{event}->{category};

    $conf_hr->{event}->{amount} = Finance::Budget::_format_currency(
        $conf_hr->{event}->{cents},
        $conf_hr->{currency_symbol}
    );

    $conf_hr->{event}->{balance} = $conf_hr->{balance};

    $conf_hr->{event}->{balance_str} = Finance::Budget::_format_currency(
        $conf_hr->{balance},
        $conf_hr->{currency_symbol}
    );

    $conf_hr->{event}->{string} = join ' ',
        @{ $conf_hr->{event} }{qw( date_str title amount balance_str )};

    return bless $conf_hr, $class;
}

sub get_date {
    my ($self) = @_;
    return $self->{event}->{date_str};
}

sub get_category {
    my ($self) = @_;
    return $self->{event}->{category};
}

sub get_amount {
    my ($self) = @_;
    return $self->{event}->{amount};
}

sub get_balance {
    my ($self) = @_;
    return $self->{balance_str};
}

sub _stringify {
    my ($self) = @_;

    return $self->{markup}->( $self->{event} )
        if $self->{markup};

    return $self->{event}->{string};
}

sub _lt {
    my ($self, $arg) = @_;
    return $self->{event}->{cents} < $arg;
}

sub _eq {
    my ($self, $arg) = @_;
    return $self->{event}->{cents} == $arg;
}


package Finance::Budget::Chokepoints;

use strict;
use warnings;
use Carp;

sub new
{
    my ($class, $param_hr) = @_;

    die "$class requires 'chokepoints' parameter"
        if not exists $param_hr->{chokepoints};

    return bless $param_hr, $class;
}

sub eye
{
    my ($self) = @_;

    croak 'no chokepoints encountered'
        if not @{ $self->{chokepoints} };

    my ($eye_hr)
        = sort { $a->{cents} <=> $b->{cents} } @{ $self->{chokepoints} };

    return Finance::Budget::Chokepoint->new(
        {   point  => $eye_hr,
            markup => $self->{markup},
        }
    );
}

sub next
{
    my ($self) = @_;

    return
        if not @{ $self->{chokepoints} };

    my $point_hr = shift @{ $self->{chokepoints} };

    return Finance::Budget::Chokepoint->new(
        {   point  => $point_hr,
            markup => $self->{markup},
        }
    );
}

package Finance::Budget::Chokepoint;

use strict;
use warnings;
use overload (
    q{""} => \&_stringify,
    q{<}  => \&_lt,
    q{==} => \&_eq,
    q{!=} => sub { !_eq( @_ ) },
    q{>}  => sub { !_eq( @_ ) && !_lt( @_ ) },
);

sub new
{
    my ( $class, $param_hr ) = @_;
    $param_hr->{point}->{string}
        = sprintf '%s %s', @{ $param_hr->{point} }{qw( date_str balance_str)};
    return bless $param_hr, $class;
}

sub _stringify
{
    my ($self) = @_;
    return $self->{markup}->( $self->{point} );
}

sub _lt {
    my ($self, $arg) = @_;
    return $self->{point}->{cents} < $arg;
}

sub _eq {
    my ($self, $arg) = @_;
    return $self->{point}->{cents} == $arg;
}


1;

__END__