Version 0.002
[chaz/homebank2ledger] / lib / File / HomeBank.pm
1 package File::HomeBank;
2 # ABSTRACT: Parse HomeBank files
3
4
5 use warnings;
6 use strict;
7
8 use App::HomeBank2Ledger::Util qw(commify);
9 use Exporter qw(import);
10 use Scalar::Util qw(refaddr);
11 use Time::Piece;
12 use XML::Entities;
13 use XML::Parser::Lite;
14
15 our $VERSION = '0.002'; # VERSION
16
17 our @EXPORT_OK = qw(parse_string parse_file);
18
19 my %ACCOUNT_TYPES = (
20 0 => 'none',
21 1 => 'bank',
22 2 => 'cash',
23 3 => 'asset',
24 4 => 'creditcard',
25 5 => 'liability',
26 6 => 'stock',
27 7 => 'mutualfund',
28 8 => 'income',
29 9 => 'expense',
30 10 => 'equity',
31 );
32 my %ACCOUNT_FLAGS = (
33 0 => 'oldbudget',
34 1 => 'closed',
35 2 => 'added',
36 3 => 'changed',
37 4 => 'nosummary',
38 5 => 'nobudget',
39 6 => 'noreport',
40 );
41 my %CURRENCY_FLAGS = (
42 1 => 'custom',
43 );
44 my %CATEGORY_FLAGS = (
45 0 => 'sub',
46 1 => 'income',
47 2 => 'custom',
48 3 => 'budget',
49 4 => 'forced',
50 );
51 my %TRANSACTION_FLAGS = (
52 0 => 'oldvalid',
53 1 => 'income',
54 2 => 'auto',
55 3 => 'added',
56 4 => 'changed',
57 5 => 'oldremind',
58 6 => 'cheq2',
59 7 => 'limit',
60 8 => 'split',
61 );
62 my %TRANSACTION_STATUSES = (
63 0 => 'none',
64 1 => 'cleared',
65 2 => 'reconciled',
66 3 => 'remind',
67 4 => 'void',
68 );
69 my %TRANSACTION_PAYMODES = (
70 0 => 'none',
71 1 => 'creditcard',
72 2 => 'check',
73 3 => 'cash',
74 4 => 'transfer',
75 5 => 'internaltransfer',
76 6 => 'debitcard',
77 7 => 'repeatpayment',
78 8 => 'epayment',
79 9 => 'deposit',
80 10 => 'fee',
81 11 => 'directdebit',
82 );
83
84 sub _croak { require Carp; Carp::croak(@_) }
85 sub _usage { _croak("Usage: @_\n") }
86
87
88 my %CACHE;
89
90 sub new {
91 my $class = shift;
92 my %args = @_;
93
94 my $self;
95
96 if (my $filepath = $args{file}) {
97 $self = parse_file($filepath);
98 $self->{file} = $filepath;
99 }
100 elsif (my $str = $args{string}) {
101 $self = parse_string($str);
102 }
103 else {
104 _usage(q{File::HomeBank->new(string => $str)});
105 }
106
107 return bless $self, $class;
108 }
109
110 sub DESTROY {
111 my $self = shift;
112 my $in_global_destruction = shift;
113 delete $CACHE{refaddr($self)} if !$in_global_destruction;
114 }
115
116
117 sub file {
118 shift->{file};
119 }
120
121
122 sub title {
123 shift->{properties}{title};
124 }
125
126
127 sub base_currency {
128 shift->{properties}{currency};
129 }
130
131
132 sub accounts { shift->{accounts} || [] }
133 sub categories { shift->{categories} || [] }
134 sub currencies { shift->{currencies} || [] }
135 sub payees { shift->{payees} || [] }
136 sub transactions { shift->{transactions} || [] }
137
138 sub tags {
139 my $self = shift;
140
141 my %tags;
142
143 for my $transaction (@{$self->transactions}) {
144 for my $tag (split(/\h+/, $transaction->{tags} || '')) {
145 $tags{$tag} = 1;
146 }
147 }
148
149 return [keys %tags];
150 }
151
152
153 sub find_account_by_key {
154 my $self = shift;
155 my $key = shift or return;
156
157 my $index = $CACHE{refaddr($self)}{account_by_key};
158 if (!$index) {
159 # build index
160 for my $account (@{$self->accounts}) {
161 $index->{$account->{key}} = $account;
162 }
163
164 $CACHE{refaddr($self)}{account_by_key} = $index;
165 }
166
167 return $index->{$key};
168 }
169
170
171 sub find_currency_by_key {
172 my $self = shift;
173 my $key = shift or return;
174
175 my $index = $CACHE{refaddr($self)}{currency_by_key};
176 if (!$index) {
177 # build index
178 for my $currency (@{$self->currencies}) {
179 $index->{$currency->{key}} = $currency;
180 }
181
182 $CACHE{refaddr($self)}{currency_by_key} = $index;
183 }
184
185 return $index->{$key};
186 }
187
188
189 sub find_category_by_key {
190 my $self = shift;
191 my $key = shift or return;
192
193 my $index = $CACHE{refaddr($self)}{category_by_key};
194 if (!$index) {
195 # build index
196 for my $category (@{$self->categories}) {
197 $index->{$category->{key}} = $category;
198 }
199
200 $CACHE{refaddr($self)}{category_by_key} = $index;
201 }
202
203 return $index->{$key};
204 }
205
206
207 sub find_payee_by_key {
208 my $self = shift;
209 my $key = shift or return;
210
211 my $index = $CACHE{refaddr($self)}{payee_by_key};
212 if (!$index) {
213 # build index
214 for my $payee (@{$self->payees}) {
215 $index->{$payee->{key}} = $payee;
216 }
217
218 $CACHE{refaddr($self)}{payee_by_key} = $index;
219 }
220
221 return $index->{$key};
222 }
223
224
225 sub find_transactions_by_transfer_key {
226 my $self = shift;
227 my $key = shift or return;
228
229 my $index = $CACHE{refaddr($self)}{transactions_by_transfer_key};
230 if (!$index) {
231 # build index
232 for my $transaction (@{$self->transactions}) {
233 my $xfkey = $transaction->{transfer_key} or next;
234 push @{$index->{$xfkey} ||= []}, $transaction;
235 }
236
237 $CACHE{refaddr($self)}{transactions_by_transfer_key} = $index;
238 }
239
240 return @{$index->{$key} || []};
241 }
242
243
244 sub find_transaction_transfer_pair {
245 my $self = shift;
246 my $transaction = shift;
247
248 return if $transaction->{paymode} ne 'internaltransfer';
249
250 my $transfer_key = $transaction->{transfer_key};
251
252 my @matching = grep { refaddr($_) != refaddr($transaction) }
253 $self->find_transactions_by_transfer_key($transfer_key);
254 warn "Found more than two transactions with the same transfer key.\n" if 1 < @matching;
255 return $matching[0] if @matching;
256
257 warn "Found internal transfer with no tranfer key.\n" if !defined $transfer_key;
258
259 my $dst_account = $self->find_account_by_key($transaction->{dst_account});
260 if (!$dst_account) {
261 warn "Found internal transfer with no destination account.\n";
262 return;
263 }
264
265 my @candidates;
266
267 for my $t (@{$self->transactions}) {
268 next if $t->{paymode} ne 'internaltransfer';
269 next if $t->{account} != $transaction->{dst_account};
270 next if $t->{dst_account} != $transaction->{account};
271 next if $t->{amount} != -$transaction->{amount};
272
273 my @matching = $self->find_transactions_by_transfer_key($t->{transfer_key});
274 next if 1 < @matching; # other transaction must also be orphaned
275
276 push @candidates, $t;
277 }
278
279 my $transaction_day = _ymd_to_julian($transaction->{date});
280
281 # sort the candidates so we can pick the nearest one by date
282 my @ordered_candidates =
283 map { $_->[1] }
284 sort { $a->[0] <=> $b->[0] }
285 map { [abs($transaction_day - _ymd_to_julian($_->{date})), $_] } @candidates;
286
287 if (my $winner = $ordered_candidates[0]) {
288 my $key1 = $transfer_key || '[no key]';
289 my $key2 = $winner->{transfer_key} || '[no key]';
290 warn "Paired orphaned internal transfer ${key1} and ${key2}.\n";
291 return $winner;
292 }
293 }
294
295
296 sub sorted_transactions {
297 my $self = shift;
298
299 my $sorted_transactions = $CACHE{refaddr($self)}{sorted_transactions};
300 if (!$sorted_transactions) {
301 $sorted_transactions = [sort { $a->{date} cmp $b->{date} } @{$self->transactions}];
302
303 $CACHE{refaddr($self)}{sorted_transactions} = $sorted_transactions;
304 }
305
306 return $sorted_transactions;
307 }
308
309
310 sub full_category_name {
311 my $self = shift;
312 my $key = shift or return;
313
314 my $cat = $self->find_category_by_key($key);
315
316 my @categories = ($cat);
317
318 while (my $parent_key = $cat->{parent}) {
319 $cat = $self->find_category_by_key($parent_key);
320 unshift @categories, $cat;
321 }
322
323 return join(':', map { $_->{name} } @categories);
324 }
325
326
327 sub format_amount {
328 my $self = shift;
329 my $amount = shift;
330 my $currency = shift || $self->base_currency;
331
332 $currency = $self->find_currency_by_key($currency) if !ref($currency);
333 _croak 'Must provide a valid currency' if !$currency;
334
335 my $format = "\% .$currency->{frac}f";
336 my ($whole, $fraction) = split(/\./, sprintf($format, $amount));
337
338 my $num = join($currency->{dchar}, commify($whole, $currency->{gchar}), $fraction);
339
340 $num = $currency->{syprf} ? "$currency->{symbol} $num" : "$num $currency->{symbol}";
341
342 return $num;
343 }
344
345
346 sub parse_file {
347 my $filepath = shift or _usage(q{parse_file($filepath)});
348
349 open(my $fh, '<', $filepath) or die "open failed: $!";
350 my $str_in = do { local $/; <$fh> };
351
352 return parse_string($str_in);
353 }
354
355
356 sub parse_string {
357 my $str = shift or die _usage(q{parse_string($str)});
358
359 my %properties;
360 my @accounts;
361 my @payees;
362 my @categories;
363 my @currencies;
364 my @transactions;
365
366 my $xml_parser = XML::Parser::Lite->new(
367 Handlers => {
368 Start => sub {
369 shift;
370 my $node = shift;
371 my %attr = @_;
372
373 # decode all attribute values
374 for my $key (keys %attr) {
375 $attr{$key} = _decode_xml_entities($attr{$key});
376 }
377
378 if ($node eq 'properties') {
379 $attr{currency} = delete $attr{curr} if $attr{curr};
380 %properties = %attr;
381 }
382 elsif ($node eq 'account') {
383 $attr{type} = $ACCOUNT_TYPES{$attr{type} || ''} || 'unknown';
384 $attr{bank_name} = delete $attr{bankname} if $attr{bankname};
385 $attr{currency} = delete $attr{curr} if $attr{curr};
386 $attr{display_position} = delete $attr{pos} if $attr{pos};
387
388 my $flags = delete $attr{flags} || 0;
389 while (my ($shift, $name) = each %ACCOUNT_FLAGS) {
390 $attr{flags}{$name} = $flags & (1 << $shift) ? 1 : 0;
391 }
392
393 push @accounts, \%attr;
394 }
395 elsif ($node eq 'pay') { # payee
396 push @payees, \%attr;
397 }
398 elsif ($node eq 'cur') { # currency
399 $attr{symbol} = delete $attr{symb} if $attr{symb};
400
401 my $flags = delete $attr{flags} || 0;
402 while (my ($shift, $name) = each %CURRENCY_FLAGS) {
403 $attr{flags}{$name} = $flags & (1 << $shift) ? 1 : 0;
404 }
405
406 push @currencies, \%attr;
407 }
408 elsif ($node eq 'cat') { # category
409 my $flags = delete $attr{flags} || 0;
410 while (my ($shift, $name) = each %CATEGORY_FLAGS) {
411 $attr{flags}{$name} = $flags & (1 << $shift) ? 1 : 0;
412 }
413
414 push @categories, \%attr;
415 }
416 elsif ($node eq 'ope') { # transaction
417 $attr{paymode} = $TRANSACTION_PAYMODES{$attr{paymode} || ''} || 'unknown';
418 $attr{status} = $TRANSACTION_STATUSES{delete $attr{st}} || 'unknown';
419
420 $attr{transfer_key} = delete $attr{kxfer} if $attr{kxfer};
421 $attr{split_amount} = delete $attr{samt} if $attr{samt};
422 $attr{split_memo} = delete $attr{smem} if $attr{smem};
423 $attr{split_category} = delete $attr{scat} if $attr{scat};
424
425 $attr{date} = _rdn_to_ymd($attr{date}) if $attr{date};
426
427 my $flags = delete $attr{flags} || 0;
428 while (my ($shift, $name) = each %TRANSACTION_FLAGS) {
429 $attr{flags}{$name} = $flags & (1 << $shift) ? 1 : 0;
430 }
431
432 push @transactions, \%attr;
433 }
434 },
435 },
436 );
437 $xml_parser->parse($str);
438
439 return {
440 properties => \%properties,
441 accounts => \@accounts,
442 payees => \@payees,
443 categories => \@categories,
444 currencies => \@currencies,
445 transactions => \@transactions,
446 };
447 }
448
449 sub _decode_xml_entities {
450 my $str = shift;
451 # decoding entities can be extremely slow, so don't bother if it doesn't look like there are any
452 # entities to decode
453 return $str if $str !~ /&(?:#\d+)|[A-Za-z0-9]+;/;
454 return XML::Entities::decode('all', $str);
455 }
456
457 sub _rdn_to_unix_epoch {
458 my $rdn = shift;
459 my $jan01_1970 = 719163;
460 return ($rdn - $jan01_1970) * 86400;
461 }
462
463 sub _rdn_to_ymd {
464 my $rdn = shift;
465 my $epoch = _rdn_to_unix_epoch($rdn);
466 my $time = gmtime($epoch);
467 return $time->ymd;
468 };
469
470 sub _ymd_to_julian {
471 my $ymd = shift;
472 my $t = Time::Piece->strptime($ymd, '%Y-%m-%d');
473 return $t->julian_day;
474 }
475
476 1;
477
478 __END__
479
480 =pod
481
482 =encoding UTF-8
483
484 =head1 NAME
485
486 File::HomeBank - Parse HomeBank files
487
488 =head1 VERSION
489
490 version 0.002
491
492 =head1 SYNOPSIS
493
494 # Functional:
495
496 use File::HomeBank qw(parse_file);
497
498 my $raw_data = parse_file('path/to/homebank.xhb');
499
500 # Or OOP:
501
502 my $homebank = File::HomeBank->new(file => 'path/to/homebank.xhb');
503
504 for my $account (@{$homebank->accounts}) {
505 print "Found account named $account->{name}\n";
506 }
507
508 =head1 DESCRIPTION
509
510 This module parses L<HomeBank|http://homebank.free.fr/> files.
511
512 =head1 ATTRIBUTES
513
514 =head2 file
515
516 Get the filepath (if parsed from a file).
517
518 =head1 METHODS
519
520 =head2 new
521
522 $homebank = File::HomeBank->new(string => $str);
523 $homebank = File::HomeBank->new(file => $filepath);
524
525 Construct a L<File::HomeBank>.
526
527 =head2 title
528
529 $title = $homebank->title;
530
531 Get the title or owner property.
532
533 =head2 base_currency
534
535 $base_currency = $homebank->base_currency;
536
537 Get the key of the base currency.
538
539 =head2 accounts
540
541 Get an arrayref of accounts.
542
543 =head2 categories
544
545 Get an arrayref of categories.
546
547 =head2 currencies
548
549 Get an arrayref of currencies.
550
551 =head2 payees
552
553 Get an arrayref of payees.
554
555 =head2 tags
556
557 Get an arrayref of tags.
558
559 =head2 transactions
560
561 Get an arrayref of transactions.
562
563 =head2 find_account_by_key
564
565 $account = $homebank->find_account_by_key($key);
566
567 Find a account with the given key.
568
569 =head2 find_currency_by_key
570
571 $currency = $homebank->find_currency_by_key($key);
572
573 Find a currency with the given key.
574
575 =head2 find_category_by_key
576
577 $category = $homebank->find_category_by_key($key);
578
579 Find a category with the given key.
580
581 =head2 find_payee_by_key
582
583 $payee = $homebank->find_payee_by_key($key);
584
585 Find a payee with the given key.
586
587 =head2 find_transactions_by_transfer_key
588
589 @transactions = $homebank->find_transactions_by_transfer_key($key);
590
591 Find all transactions that share the same transfer key.
592
593 =head2 find_transaction_transfer_pair
594
595 $other_transaction = $homebank->find_transaction_transfer_pair($transaction);
596
597 Given a transaction hashref, return its corresponding transaction if it is an internal transfer. If
598 the transaction is an internal transaction with a destination account but is orphaned (has no
599 matching transfer key), this also looks for another orphaned transaction in the destination account
600 that it can call its partner.
601
602 Returns undef or empty if no corresponding transaction is found.
603
604 =head2 sorted_transactions
605
606 $transations = $homebank->sorted_transactions;
607
608 Get an arrayref of transactions sorted by date (oldest first).
609
610 =head2 full_category_name
611
612 $category_name = $homebank->full_category_name($key);
613
614 Generate the full name for a category, taking category inheritance into consideration.
615
616 Income
617 Salary <--
618
619 will become:
620
621 "Income:Salary"
622
623 =head2 format_amount
624
625 $formatted_amount = $homebank->format_amount($amount);
626 $formatted_amount = $homebank->format_amount($amount, $currency);
627
628 Formats an amount in either the base currency (for the whole file) or in the given currency.
629 Currency can be a key or the actualy currency structure.
630
631 =head1 FUNCTIONS
632
633 =head2 parse_file
634
635 $homebank_data = parse_file($filepath);
636
637 Read and parse a HomeBank .xhb file from a filesystem.
638
639 =head2 parse_string
640
641 $homebank_data = parse_string($str);
642
643 Parse a HomeBank file from a string.
644
645 =head1 BUGS
646
647 Please report any bugs or feature requests on the bugtracker website
648 L<https://github.com/chazmcgarvey/homebank2ledger/issues>
649
650 When submitting a bug or request, please include a test-file or a
651 patch to an existing test-file that illustrates the bug or desired
652 feature.
653
654 =head1 AUTHOR
655
656 Charles McGarvey <chazmcgarvey@brokenzipper.com>
657
658 =head1 COPYRIGHT AND LICENSE
659
660 This software is Copyright (c) 2019 by Charles McGarvey.
661
662 This is free software, licensed under:
663
664 The MIT (X11) License
665
666 =cut
This page took 0.07324 seconds and 4 git commands to generate.