File Coverage

blib/lib/Finance/Bank/ID/Base.pm

Criterion	Covered	Total	%
statement	79	140	56.4
branch	29	64	45.3
condition	5	20	25.0
subroutine	9	20	45.0
pod	9	10	90.0
total	131	254	51.5

package Finance::Bank::ID::Base;

our $DATE = '2017-07-20'; # DATE
our $VERSION = '0.49'; # VERSION

use 5.010;
use Moo;
use Log::ger;

use Data::Dmp;

has mech        => (is => 'rw');
has username    => (is => 'rw');
has password    => (is => 'rw');
has logged_in   => (is => 'rw');
has accounts    => (is => 'rw');
has logger      => (is => 'rw',
                    default => sub { Log::ger->get_logger() } );
has logger_dump => (is => 'rw',
                    default => sub { Log::ger->get_logger() } );

has site => (is => 'rw');

has _req_counter => (is => 'rw', default => sub{0});

has verify_https => (is => 'rw', default => sub{0});
has https_ca_dir => (is => 'rw', default => sub{'/etc/ssl/certs'});
has https_host   => (is => 'rw');
has mode         => (is => 'rw', default => sub{''});
has save_dir     => (is => 'rw');

sub _fmtdate {
    my ($self, $dt) = @_;
    $dt->ymd;
}

sub _fmtdt {
    my ($self, $dt) = @_;
    $dt->datetime;
}

# strip non-digit characters
sub _stripD {
    my ($self, $s) = @_;
    $s =~ s/\D+//g;
    $s;
}

sub BUILD {
    my ($self, $args) = @_;

    # alias
    $self->username($args->{login}) if $args->{login} && !$self->username;
    $self->username($args->{user})  if $args->{user}  && !$self->username;
    $self->password($args->{pin})   if $args->{pin}   && !$self->password;
}

sub _set_default_mech {
    require Finance::BankUtils::ID::Mechanize;

    my ($self) = @_;
    $self->mech(
        Finance::BankUtils::ID::Mechanize->new(
            verify_https => $self->verify_https,
            https_ca_dir => $self->https_ca_dir,
            https_host   => $self->https_host,
        )
    );
}

sub _req {
    my ($self, $meth, $args, $opts) = @_;

    if (ref($opts) ne 'HASH') {
        die "Please update your module, 3rd arg is now a hashref since ".__PACKAGE__." 0.27";
    }

    $opts->{id} or die "BUG: Request does not have id";
    $opts->{id} =~ /\A[\w-]+\z/ or die "BUG: Invalid syntax in id '$opts->{id}'";

    $self->_set_default_mech unless $self->mech;
    my $mech = $self->mech;
    my $c = $self->_req_counter + 1;
    $self->_req_counter($c);
    $self->logger->debug("mech request #$c: $meth ".dmp($args)."");
    my $errmsg = "";

    eval {
        if ($self->mode eq 'simulation' &&
                $self->save_dir && (-f $self->save_dir . "/$opts->{id}.yaml")) {
            require YAML::Syck;
            $Finance::BankUtils::ID::Mechanize::saved_resp =
                YAML::Syck::LoadFile($self->save_dir . "/$opts->{id}.yaml");
        }
        $mech->$meth(@$args);
        if ($self->save_dir && $self->mode ne 'simulation') {
            require YAML::Syck;
            YAML::Syck::DumpFile($self->save_dir . "/$opts->{id}.yaml", $mech->response);
        }
    };
    my $evalerr = $@;

    eval {
        $self->logger_dump->debug(
            "<!-- result of mech request #$c ($meth ".dmp($args)."):\n".
            $mech->response->status_line."\n".
            $mech->response->headers->as_string."\n".
            "-->\n".
            $mech->content
            );
    };

    if ($evalerr) {
        # mech dies on error, we catch it so we can log it
        $errmsg = "die: $evalerr";
    } elsif (!$mech->success) {
        # actually mech usually dies if unsuccessful (see above), but
        # this is just in case
        $errmsg = "network error: " . $mech->response->status_line;
    } elsif ($opts->{after_request}) {
        $errmsg = $opts->{after_request}->($mech);
        $errmsg = "after_request check error: $errmsg" if $errmsg;
    }
    if ($errmsg) {
        $errmsg = "mech request #$c failed: $errmsg";
        $self->logger->fatal($errmsg);
        die $errmsg;
    }
}

sub login {
    die "Should be implemented by child";
}

sub logout {
    die "Should be implemented by child";
}

sub list_accounts {
    die "Should be implemented by child";
}

sub check_balance {
    die "Should be implemented by child";
}

sub get_balance { check_balance(@_) }

sub get_statement {
    die "Should be implemented by child";
}

sub check_statement { get_statement(@_) }

sub account_statement { get_statement(@_) }

sub parse_statement {
    my ($self, $page, %opts) = @_;
    my $status = 500;
    my $error = "";
    my $stmt = {};

    while (1) {
        my $err;
        if ($err = $self->_ps_detect($page, $stmt)) {
            $status = 400; $error = "Can't detect: $err"; last;
        }
        if ($err = $self->_ps_get_metadata($page, $stmt)) {
            $status = 400; $error = "Can't get metadata: $err"; last;
        }
        if ($err = $self->_ps_get_transactions($page, $stmt)) {
            $status = 400; $error = "Can't get transactions: $err"; last;
        }

        if (defined($stmt->{_total_debit_in_stmt})) {
            my $na = $stmt->{_total_debit_in_stmt};
            my $nb = 0;
            my $ntx = 0;
            for (@{ $stmt->{transactions} },
                 @{ $stmt->{skipped_transactions} }) {
                if ($_->{amount} < 0) {
                    $nb += -$_->{amount}; $ntx++;
                }
            }
            if (abs($na-$nb) >= 0.01) {
                log_warn(
                    "Check failed: total debit do not match ".
                        "($na in summary line vs $nb when totalled from ".
                        "$ntx transactions(s))");
            }
        }
        if (defined($stmt->{_total_credit_in_stmt})) {
            my $na = $stmt->{_total_credit_in_stmt};
            my $nb = 0;
            my $ntx = 0;
            for (@{ $stmt->{transactions} },
                 @{ $stmt->{skipped_transactions} }) {
                if ($_->{amount} > 0) {
                    $nb += $_->{amount}; $ntx++;
                }
            }
            if (abs($na-$nb) >= 0.01) {
                log_warn(
                    "Check failed: total credit do not match ".
                        "($na in summary line vs $nb when totalled from ".
                        "$ntx transactions(s))");
            }
        }
        if (defined($stmt->{_num_debit_tx_in_stmt})) {
            my $na = $stmt->{_num_debit_tx_in_stmt};
            my $nb = 0;
            for (@{ $stmt->{transactions} },
                 @{ $stmt->{skipped_transactions} }) {
                $nb += $_->{amount} < 0 ? 1 : 0;
            }
            if ($na != $nb) {
                $status = 400;
                $error = "Check failed: number of debit transactions ".
                    "do not match ($na in summary line vs $nb when totalled)";
                last;
            }
        }
        if (defined($stmt->{_num_credit_tx_in_stmt})) {
            my $na = $stmt->{_num_credit_tx_in_stmt};
            my $nb = 0;
            for (@{ $stmt->{transactions} },
                 @{ $stmt->{skipped_transactions} }) {
                $nb += $_->{amount} > 0 ? 1 : 0;
            }
            if ($na != $nb) {
                $status = 400;
                $error = "Check failed: number of credit transactions ".
                    "do not match ($na in summary line vs $nb when totalled)";
                last;
            }
        }

        $status = 200;
        last;
    }

    $self->logger->debug("parse_statement(): Temporary result: ".dmp($stmt));
    $self->logger->debug("parse_statement(): Status: $status ($error)");

    $stmt = undef unless $status == 200;
    $self->logger->debug("parse_statement(): Result: ".dmp($stmt));

    unless ($opts{return_datetime_obj} // 1) {
        # $_[0]{seen} = {} is a trick to allow multiple places which mention the
        # same object to be converted (defeat circular checking)
        require Data::Rmap;
        Data::Rmap::rmap_ref(sub {
            $_[0]{seen} = {};
            $_ = $self->_fmtdt($_) if UNIVERSAL::isa($_, "DateTime");
        }, $stmt);
    }

    [$status, $error, $stmt];
}

1;
# ABSTRACT: Base class for Finance::Bank::ID::BCA etc

__END__

=pod

=encoding UTF-8

=head1 NAME

Finance::Bank::ID::Base - Base class for Finance::Bank::ID::BCA etc

=head1 VERSION

This document describes version 0.49 of Finance::Bank::ID::Base (from Perl distribution Finance-Bank-ID-BCA), released on 2017-07-20.

=head1 SYNOPSIS

    # Don't use this module directly, use one of its subclasses instead.

=head1 DESCRIPTION

This module provides a base implementation for L<Finance::Bank::ID::BCA> and
L<Finance::Bank::ID::Mandiri>.

=head1 ATTRIBUTES

=head2 accounts

=head2 https_ca_dir

=head2 https_host

=head2 logged_in

=head2 logger

=head2 logger_dump

=head2 mech

=head2 password

=head2 site

=head2 username

=head2 verify_https

=head2 save_dir => STR

If set, each HTP response will be saved as YAML files in this dir. Existing
files will be overwritten.

=head2 mode => STR

Can be set to C<simulation> for simulation mode. In this mode, instead of
actually sending requests to network, each request will use responses saved
previously in C<save_dir>.

=head1 METHODS

=for Pod::Coverage ^(BUILD)$

=head2 new(%args) => OBJ

Create a new instance.

=head2 $obj->login()

Login to netbanking site.

=head2 $obj->logout()

Logout from netbanking site.

=head2 $obj->list_accounts()

List accounts.

=head2 $obj->check_balance([$acct])

=head2 $obj->get_balance()

Synonym for check_balance.

=head2 $obj->get_statement(%args)

Get account statement.

=head2 $obj->check_statement()

Alias for get_statement

=head2 $obj->account_statement()

Alias for get_statement

=head2 $obj->parse_statement($html_or_text, %opts)

Parse HTML/text into statement data.

=head1 HOMEPAGE

Please visit the project's homepage at L<https://metacpan.org/release/Finance-Bank-ID-BCA>.

=head1 SOURCE

Source repository is at L<https://github.com/perlancar/perl-Finance-Bank-ID-BCA>.

=head1 BUGS

Please report any bugs or feature requests on the bugtracker website L<https://rt.cpan.org/Public/Dist/Display.html?Name=Finance-Bank-ID-BCA>

When submitting a bug or request, please include a test-file or a
patch to an existing test-file that illustrates the bug or desired
feature.

=head1 AUTHOR

perlancar <[e-mail]>

=head1 COPYRIGHT AND LICENSE

This software is copyright (c) 2017, 2015, 2014, 2013, 2012, 2011, 2010 by [e-mail].

This is free software; you can redistribute it and/or modify it under
the same terms as the Perl 5 programming language system itself.

=cut