view release on metacpan or  search on metacpan

lib/App/GnuCash/MembershipUtils.pm  view on Meta::CPAN

##----------------------------------------------------------------------------
## :mode=perl:indentSize=2:tabSize=2:noTabs=true:
##****************************************************************************
## NOTES:
##  * Before comitting this file to the repository, ensure Perl Critic can be
##    invoked at the HARSH [3] level with no errors
##****************************************************************************
package App::GnuCash::MembershipUtils;

use strict;
use warnings;
use YAML::XS;
use GnuCash::Schema;
use DBD::SQLite;
use Exporter qw( import );
use File::Slurp;
use Data::Dump qw( pp );
use Readonly;
use Carp qw( carp );

our @EXPORT_OK = qw(
    db_accounts_to_hash
    get_all_members
    get_config
    get_gnucash_filename
    max_length
    open_gnucash
    title_case
    validate_accounts_in_config
);

our %EXPORT_TAGS = (
    all    => [ @EXPORT_OK ],
    config => [ qw(
        get_config
        get_gnucash_filename
        validate_accounts_in_config
    )],
    db     => [ qw(
        db_accounts_to_hash
        get_all_members
        open_gnucash
    )],
    other  => [qw(
        max_length
        title_case
    )],
);


Readonly::Scalar my $EXPECTED_INVOICE_ACCOUNT_TYPE => "RECEIVABLE";
Readonly::Scalar my $EXPECTED_ITEM_ACCOUNT_TYPE    => "INCOME";


Readonly::Hash my %DEFAULT_CONFIG_VALUES => (
    format => "us",
    memo   => "Monthly membership dues",
);

## Version string
our $VERSION = qq{0.01};

=head1 NAME

App::GnuCash::MembershipUtils - A group of perl modules and scripts to help in
using L<GnuCash|https://www.gnucash.org/> for membership.

=head1 DESCRIPTION

App::GnuCash::MembershipUtils is a group of perl modules and scripts to help in
using L<GnuCash|https://www.gnucash.org/> for membership.

It assumes all customers are members, and uses the customer "notes" field to 
determine what type of membership for each member / customer.

=head1 VERSION

Version 0.01

=head1 SYNOPSIS

    use App::GnuCash::MembershipUtils qw( :all );


=cut

=head1 PUBLIC FUNCTIONS

=cut

=head2 get_config($filename)

    my ($error, $config) = get_config($filename);

Returns an C<$error> if the given C<$filename> cannot be opened.
If there is no C<$error> then C<$config> will be a HASHREF with the
config.

=cut

sub get_config {
    my $filename = shift // "";
    my $debug    = shift // 0;
    $filename    =~ s/^\s+|\s+$//g;

    return ("filename cannot be empty", undef) unless length($filename);

    return ("filename '$filename' does not exist", undef) unless -f $filename;

    $YAML::XS::ForbidDuplicateKeys = 1;
    my $config = Load(scalar(read_file($filename)));
    my @errors;

    # Now we have a hash, let's make sure it has what we need
    if (exists($config->{MembershipTypes})) {
        if (exists($config->{MembershipTypes}{default})) {
            my $error = _validate_membership_type_config($config->{MembershipTypes}{default}, 1);
            if ($error) {
                push(@errors, "The 'MembershipTypes.default' section $error"); 
            }
            if (my $others = $config->{MembershipTypes}{others}) {
                 my $idx;
                 for my $type (@$others) {
                    $idx++;
                    if (my $error = _validate_membership_type_config($type)) {
                        push(@errors, "The 'MembershipTypes.others' entry $idx $error"); 
                    }
                 }
            }
        } else {
            push(@errors, "Missing 'MembershipTypes.default' section");
        }
    } else {
        push(@errors, "Missing 'MembershipTypes' section");
    }
    if (@errors) {
        my $error = sprintf(
            "The config has the following %s\n  * %s",
            ((scalar(@errors) == 1) ? "error" : "errors"),
            join("\n  * ", @errors),
        );
        return ($error, $config);
    }
    if ($debug) {
        printf STDERR "Before applying defaults\n%s\n", pp( $config );
    }

    ## Load defaults
    for my $key (keys %DEFAULT_CONFIG_VALUES) {
        ## Only load them if the current key is undefined
        $config->{GnuCash}{$key} //= $DEFAULT_CONFIG_VALUES{$key};    
    }
    
    if ($debug) {
        printf STDERR "After applying defaults\n%s\n", pp( $config );
    }

    return (undef, $config);
}

=head2 get_gnucash_filename($override, $config)

    my $filename = get_filename_from_config($override, $config);

Returns the C<GnuCash.file> from the given C<$config>.

=cut

sub get_gnucash_filename {
    my $override = shift // "";
    my $config   = shift // {};

    return $override if length($override);
    if (exists($config->{GnuCash})) {
        return $config->{GnuCash}{file} // "";
    }
    return "";
}

=head2 open_gnucash($filename)

    my ($error, $schema) = open_gnucash($filename);

Returns an C<$error> if the given C<$filename> cannot be opened.
If C<$error> is undef, then C<$schema> will be a C<GnuCash::Schema>

lib/App/GnuCash/MembershipUtils.pm  view on Meta::CPAN

Returns the maximum length of the strings in the arguments provided.

=cut

sub max_length {
    my @strings = @_;

    my $max = 0;

    for my $string (@strings) {
        my $len = length($string);

        $max = $len if ($len > $max);
    }

    return $max;
}

=head2 db_accounts_to_hash($schema)

    my $accounts = db_accounts_to_hash($schema);

Returns a HASHREF whose keys are the complete name of each
account, and whose keys are as follows:

=over

=item account_type

=item hidden

=item placeholder

=back

=cut

sub db_accounts_to_hash {
    my $schema = shift;
    my %accounts;

    my $rs = $schema->resultset('Account')->search(
        {
            # parent_guid IS NOT NULL
            parent_guid => { '!=' => undef, },           
        },
        {
            columns => [qw( name account_type hidden placeholder guid parent_guid )],
        }
    );

    while (my $account = $rs->next) {
        my $full_name = $account->complete_name;
        $accounts{$full_name} = { $account->get_columns };
    }

    return \%accounts;
}

=head2 validate_accounts_in_config($args)

    my ($errors, $warnings) = validate_accounts_in_config($args);
    warn $warnings if ($warnings);
    die $errors if ($errors);

Accepts a HASHREF of C<$args> whose keys are as follows:

=over

=item config

=item schema

=back

Returns C<$errors> which is a string indicating fatal errors, and
C<$warnings> which is a non-fatal error.

=cut

sub validate_accounts_in_config {
    my $args   = shift;
    my $schema = delete $args->{schema};
    my $config = delete $args->{config};
    my $debug  = delete $args->{debug} // 0;

    my $accounts = db_accounts_to_hash($schema);
    my @errors;
    my @warnings;
    if (exists($config->{GnuCash})) {
        my $config_account = $config->{GnuCash}{account};
        if (my $gc_account = $accounts->{$config_account}) {
            if ($gc_account->{account_type} ne $EXPECTED_INVOICE_ACCOUNT_TYPE) {
                _warning_account_type(
                    \@warnings,
                    "'GnuCash.account'",
                    $gc_account,
                    $EXPECTED_INVOICE_ACCOUNT_TYPE,
                );
            } elsif ($gc_account->{hidden} || $gc_account->{placeholder}) {
                _error_hidden_or_placeholder_account(
                    \@errors,
                    "'GnuCash.account'",
                );
            }
        } else {
            _error_invalid_account(\@errors, "'GnuCash.account'");
        }
    } else {
        push(@errors, "Missing 'GnuCash' section");
    }
    if (exists($config->{MembershipTypes})) {
        if (exists($config->{MembershipTypes}{default})) {
            my $error = _validate_membership_type_config($config->{MembershipTypes}{default}, 1);
            if ($error) {
                push(@errors, "The 'MembershipTypes.default' section $error"); 
            } else {
                my $config_account = $config->{MembershipTypes}{default}{account};
                if (my $gc_account = $accounts->{$config_account}) {
                    if ($gc_account->{account_type} ne $EXPECTED_ITEM_ACCOUNT_TYPE) {
                        _warning_account_type(
                            \@warnings,
                            "'MembershipTypes.default.account'",
                            $gc_account,,
                            $EXPECTED_ITEM_ACCOUNT_TYPE,
                        );
                    } elsif ($gc_account->{hidden} || $gc_account->{placeholder}) {
                        _error_hidden_or_placeholder_account(
                            \@errors,
                            "'MembershipTypes.default'",
                        );
                    }
                } else {
                    _error_invalid_account(\@errors, "'MembershipTypes.default'");
                }
            }
            if (my $others = $config->{MembershipTypes}{others}) {
                 my $idx;
                 for my $type (@$others) {
                    $idx++;
                    my $section = "'MembershipTypes.others' entry $idx";
                    my $config_account = $type->{account};
                    if (my $gc_account = $accounts->{$config_account}) {
                        if ($gc_account->{account_type} ne $EXPECTED_ITEM_ACCOUNT_TYPE) {
                            _warning_account_type(
                                \@warnings,
                                $section,
                                $gc_account,
                                $EXPECTED_ITEM_ACCOUNT_TYPE,
                            );
                        } elsif ($gc_account->{hidden} || $gc_account->{placeholder}) {
                            _error_hidden_or_placeholder_account(
                                \@errors,
                                $section,
                            );
                        }
                    } else {
                        _error_invalid_account(\@errors, $section);
                    }
                 }
            }
        } else {
            push(@errors, "Missing 'MembershipTypes.default' section");
        }
    } else {
        push(@errors, "Missing 'MembershipTypes' section");
    }
    my $error_string;
    if (@errors) {
        $error_string = sprintf(
            "The config has the following fatal %s\n  * %s",
            ((scalar(@errors) == 1) ? "error" : "errors"),
            join("\n  * ", @errors),
        );
    }
    my $warning_string;
    if (@warnings) {
        $warning_string = sprintf(
            "The config has the following non-fatal %s\n  * %s",
            ((scalar(@warnings) == 1) ? "error" : "errors"),
            join("\n  * ", @warnings),
        );
    }

    return ($error_string, $warning_string);
}

sub _warning_account_type {
    my $warnings = shift;
    my $section  = shift;
    my $account  = shift;
    my $type     = shift;

    push(
        @$warnings, 
        sprintf(
            "The %s account type is '%s' but should be '%s'",
            $section,
            $account->{account_type},
            $type,
        )
    );
}

sub _error_hidden_or_placeholder_account {
    my $errors  = shift;
    my $section = shift;
    push(
        @$errors, 
        sprintf(
            "The %s account cannot be hidden, or a placeholder.",
            $section,
        )
    );
}
sub _error_invalid_account {
    my $errors  = shift;
    my $section = shift;

    push(
        @$errors, 
        sprintf(
            "The %s account could not be found.",
            $section,
        )
    );
}

sub _validate_membership_type_config {
    my $config        = shift // {};
    my $default_type  = shift // 0;
    my @required_keys = qw( account amount name );
    push(@required_keys, qw( match )) unless $default_type;
    my @missing;
    my $invalid_amount;

    for my $key (@required_keys) {
        if (exists($config->{$key}) && defined($config->{$key})) {
            if ($key eq 'amount') {
                my $value       = $config->{$key};
                $invalid_amount = $value unless ($value =~ m/^\d+\.\d{2}$/);
            }
        } else {
            push(@missing, $key) 
        }
    }

    # Now generate the return string
    my $error = (
        (   @missing
            ? sprintf("is missing the following: '%s'", join("', '", @missing))
            : ""
        )
    );
    if ($invalid_amount) {
        $error .= " and " if ($error);
        $error .= sprintf(
            "the 'amount' '%s' is invalid, and should be in the form 'X.XX'",
            $invalid_amount,
        );
    }
    return $error;
}


=head1 CONFIG FILE FORMAT

This module supports reading a L<YAML|https://yaml.org/> based config file.

=head2 SAMPLE

Here is a sample config file:

    ---
    GnuCash:
      file:    /path/to/organization.gnucash
      format:  US
      memo:    Monthly membership dues
      account: Assets:Accounts Receivable

    MembershipTypes:
      default:
        name:    Standard Membership
        account: Income:Membership Dues
        amount:  30.00
      others:
        - name:    Special Membership
          match:   Special
          account: Income:Membership Dues