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 $title = $homebank->title;
159 Get the title
or owner property
.
164 shift-
>{properties
}{title
};
167 =method base_currency
169 $base_currency = $homebank->base_currency;
171 Get the key of the base currency
.
176 shift-
>{properties
}{currency
};
181 Get an arrayref of accounts
.
185 Get an arrayref of categories
.
189 Get an arrayref of currencies
.
193 Get an arrayref of payees
.
197 Get an arrayref of tags
.
201 Get an arrayref of transactions
.
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
} || [] }
216 for my $transaction (@{$self->transactions}) {
217 for my $tag (split(/\h+/, $transaction->{tags
} || '')) {
225 =method find_account_by_key
227 $account = $homebank->find_account_by_key($key);
229 Find a account with the
given key
.
233 sub find_account_by_key
{
235 my $key = shift or return;
237 my $index = $CACHE{refaddr
($self)}{account_by_key
};
240 for my $account (@{$self->accounts}) {
241 $index->{$account->{key
}} = $account;
244 $CACHE{refaddr
($self)}{account_by_key
} = $index;
247 return $index->{$key};
250 =method find_currency_by_key
252 $currency = $homebank->find_currency_by_key($key);
254 Find a currency with the
given key
.
258 sub find_currency_by_key
{
260 my $key = shift or return;
262 my $index = $CACHE{refaddr
($self)}{currency_by_key
};
265 for my $currency (@{$self->currencies}) {
266 $index->{$currency->{key
}} = $currency;
269 $CACHE{refaddr
($self)}{currency_by_key
} = $index;
272 return $index->{$key};
275 =method find_category_by_key
277 $category = $homebank->find_category_by_key($key);
279 Find a category with the
given key
.
283 sub find_category_by_key
{
285 my $key = shift or return;
287 my $index = $CACHE{refaddr
($self)}{category_by_key
};
290 for my $category (@{$self->categories}) {
291 $index->{$category->{key
}} = $category;
294 $CACHE{refaddr
($self)}{category_by_key
} = $index;
297 return $index->{$key};
300 =method find_payee_by_key
302 $payee = $homebank->find_payee_by_key($key);
304 Find a payee with the
given key
.
308 sub find_payee_by_key
{
310 my $key = shift or return;
312 my $index = $CACHE{refaddr
($self)}{payee_by_key
};
315 for my $payee (@{$self->payees}) {
316 $index->{$payee->{key
}} = $payee;
319 $CACHE{refaddr
($self)}{payee_by_key
} = $index;
322 return $index->{$key};
325 =method find_transactions_by_transfer_key
327 @transactions = $homebank->find_transactions_by_transfer_key($key);
329 Find all transactions that share the same transfer key
.
333 sub find_transactions_by_transfer_key
{
335 my $key = shift or return;
337 my $index = $CACHE{refaddr
($self)}{transactions_by_transfer_key
};
340 for my $transaction (@{$self->transactions}) {
341 my $xfkey = $transaction->{transfer_key
} or next;
342 push @{$index->{$xfkey} ||= []}, $transaction;
345 $CACHE{refaddr
($self)}{transactions_by_transfer_key
} = $index;
348 return @{$index->{$key} || []};
351 =method find_transaction_transfer_pair
353 $other_transaction = $homebank->find_transaction_transfer_pair($transaction);
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
.
360 Returns
undef or empty
if no corresponding transaction
is found
.
364 sub find_transaction_transfer_pair
{
366 my $transaction = shift;
368 return if $transaction->{paymode
} ne 'internaltransfer';
370 my $transfer_key = $transaction->{transfer_key
};
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;
377 warn "Found internal transfer with no tranfer key.\n" if !defined $transfer_key;
379 my $dst_account = $self->find_account_by_key($transaction->{dst_account
});
381 warn "Found internal transfer with no destination account.\n";
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
};
393 my @matching = $self->find_transactions_by_transfer_key($t->{transfer_key
});
394 next if 1 < @matching; # other transaction must also be orphaned
396 push @candidates, $t;
399 my $transaction_day = _ymd_to_julian
($transaction->{date
});
401 # sort the candidates so we can pick the nearest one by date
402 my @ordered_candidates =
404 sort { $a->[0] <=> $b->[0] }
405 map { [abs($transaction_day - _ymd_to_julian
($_->{date
})), $_] } @candidates;
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";
415 =method sorted_transactions
417 $transations = $homebank->sorted_transactions;
419 Get an arrayref of transactions sorted by date
(oldest first
).
423 sub sorted_transactions
{
426 my $sorted_transactions = $CACHE{refaddr
($self)}{sorted_transactions
};
427 if (!$sorted_transactions) {
428 $sorted_transactions = [sort { $a->{date
} cmp $b->{date
} } @{$self->transactions}];
430 $CACHE{refaddr
($self)}{sorted_transactions
} = $sorted_transactions;
433 return $sorted_transactions;
436 =method full_category_name
438 $category_name = $homebank->full_category_name($key);
440 Generate the full name
for a category
, taking category inheritance into consideration
.
451 sub full_category_name
{
453 my $key = shift or return;
455 my $cat = $self->find_category_by_key($key);
457 my @categories = ($cat);
459 while (my $parent_key = $cat->{parent
}) {
460 $cat = $self->find_category_by_key($parent_key);
461 unshift @categories, $cat;
464 return join(':', map { $_->{name
} } @categories);
467 =method format_amount
469 $formatted_amount = $homebank->format_amount($amount);
470 $formatted_amount = $homebank->format_amount($amount, $currency);
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
.
480 my $currency = shift || $self->base_currency;
482 $currency = $self->find_currency_by_key($currency) if !ref($currency);
483 _croak
'Must provide a valid currency' if !$currency;
485 my $format = "\% .$currency->{frac}f";
486 my ($whole, $fraction) = split(/\./, sprintf($format, $amount));
488 my $num = join($currency->{dchar
}, commify
($whole, $currency->{gchar
}), $fraction);
490 $num = $currency->{syprf
} ? "$currency->{symbol} $num" : "$num $currency->{symbol}";
497 $homebank_data = parse_file
($filepath);
499 Read
and parse a HomeBank
.xhb file from a filesystem
.
504 my $filepath = shift or _usage
(q{parse_file($filepath)});
506 open(my $fh, '<', $filepath) or die "open failed: $!";
507 my $str_in = do { local $/; <$fh> };
509 return parse_string
($str_in);
514 $homebank_data = parse_string
($str);
516 Parse a HomeBank file from a string
.
521 my $str = shift or die _usage
(q{parse_string($str)});
530 my $xml_parser = XML
::Parser
::Lite-
>new(
537 # decode all attribute values
538 for my $key (keys %attr) {
539 $attr{$key} = _decode_xml_entities
($attr{$key});
542 if ($node eq 'properties') {
543 $attr{currency
} = delete $attr{curr
} if $attr{curr
};
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};
552 my $flags = delete $attr{flags
} || 0;
553 while (my ($shift, $name) = each %ACCOUNT_FLAGS) {
554 $attr{flags
}{$name} = $flags & (1 << $shift) ? 1 : 0;
557 push @accounts, \
%attr;
559 elsif ($node eq 'pay') { # payee
560 push @payees, \
%attr;
562 elsif ($node eq 'cur') { # currency
563 $attr{symbol
} = delete $attr{symb
} if $attr{symb
};
565 my $flags = delete $attr{flags
} || 0;
566 while (my ($shift, $name) = each %CURRENCY_FLAGS) {
567 $attr{flags
}{$name} = $flags & (1 << $shift) ? 1 : 0;
570 push @currencies, \
%attr;
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;
578 for my $bnum (0 .. 12) {
579 $attr{budget_amounts
}[$bnum] = delete $attr{"b$bnum"} if $attr{"b$bnum"};
582 push @categories, \
%attr;
584 elsif ($node eq 'ope') { # transaction
585 $attr{paymode
} = $TRANSACTION_PAYMODES{$attr{paymode
} || ''} || 'unknown';
586 $attr{status
} = $TRANSACTION_STATUSES{delete $attr{st
}} || 'unknown';
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
};
593 $attr{date
} = _rdn_to_ymd
($attr{date
}) if $attr{date
};
595 my $flags = delete $attr{flags
} || 0;
596 while (my ($shift, $name) = each %TRANSACTION_FLAGS) {
597 $attr{flags
}{$name} = $flags & (1 << $shift) ? 1 : 0;
600 push @transactions, \
%attr;
605 $xml_parser->parse($str);
608 properties
=> \
%properties,
609 accounts
=> \
@accounts,
611 categories
=> \
@categories,
612 currencies
=> \
@currencies,
613 transactions
=> \
@transactions,
617 sub _decode_xml_entities
{
619 # decoding entities can be extremely slow, so don't bother if it doesn't look like there are any
621 return $str if $str !~ /&(?:#\d+)|[A-Za-z0-9]+;/;
622 return XML
::Entities
::decode
('all', $str);
625 sub _rdn_to_unix_epoch
{
627 my $jan01_1970 = 719163;
628 return ($rdn - $jan01_1970) * 86400;
633 my $epoch = _rdn_to_unix_epoch
($rdn);
634 my $time = gmtime($epoch);
640 my $t = Time
::Piece-
>strptime($ymd, '%Y-%m-%d');
641 return $t->julian_day;