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