1 package File
::HomeBank
;
2 # ABSTRACT: Parse HomeBank files
8 use File::HomeBank qw(parse_file);
10 my $raw_data = parse_file('path/to/homebank.xhb');
14 my $homebank = File::HomeBank->new(file => 'path/to/homebank.xhb');
16 for my $account (@{$homebank->accounts}) {
17 print "Found account named $account->{name}\n";
22 This module parses L<HomeBank|http://homebank.free.fr/> files.
29 use App
::HomeBank2Ledger
::Util
qw(commify);
30 use Exporter
qw(import);
31 use Scalar
::Util
qw(refaddr);
34 use XML
::Parser
::Lite
;
36 our $VERSION = '9999.999'; # VERSION
38 our @EXPORT_OK = qw(parse_string parse_file);
62 my %CURRENCY_FLAGS = (
65 my %CATEGORY_FLAGS = (
72 my %TRANSACTION_FLAGS = (
83 my %TRANSACTION_STATUSES = (
90 my %TRANSACTION_PAYMODES = (
96 5 => 'internaltransfer',
105 sub _croak
{ require Carp
; Carp
::croak
(@_) }
106 sub _usage
{ _croak
("Usage: @_\n") }
110 $homebank = File
::HomeBank-
>new(string
=> $str);
111 $homebank = File
::HomeBank-
>new(file
=> $filepath);
113 Construct a L
<File
::HomeBank
>.
125 if (my $filepath = $args{file
}) {
126 $self = parse_file
($filepath);
127 $self->{file
} = $filepath;
129 elsif (my $str = $args{string
}) {
130 $self = parse_string
($str);
133 _usage
(q{File::HomeBank->new(string => $str)});
136 return bless $self, $class;
141 my $in_global_destruction = shift;
142 delete $CACHE{refaddr
($self)} if !$in_global_destruction;
147 Get the filepath
(if parsed from a file
).
157 $version = $homebank->file_version;
159 Get the file format version
.
164 shift-
>{homebank
}{version
};
169 $title = $homebank->title;
171 Get the title
or owner property
.
176 shift-
>{properties
}{title
};
179 =method base_currency
181 $base_currency = $homebank->base_currency;
183 Get the key of the base currency
.
188 shift-
>{properties
}{currency
};
193 Get an arrayref of accounts
.
197 Get an arrayref of categories
.
201 Get an arrayref of currencies
.
205 Get an arrayref of payees
.
209 Get an arrayref of tags
.
213 Get an arrayref of transactions
.
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
} || [] }
228 for my $transaction (@{$self->transactions}) {
229 for my $tag (split(/\h+/, $transaction->{tags
} || '')) {
237 =method find_account_by_key
239 $account = $homebank->find_account_by_key($key);
241 Find an account with the
given key
.
245 sub find_account_by_key
{
247 my $key = shift or return;
249 my $index = $CACHE{refaddr
($self)}{account_by_key
};
252 for my $account (@{$self->accounts}) {
253 $index->{$account->{key
}} = $account;
256 $CACHE{refaddr
($self)}{account_by_key
} = $index;
259 return $index->{$key};
262 =method find_currency_by_key
264 $currency = $homebank->find_currency_by_key($key);
266 Find a currency with the
given key
.
270 sub find_currency_by_key
{
272 my $key = shift or return;
274 my $index = $CACHE{refaddr
($self)}{currency_by_key
};
277 for my $currency (@{$self->currencies}) {
278 $index->{$currency->{key
}} = $currency;
281 $CACHE{refaddr
($self)}{currency_by_key
} = $index;
284 return $index->{$key};
287 =method find_category_by_key
289 $category = $homebank->find_category_by_key($key);
291 Find a category with the
given key
.
295 sub find_category_by_key
{
297 my $key = shift or return;
299 my $index = $CACHE{refaddr
($self)}{category_by_key
};
302 for my $category (@{$self->categories}) {
303 $index->{$category->{key
}} = $category;
306 $CACHE{refaddr
($self)}{category_by_key
} = $index;
309 return $index->{$key};
312 =method find_payee_by_key
314 $payee = $homebank->find_payee_by_key($key);
316 Find a payee with the
given key
.
320 sub find_payee_by_key
{
322 my $key = shift or return;
324 my $index = $CACHE{refaddr
($self)}{payee_by_key
};
327 for my $payee (@{$self->payees}) {
328 $index->{$payee->{key
}} = $payee;
331 $CACHE{refaddr
($self)}{payee_by_key
} = $index;
334 return $index->{$key};
337 =method find_transactions_by_transfer_key
339 @transactions = $homebank->find_transactions_by_transfer_key($key);
341 Find all transactions that share the same transfer key
.
345 sub find_transactions_by_transfer_key
{
347 my $key = shift or return;
349 my $index = $CACHE{refaddr
($self)}{transactions_by_transfer_key
};
352 for my $transaction (@{$self->transactions}) {
353 my $xfkey = $transaction->{transfer_key
} or next;
354 push @{$index->{$xfkey} ||= []}, $transaction;
357 $CACHE{refaddr
($self)}{transactions_by_transfer_key
} = $index;
360 return @{$index->{$key} || []};
363 =method find_transaction_transfer_pair
365 $other_transaction = $homebank->find_transaction_transfer_pair($transaction);
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
.
372 Returns
undef or empty
if no corresponding transaction
is found
.
376 sub find_transaction_transfer_pair
{
378 my $transaction = shift;
380 return if !$transaction->{dst_account
};
382 my $transfer_key = $transaction->{transfer_key
};
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;
389 warn "Found internal transfer with no tranfer key.\n" if !defined $transfer_key;
391 my $dst_account = $self->find_account_by_key($transaction->{dst_account
});
393 warn "Found internal transfer with no destination account.\n";
399 for my $t (@{$self->transactions}) {
400 next if !$t->{dst_account
};
401 next if $t->{account
} != $transaction->{dst_account
};
402 next if $t->{dst_account
} != $transaction->{account
};
403 next if $t->{amount
} != -$transaction->{amount
};
405 my @matching = $self->find_transactions_by_transfer_key($t->{transfer_key
});
406 next if 1 < @matching; # other transaction must also be orphaned
408 push @candidates, $t;
411 my $transaction_day = _ymd_to_julian
($transaction->{date
});
413 # sort the candidates so we can pick the nearest one by date
414 my @ordered_candidates =
416 sort { $a->[0] <=> $b->[0] }
417 map { [abs($transaction_day - _ymd_to_julian
($_->{date
})), $_] } @candidates;
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";
427 =method sorted_transactions
429 $transations = $homebank->sorted_transactions;
431 Get an arrayref of transactions sorted by date
(oldest first
).
435 sub sorted_transactions
{
438 my $sorted_transactions = $CACHE{refaddr
($self)}{sorted_transactions
};
439 if (!$sorted_transactions) {
440 $sorted_transactions = [sort { $a->{date
} cmp $b->{date
} } @{$self->transactions}];
442 $CACHE{refaddr
($self)}{sorted_transactions
} = $sorted_transactions;
445 return $sorted_transactions;
448 =method full_category_name
450 $category_name = $homebank->full_category_name($key);
452 Generate the full name
for a category
, taking category inheritance into consideration
.
463 sub full_category_name
{
465 my $key = shift or return;
467 my $cat = $self->find_category_by_key($key);
469 my @categories = ($cat);
471 while (my $parent_key = $cat->{parent
}) {
472 $cat = $self->find_category_by_key($parent_key);
473 unshift @categories, $cat;
476 return join(':', map { $_->{name
} } @categories);
479 =method format_amount
481 $formatted_amount = $homebank->format_amount($amount);
482 $formatted_amount = $homebank->format_amount($amount, $currency);
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
.
492 my $currency = shift || $self->base_currency;
494 $currency = $self->find_currency_by_key($currency) if !ref($currency);
495 _croak
'Must provide a valid currency' if !$currency;
497 my $format = "\% .$currency->{frac}f";
498 my ($whole, $fraction) = split(/\./, sprintf($format, $amount));
500 my $num = join($currency->{dchar
}, commify
($whole, $currency->{gchar
}), $fraction);
502 $num = $currency->{syprf
} ? "$currency->{symbol} $num" : "$num $currency->{symbol}";
509 $homebank_data = parse_file
($filepath);
511 Read
and parse a HomeBank
.xhb file from a filesystem
.
516 my $filepath = shift or _usage
(q{parse_file($filepath)});
518 open(my $fh, '<', $filepath) or die "open failed: $!";
519 my $str_in = do { local $/; <$fh> };
521 return parse_string
($str_in);
526 $homebank_data = parse_string
($str);
528 Parse a HomeBank file from a string
.
533 my $str = shift or die _usage
(q{parse_string($str)});
543 my $xml_parser = XML
::Parser
::Lite-
>new(
550 # decode all attribute values
551 for my $key (keys %attr) {
552 $attr{$key} = _decode_xml_entities
($attr{$key});
555 if ($node eq 'homebank') {
556 $attr{version
} = delete $attr{v
} if $attr{v
};
559 elsif ($node eq 'properties') {
560 $attr{currency
} = delete $attr{curr
} if $attr{curr
};
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};
569 my $flags = delete $attr{flags
} || 0;
570 while (my ($shift, $name) = each %ACCOUNT_FLAGS) {
571 $attr{flags
}{$name} = $flags & (1 << $shift) ? 1 : 0;
574 push @accounts, \
%attr;
576 elsif ($node eq 'pay') { # payee
577 push @payees, \
%attr;
579 elsif ($node eq 'cur') { # currency
580 $attr{symbol
} = delete $attr{symb
} if $attr{symb
};
582 my $flags = delete $attr{flags
} || 0;
583 while (my ($shift, $name) = each %CURRENCY_FLAGS) {
584 $attr{flags
}{$name} = $flags & (1 << $shift) ? 1 : 0;
587 push @currencies, \
%attr;
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;
595 for my $bnum (0 .. 12) {
596 $attr{budget_amounts
}[$bnum] = delete $attr{"b$bnum"} if $attr{"b$bnum"};
599 push @categories, \
%attr;
601 elsif ($node eq 'ope') { # transaction
602 $attr{paymode
} = $TRANSACTION_PAYMODES{$attr{paymode
} || ''} || 'unknown';
603 $attr{status
} = $TRANSACTION_STATUSES{delete $attr{st
} || ''} || 'unknown';
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
};
610 $attr{date
} = _rdn_to_ymd
($attr{date
}) if $attr{date
};
612 my $flags = delete $attr{flags
} || 0;
613 while (my ($shift, $name) = each %TRANSACTION_FLAGS) {
614 $attr{flags
}{$name} = $flags & (1 << $shift) ? 1 : 0;
617 push @transactions, \
%attr;
622 $xml_parser->parse($str);
625 homebank
=> \
%homebank,
626 properties
=> \
%properties,
627 accounts
=> \
@accounts,
629 categories
=> \
@categories,
630 currencies
=> \
@currencies,
631 transactions
=> \
@transactions,
635 sub _decode_xml_entities
{
637 # decoding entities can be extremely slow, so don't bother if it doesn't look like there are any
639 return $str if $str !~ /&(?:#\d+)|[A-Za-z0-9]+;/;
640 return XML
::Entities
::decode
('all', $str);
643 sub _rdn_to_unix_epoch
{
645 my $jan01_1970 = 719163;
646 return ($rdn - $jan01_1970) * 86400;
651 my $epoch = _rdn_to_unix_epoch
($rdn);
652 my $time = gmtime($epoch);
658 my $t = Time
::Piece-
>strptime($ymd, '%Y-%m-%d');
659 return $t->julian_day;