add file_version method to File::HomeBank
[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 file_version
156
157 $version = $homebank->file_version;
158
159 Get the file format version.
160
161 =cut
162
163 sub file_version {
164 shift->{homebank}{version};
165 }
166
167 =method title
168
169 $title = $homebank->title;
170
171 Get the title or owner property.
172
173 =cut
174
175 sub title {
176 shift->{properties}{title};
177 }
178
179 =method base_currency
180
181 $base_currency = $homebank->base_currency;
182
183 Get the key of the base currency.
184
185 =cut
186
187 sub base_currency {
188 shift->{properties}{currency};
189 }
190
191 =method accounts
192
193 Get an arrayref of accounts.
194
195 =method categories
196
197 Get an arrayref of categories.
198
199 =method currencies
200
201 Get an arrayref of currencies.
202
203 =method payees
204
205 Get an arrayref of payees.
206
207 =method tags
208
209 Get an arrayref of tags.
210
211 =method transactions
212
213 Get an arrayref of transactions.
214
215 =cut
216
217 sub accounts { shift->{accounts} || [] }
218 sub categories { shift->{categories} || [] }
219 sub currencies { shift->{currencies} || [] }
220 sub payees { shift->{payees} || [] }
221 sub transactions { shift->{transactions} || [] }
222
223 sub tags {
224 my $self = shift;
225
226 my %tags;
227
228 for my $transaction (@{$self->transactions}) {
229 for my $tag (split(/\h+/, $transaction->{tags} || '')) {
230 $tags{$tag} = 1;
231 }
232 }
233
234 return [keys %tags];
235 }
236
237 =method find_account_by_key
238
239 $account = $homebank->find_account_by_key($key);
240
241 Find an account with the given key.
242
243 =cut
244
245 sub find_account_by_key {
246 my $self = shift;
247 my $key = shift or return;
248
249 my $index = $CACHE{refaddr($self)}{account_by_key};
250 if (!$index) {
251 # build index
252 for my $account (@{$self->accounts}) {
253 $index->{$account->{key}} = $account;
254 }
255
256 $CACHE{refaddr($self)}{account_by_key} = $index;
257 }
258
259 return $index->{$key};
260 }
261
262 =method find_currency_by_key
263
264 $currency = $homebank->find_currency_by_key($key);
265
266 Find a currency with the given key.
267
268 =cut
269
270 sub find_currency_by_key {
271 my $self = shift;
272 my $key = shift or return;
273
274 my $index = $CACHE{refaddr($self)}{currency_by_key};
275 if (!$index) {
276 # build index
277 for my $currency (@{$self->currencies}) {
278 $index->{$currency->{key}} = $currency;
279 }
280
281 $CACHE{refaddr($self)}{currency_by_key} = $index;
282 }
283
284 return $index->{$key};
285 }
286
287 =method find_category_by_key
288
289 $category = $homebank->find_category_by_key($key);
290
291 Find a category with the given key.
292
293 =cut
294
295 sub find_category_by_key {
296 my $self = shift;
297 my $key = shift or return;
298
299 my $index = $CACHE{refaddr($self)}{category_by_key};
300 if (!$index) {
301 # build index
302 for my $category (@{$self->categories}) {
303 $index->{$category->{key}} = $category;
304 }
305
306 $CACHE{refaddr($self)}{category_by_key} = $index;
307 }
308
309 return $index->{$key};
310 }
311
312 =method find_payee_by_key
313
314 $payee = $homebank->find_payee_by_key($key);
315
316 Find a payee with the given key.
317
318 =cut
319
320 sub find_payee_by_key {
321 my $self = shift;
322 my $key = shift or return;
323
324 my $index = $CACHE{refaddr($self)}{payee_by_key};
325 if (!$index) {
326 # build index
327 for my $payee (@{$self->payees}) {
328 $index->{$payee->{key}} = $payee;
329 }
330
331 $CACHE{refaddr($self)}{payee_by_key} = $index;
332 }
333
334 return $index->{$key};
335 }
336
337 =method find_transactions_by_transfer_key
338
339 @transactions = $homebank->find_transactions_by_transfer_key($key);
340
341 Find all transactions that share the same transfer key.
342
343 =cut
344
345 sub find_transactions_by_transfer_key {
346 my $self = shift;
347 my $key = shift or return;
348
349 my $index = $CACHE{refaddr($self)}{transactions_by_transfer_key};
350 if (!$index) {
351 # build index
352 for my $transaction (@{$self->transactions}) {
353 my $xfkey = $transaction->{transfer_key} or next;
354 push @{$index->{$xfkey} ||= []}, $transaction;
355 }
356
357 $CACHE{refaddr($self)}{transactions_by_transfer_key} = $index;
358 }
359
360 return @{$index->{$key} || []};
361 }
362
363 =method find_transaction_transfer_pair
364
365 $other_transaction = $homebank->find_transaction_transfer_pair($transaction);
366
367 Given a transaction hashref, return its corresponding transaction if it is an internal transfer. If
368 the transaction is an internal transaction with a destination account but is orphaned (has no
369 matching transfer key), this also looks for another orphaned transaction in the destination account
370 that it can call its partner.
371
372 Returns undef or empty if no corresponding transaction is found.
373
374 =cut
375
376 sub find_transaction_transfer_pair {
377 my $self = shift;
378 my $transaction = shift;
379
380 return if $transaction->{paymode} ne 'internaltransfer';
381
382 my $transfer_key = $transaction->{transfer_key};
383
384 my @matching = grep { refaddr($_) != refaddr($transaction) }
385 $self->find_transactions_by_transfer_key($transfer_key);
386 warn "Found more than two transactions with the same transfer key.\n" if 1 < @matching;
387 return $matching[0] if @matching;
388
389 warn "Found internal transfer with no tranfer key.\n" if !defined $transfer_key;
390
391 my $dst_account = $self->find_account_by_key($transaction->{dst_account});
392 if (!$dst_account) {
393 warn "Found internal transfer with no destination account.\n";
394 return;
395 }
396
397 my @candidates;
398
399 for my $t (@{$self->transactions}) {
400 next if $t->{paymode} ne 'internaltransfer';
401 next if $t->{account} != $transaction->{dst_account};
402 next if $t->{dst_account} != $transaction->{account};
403 next if $t->{amount} != -$transaction->{amount};
404
405 my @matching = $self->find_transactions_by_transfer_key($t->{transfer_key});
406 next if 1 < @matching; # other transaction must also be orphaned
407
408 push @candidates, $t;
409 }
410
411 my $transaction_day = _ymd_to_julian($transaction->{date});
412
413 # sort the candidates so we can pick the nearest one by date
414 my @ordered_candidates =
415 map { $_->[1] }
416 sort { $a->[0] <=> $b->[0] }
417 map { [abs($transaction_day - _ymd_to_julian($_->{date})), $_] } @candidates;
418
419 if (my $winner = $ordered_candidates[0]) {
420 my $key1 = $transfer_key || '[no key]';
421 my $key2 = $winner->{transfer_key} || '[no key]';
422 warn "Paired orphaned internal transfer ${key1} and ${key2}.\n";
423 return $winner;
424 }
425 }
426
427 =method sorted_transactions
428
429 $transations = $homebank->sorted_transactions;
430
431 Get an arrayref of transactions sorted by date (oldest first).
432
433 =cut
434
435 sub sorted_transactions {
436 my $self = shift;
437
438 my $sorted_transactions = $CACHE{refaddr($self)}{sorted_transactions};
439 if (!$sorted_transactions) {
440 $sorted_transactions = [sort { $a->{date} cmp $b->{date} } @{$self->transactions}];
441
442 $CACHE{refaddr($self)}{sorted_transactions} = $sorted_transactions;
443 }
444
445 return $sorted_transactions;
446 }
447
448 =method full_category_name
449
450 $category_name = $homebank->full_category_name($key);
451
452 Generate the full name for a category, taking category inheritance into consideration.
453
454 Income
455 Salary <--
456
457 will become:
458
459 "Income:Salary"
460
461 =cut
462
463 sub full_category_name {
464 my $self = shift;
465 my $key = shift or return;
466
467 my $cat = $self->find_category_by_key($key);
468
469 my @categories = ($cat);
470
471 while (my $parent_key = $cat->{parent}) {
472 $cat = $self->find_category_by_key($parent_key);
473 unshift @categories, $cat;
474 }
475
476 return join(':', map { $_->{name} } @categories);
477 }
478
479 =method format_amount
480
481 $formatted_amount = $homebank->format_amount($amount);
482 $formatted_amount = $homebank->format_amount($amount, $currency);
483
484 Formats an amount in either the base currency (for the whole file) or in the given currency.
485 Currency can be a key or the actualy currency structure.
486
487 =cut
488
489 sub format_amount {
490 my $self = shift;
491 my $amount = shift;
492 my $currency = shift || $self->base_currency;
493
494 $currency = $self->find_currency_by_key($currency) if !ref($currency);
495 _croak 'Must provide a valid currency' if !$currency;
496
497 my $format = "\% .$currency->{frac}f";
498 my ($whole, $fraction) = split(/\./, sprintf($format, $amount));
499
500 my $num = join($currency->{dchar}, commify($whole, $currency->{gchar}), $fraction);
501
502 $num = $currency->{syprf} ? "$currency->{symbol} $num" : "$num $currency->{symbol}";
503
504 return $num;
505 }
506
507 =func parse_file
508
509 $homebank_data = parse_file($filepath);
510
511 Read and parse a HomeBank .xhb file from a filesystem.
512
513 =cut
514
515 sub parse_file {
516 my $filepath = shift or _usage(q{parse_file($filepath)});
517
518 open(my $fh, '<', $filepath) or die "open failed: $!";
519 my $str_in = do { local $/; <$fh> };
520
521 return parse_string($str_in);
522 }
523
524 =func parse_string
525
526 $homebank_data = parse_string($str);
527
528 Parse a HomeBank file from a string.
529
530 =cut
531
532 sub parse_string {
533 my $str = shift or die _usage(q{parse_string($str)});
534
535 my %homebank;
536 my %properties;
537 my @accounts;
538 my @payees;
539 my @categories;
540 my @currencies;
541 my @transactions;
542
543 my $xml_parser = XML::Parser::Lite->new(
544 Handlers => {
545 Start => sub {
546 shift;
547 my $node = shift;
548 my %attr = @_;
549
550 # decode all attribute values
551 for my $key (keys %attr) {
552 $attr{$key} = _decode_xml_entities($attr{$key});
553 }
554
555 if ($node eq 'homebank') {
556 $attr{version} = delete $attr{v} if $attr{v};
557 %homebank = %attr;
558 }
559 elsif ($node eq 'properties') {
560 $attr{currency} = delete $attr{curr} if $attr{curr};
561 %properties = %attr;
562 }
563 elsif ($node eq 'account') {
564 $attr{type} = $ACCOUNT_TYPES{$attr{type} || ''} || 'unknown';
565 $attr{bank_name} = delete $attr{bankname} if $attr{bankname};
566 $attr{currency} = delete $attr{curr} if $attr{curr};
567 $attr{display_position} = delete $attr{pos} if $attr{pos};
568
569 my $flags = delete $attr{flags} || 0;
570 while (my ($shift, $name) = each %ACCOUNT_FLAGS) {
571 $attr{flags}{$name} = $flags & (1 << $shift) ? 1 : 0;
572 }
573
574 push @accounts, \%attr;
575 }
576 elsif ($node eq 'pay') { # payee
577 push @payees, \%attr;
578 }
579 elsif ($node eq 'cur') { # currency
580 $attr{symbol} = delete $attr{symb} if $attr{symb};
581
582 my $flags = delete $attr{flags} || 0;
583 while (my ($shift, $name) = each %CURRENCY_FLAGS) {
584 $attr{flags}{$name} = $flags & (1 << $shift) ? 1 : 0;
585 }
586
587 push @currencies, \%attr;
588 }
589 elsif ($node eq 'cat') { # category
590 my $flags = delete $attr{flags} || 0;
591 while (my ($shift, $name) = each %CATEGORY_FLAGS) {
592 $attr{flags}{$name} = $flags & (1 << $shift) ? 1 : 0;
593 }
594
595 for my $bnum (0 .. 12) {
596 $attr{budget_amounts}[$bnum] = delete $attr{"b$bnum"} if $attr{"b$bnum"};
597 }
598
599 push @categories, \%attr;
600 }
601 elsif ($node eq 'ope') { # transaction
602 $attr{paymode} = $TRANSACTION_PAYMODES{$attr{paymode} || ''} || 'unknown';
603 $attr{status} = $TRANSACTION_STATUSES{delete $attr{st} || ''} || 'unknown';
604
605 $attr{transfer_key} = delete $attr{kxfer} if $attr{kxfer};
606 $attr{split_amount} = delete $attr{samt} if $attr{samt};
607 $attr{split_memo} = delete $attr{smem} if $attr{smem};
608 $attr{split_category} = delete $attr{scat} if $attr{scat};
609
610 $attr{date} = _rdn_to_ymd($attr{date}) if $attr{date};
611
612 my $flags = delete $attr{flags} || 0;
613 while (my ($shift, $name) = each %TRANSACTION_FLAGS) {
614 $attr{flags}{$name} = $flags & (1 << $shift) ? 1 : 0;
615 }
616
617 push @transactions, \%attr;
618 }
619 },
620 },
621 );
622 $xml_parser->parse($str);
623
624 return {
625 homebank => \%homebank,
626 properties => \%properties,
627 accounts => \@accounts,
628 payees => \@payees,
629 categories => \@categories,
630 currencies => \@currencies,
631 transactions => \@transactions,
632 };
633 }
634
635 sub _decode_xml_entities {
636 my $str = shift;
637 # decoding entities can be extremely slow, so don't bother if it doesn't look like there are any
638 # entities to decode
639 return $str if $str !~ /&(?:#\d+)|[A-Za-z0-9]+;/;
640 return XML::Entities::decode('all', $str);
641 }
642
643 sub _rdn_to_unix_epoch {
644 my $rdn = shift;
645 my $jan01_1970 = 719163;
646 return ($rdn - $jan01_1970) * 86400;
647 }
648
649 sub _rdn_to_ymd {
650 my $rdn = shift;
651 my $epoch = _rdn_to_unix_epoch($rdn);
652 my $time = gmtime($epoch);
653 return $time->ymd;
654 };
655
656 sub _ymd_to_julian {
657 my $ymd = shift;
658 my $t = Time::Piece->strptime($ymd, '%Y-%m-%d');
659 return $t->julian_day;
660 }
661
662 1;
This page took 0.075026 seconds and 4 git commands to generate.