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


line stmt bran cond sub pod time code
1             package Finance::Bank::ID::Base;
2              
3             our $DATE = '2017-07-20'; # DATE
4             our $VERSION = '0.48'; # VERSION
5              
6 1     1   582 use 5.010;
  1         4  
7 1     1   8 use Moo;
  1         4  
  1         8  
8 1     1   1573 use Log::ger;
  1         107  
  1         8  
9              
10 1     1   816 use Data::Dmp;
  1         1414  
  1         1274  
11              
12             has mech => (is => 'rw');
13             has username => (is => 'rw');
14             has password => (is => 'rw');
15             has logged_in => (is => 'rw');
16             has accounts => (is => 'rw');
17             has logger => (is => 'rw',
18             default => sub { Log::ger->get_logger() } );
19             has logger_dump => (is => 'rw',
20             default => sub { Log::ger->get_logger() } );
21              
22             has site => (is => 'rw');
23              
24             has _req_counter => (is => 'rw', default => sub{0});
25              
26             has verify_https => (is => 'rw', default => sub{0});
27             has https_ca_dir => (is => 'rw', default => sub{'/etc/ssl/certs'});
28             has https_host => (is => 'rw');
29             has mode => (is => 'rw', default => sub{''});
30             has save_dir => (is => 'rw');
31              
32             sub _fmtdate {
33 0     0   0 my ($self, $dt) = @_;
34 0         0 $dt->ymd;
35             }
36              
37             sub _fmtdt {
38 19     19   35 my ($self, $dt) = @_;
39 19         88 $dt->datetime;
40             }
41              
42             # strip non-digit characters
43             sub _stripD {
44 207     207   414 my ($self, $s) = @_;
45 207         833 $s =~ s/\D+//g;
46 207         832 $s;
47             }
48              
49             sub BUILD {
50 1     1 0 6 my ($self, $args) = @_;
51              
52             # alias
53 1 50 33     4 $self->username($args->{login}) if $args->{login} && !$self->username;
54 1 50 33     5 $self->username($args->{user}) if $args->{user} && !$self->username;
55 1 50 33     7 $self->password($args->{pin}) if $args->{pin} && !$self->password;
56             }
57              
58             sub _set_default_mech {
59 0     0   0 require Finance::BankUtils::ID::Mechanize;
60              
61 0         0 my ($self) = @_;
62 0         0 $self->mech(
63             Finance::BankUtils::ID::Mechanize->new(
64             verify_https => $self->verify_https,
65             https_ca_dir => $self->https_ca_dir,
66             https_host => $self->https_host,
67             )
68             );
69             }
70              
71             sub _req {
72 0     0   0 my ($self, $meth, $args, $opts) = @_;
73              
74 0 0       0 if (ref($opts) ne 'HASH') {
75 0         0 die "Please update your module, 3rd arg is now a hashref since ".__PACKAGE__." 0.27";
76             }
77              
78 0 0       0 $opts->{id} or die "BUG: Request does not have id";
79 0 0       0 $opts->{id} =~ /\A[\w-]+\z/ or die "BUG: Invalid syntax in id '$opts->{id}'";
80              
81 0 0       0 $self->_set_default_mech unless $self->mech;
82 0         0 my $mech = $self->mech;
83 0         0 my $c = $self->_req_counter + 1;
84 0         0 $self->_req_counter($c);
85 0         0 $self->logger->debug("mech request #$c: $meth ".dmp($args)."");
86 0         0 my $errmsg = "";
87              
88 0         0 eval {
89 0 0 0     0 if ($self->mode eq 'simulation' &&
      0        
90             $self->save_dir && (-f $self->save_dir . "/$opts->{id}.yaml")) {
91 0         0 require YAML::Syck;
92 0         0 $Finance::BankUtils::ID::Mechanize::saved_resp =
93             YAML::Syck::LoadFile($self->save_dir . "/$opts->{id}.yaml");
94             }
95 0         0 $mech->$meth(@$args);
96 0 0 0     0 if ($self->save_dir && $self->mode ne 'simulation') {
97 0         0 require YAML::Syck;
98 0         0 YAML::Syck::DumpFile($self->save_dir . "/$opts->{id}.yaml", $mech->response);
99             }
100             };
101 0         0 my $evalerr = $@;
102              
103 0         0 eval {
104 0         0 $self->logger_dump->debug(
105             "<!-- result of mech request #$c ($meth ".dmp($args)."):\n".
106             $mech->response->status_line."\n".
107             $mech->response->headers->as_string."\n".
108             "-->\n".
109             $mech->content
110             );
111             };
112              
113 0 0       0 if ($evalerr) {
    0          
    0          
114             # mech dies on error, we catch it so we can log it
115 0         0 $errmsg = "die: $evalerr";
116             } elsif (!$mech->success) {
117             # actually mech usually dies if unsuccessful (see above), but
118             # this is just in case
119 0         0 $errmsg = "network error: " . $mech->response->status_line;
120             } elsif ($opts->{after_request}) {
121 0         0 $errmsg = $opts->{after_request}->($mech);
122 0 0       0 $errmsg = "after_request check error: $errmsg" if $errmsg;
123             }
124 0 0       0 if ($errmsg) {
125 0         0 $errmsg = "mech request #$c failed: $errmsg";
126 0         0 $self->logger->fatal($errmsg);
127 0         0 die $errmsg;
128             }
129             }
130              
131             sub login {
132 0     0 1 0 die "Should be implemented by child";
133             }
134              
135             sub logout {
136 0     0 1 0 die "Should be implemented by child";
137             }
138              
139             sub list_accounts {
140 0     0 1 0 die "Should be implemented by child";
141             }
142              
143             sub check_balance {
144 0     0 1 0 die "Should be implemented by child";
145             }
146              
147 0     0 1 0 sub get_balance { check_balance(@_) }
148              
149             sub get_statement {
150 0     0 1 0 die "Should be implemented by child";
151             }
152              
153 0     0 1 0 sub check_statement { get_statement(@_) }
154              
155 0     0 1 0 sub account_statement { get_statement(@_) }
156              
157             sub parse_statement {
158 7     7 1 58363 my ($self, $page, %opts) = @_;
159 7         19 my $status = 500;
160 7         15 my $error = "";
161 7         17 my $stmt = {};
162              
163 7         24 while (1) {
164 7         14 my $err;
165 7 50       36 if ($err = $self->_ps_detect($page, $stmt)) {
166 0         0 $status = 400; $error = "Can't detect: $err"; last;
  0         0  
  0         0  
167             }
168 7 50       30 if ($err = $self->_ps_get_metadata($page, $stmt)) {
169 0         0 $status = 400; $error = "Can't get metadata: $err"; last;
  0         0  
  0         0  
170             }
171 7 50       28 if ($err = $self->_ps_get_transactions($page, $stmt)) {
172 0         0 $status = 400; $error = "Can't get transactions: $err"; last;
  0         0  
  0         0  
173             }
174              
175 7 50       29 if (defined($stmt->{_total_debit_in_stmt})) {
176 7         16 my $na = $stmt->{_total_debit_in_stmt};
177 7         16 my $nb = 0;
178 7         14 my $ntx = 0;
179 7         12 for (@{ $stmt->{transactions} },
  7         18  
180 7         18 @{ $stmt->{skipped_transactions} }) {
181 93 100       208 if ($_->{amount} < 0) {
182 63         103 $nb += -$_->{amount}; $ntx++;
  63         98  
183             }
184             }
185 7 50       30 if (abs($na-$nb) >= 0.01) {
186 0         0 log_warn(
187             "Check failed: total debit do not match ".
188             "($na in summary line vs $nb when totalled from ".
189             "$ntx transactions(s))");
190             }
191             }
192 7 50       25 if (defined($stmt->{_total_credit_in_stmt})) {
193 7         16 my $na = $stmt->{_total_credit_in_stmt};
194 7         12 my $nb = 0;
195 7         11 my $ntx = 0;
196 7         11 for (@{ $stmt->{transactions} },
  7         35  
197 7         23 @{ $stmt->{skipped_transactions} }) {
198 93 100       202 if ($_->{amount} > 0) {
199 30         45 $nb += $_->{amount}; $ntx++;
  30         41  
200             }
201             }
202 7 50       27 if (abs($na-$nb) >= 0.01) {
203 0         0 log_warn(
204             "Check failed: total credit do not match ".
205             "($na in summary line vs $nb when totalled from ".
206             "$ntx transactions(s))");
207             }
208             }
209 7 100       22 if (defined($stmt->{_num_debit_tx_in_stmt})) {
210 1         3 my $na = $stmt->{_num_debit_tx_in_stmt};
211 1         2 my $nb = 0;
212 1         2 for (@{ $stmt->{transactions} },
  1         2  
213 1         3 @{ $stmt->{skipped_transactions} }) {
214 3 100       9 $nb += $_->{amount} < 0 ? 1 : 0;
215             }
216 1 50       4 if ($na != $nb) {
217 0         0 $status = 400;
218 0         0 $error = "Check failed: number of debit transactions ".
219             "do not match ($na in summary line vs $nb when totalled)";
220 0         0 last;
221             }
222             }
223 7 100       20 if (defined($stmt->{_num_credit_tx_in_stmt})) {
224 1         3 my $na = $stmt->{_num_credit_tx_in_stmt};
225 1         2 my $nb = 0;
226 1         2 for (@{ $stmt->{transactions} },
  1         2  
227 1         2 @{ $stmt->{skipped_transactions} }) {
228 3 100       7 $nb += $_->{amount} > 0 ? 1 : 0;
229             }
230 1 50       3 if ($na != $nb) {
231 0         0 $status = 400;
232 0         0 $error = "Check failed: number of credit transactions ".
233             "do not match ($na in summary line vs $nb when totalled)";
234 0         0 last;
235             }
236             }
237              
238 7         13 $status = 200;
239 7         18 last;
240             }
241              
242 7         49 $self->logger->debug("parse_statement(): Temporary result: ".dmp($stmt));
243 7         97292 $self->logger->debug("parse_statement(): Status: $status ($error)");
244              
245 7 50       40 $stmt = undef unless $status == 200;
246 7         37 $self->logger->debug("parse_statement(): Result: ".dmp($stmt));
247              
248 7 100 100     108322 unless ($opts{return_datetime_obj} // 1) {
249             # $_[0]{seen} = {} is a trick to allow multiple places which mention the
250             # same object to be converted (defeat circular checking)
251 1         985 require Data::Rmap;
252             Data::Rmap::rmap_ref(sub {
253 39     39   4406 $_[0]{seen} = {};
254 39 100       204 $_ = $self->_fmtdt($_) if UNIVERSAL::isa($_, "DateTime");
255 1         2156 }, $stmt);
256             }
257              
258 7         276 [$status, $error, $stmt];
259             }
260              
261             1;
262             # ABSTRACT: Base class for Finance::Bank::ID::BCA etc
263              
264             __END__
265              
266             =pod
267              
268             =encoding UTF-8
269              
270             =head1 NAME
271              
272             Finance::Bank::ID::Base - Base class for Finance::Bank::ID::BCA etc
273              
274             =head1 VERSION
275              
276             This document describes version 0.48 of Finance::Bank::ID::Base (from Perl distribution Finance-Bank-ID-BCA), released on 2017-07-20.
277              
278             =head1 SYNOPSIS
279              
280             # Don't use this module directly, use one of its subclasses instead.
281              
282             =head1 DESCRIPTION
283              
284             This module provides a base implementation for L<Finance::Bank::ID::BCA> and
285             L<Finance::Bank::ID::Mandiri>.
286              
287             =head1 ATTRIBUTES
288              
289             =head2 accounts
290              
291             =head2 https_ca_dir
292              
293             =head2 https_host
294              
295             =head2 logged_in
296              
297             =head2 logger
298              
299             =head2 logger_dump
300              
301             =head2 mech
302              
303             =head2 password
304              
305             =head2 site
306              
307             =head2 username
308              
309             =head2 verify_https
310              
311             =head2 save_dir => STR
312              
313             If set, each HTP response will be saved as YAML files in this dir. Existing
314             files will be overwritten.
315              
316             =head2 mode => STR
317              
318             Can be set to C<simulation> for simulation mode. In this mode, instead of
319             actually sending requests to network, each request will use responses saved
320             previously in C<save_dir>.
321              
322             =head1 METHODS
323              
324             =for Pod::Coverage ^(BUILD)$
325              
326             =head2 new(%args) => OBJ
327              
328             Create a new instance.
329              
330             =head2 $obj->login()
331              
332             Login to netbanking site.
333              
334             =head2 $obj->logout()
335              
336             Logout from netbanking site.
337              
338             =head2 $obj->list_accounts()
339              
340             List accounts.
341              
342             =head2 $obj->check_balance([$acct])
343              
344             =head2 $obj->get_balance()
345              
346             Synonym for check_balance.
347              
348             =head2 $obj->get_statement(%args)
349              
350             Get account statement.
351              
352             =head2 $obj->check_statement()
353              
354             Alias for get_statement
355              
356             =head2 $obj->account_statement()
357              
358             Alias for get_statement
359              
360             =head2 $obj->parse_statement($html_or_text, %opts)
361              
362             Parse HTML/text into statement data.
363              
364             =head1 HOMEPAGE
365              
366             Please visit the project's homepage at L<https://metacpan.org/release/Finance-Bank-ID-BCA>.
367              
368             =head1 SOURCE
369              
370             Source repository is at L<https://github.com/perlancar/perl-Finance-Bank-ID-BCA>.
371              
372             =head1 BUGS
373              
374             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>
375              
376             When submitting a bug or request, please include a test-file or a
377             patch to an existing test-file that illustrates the bug or desired
378             feature.
379              
380             =head1 AUTHOR
381              
382             perlancar <perlancar@cpan.org>
383              
384             =head1 COPYRIGHT AND LICENSE
385              
386             This software is copyright (c) 2017, 2015, 2014, 2013, 2012, 2011, 2010 by perlancar@cpan.org.
387              
388             This is free software; you can redistribute it and/or modify it under
389             the same terms as the Perl 5 programming language system itself.
390              
391             =cut