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