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);
33 use XML
::Parser
::Lite
;
35 our $VERSION = '9999.999'; # VERSION
37 our @EXPORT_OK = qw(parse_string parse_file);
39 sub _croak
{ require Carp
; Carp
::croak
(@_) }
40 sub _usage
{ _croak
("Usage: @_\n") }
64 my %CURRENCY_FLAGS = (
67 my %CATEGORY_FLAGS = (
74 my %TRANSACTION_FLAGS = (
85 my %TRANSACTION_STATUSES = (
92 my %TRANSACTION_PAYMODES = (
98 5 => 'internaltransfer',
100 7 => 'repeatpayment',
109 $homebank = File
::HomeBank-
>new(string
=> $str);
110 $homebank = File
::HomeBank-
>new(file
=> $filepath);
112 Construct a L
<File
::HomeBank
>.
124 if (my $filepath = $args{file
}) {
125 $self = parse_file
($filepath);
126 $self->{file
} = $filepath;
128 elsif (my $str = $args{string
}) {
129 $self = parse_string
($str);
132 _usage
(q{File::HomeBank->new(string => $str)});
135 return bless $self, $class;
140 my $in_global_destruction = shift;
141 delete $CACHE{refaddr
($self)} if !$in_global_destruction;
146 Get the filepath
(if parsed from a file
).
156 $title = $homebank->title;
158 Get the title
or owner property
.
163 shift-
>{properties
}{title
};
166 =method base_currency
168 $base_currency = $homebank->base_currency;
170 Get the key of the base currency
.
175 shift-
>{properties
}{currency
};
180 Get an arrayref of accounts
.
184 Get an arrayref of categories
.
188 Get an arrayref of currencies
.
192 Get an arrayref of payees
.
196 Get an arrayref of tags
.
200 Get an arrayref of transactions
.
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
} || [] }
215 for my $transaction (@{$self->transactions}) {
216 for my $tag (split(/\h+/, $transaction->{tags
} || '')) {
224 =method find_account_by_key
226 $account = $homebank->find_account_by_key($key);
228 Find a account with the
given key
.
232 sub find_account_by_key
{
234 my $key = shift or return;
236 my $index = $CACHE{refaddr
($self)}{account_by_key
};
239 for my $account (@{$self->accounts}) {
240 $index->{$account->{key
}} = $account;
243 $CACHE{refaddr
($self)}{account_by_key
} = $index;
246 return $index->{$key};
249 =method find_currency_by_key
251 $currency = $homebank->find_currency_by_key($key);
253 Find a currency with the
given key
.
257 sub find_currency_by_key
{
259 my $key = shift or return;
261 my $index = $CACHE{refaddr
($self)}{currency_by_key
};
264 for my $currency (@{$self->currencies}) {
265 $index->{$currency->{key
}} = $currency;
268 $CACHE{refaddr
($self)}{currency_by_key
} = $index;
271 return $index->{$key};
274 =method find_category_by_key
276 $category = $homebank->find_category_by_key($key);
278 Find a category with the
given key
.
282 sub find_category_by_key
{
284 my $key = shift or return;
286 my $index = $CACHE{refaddr
($self)}{category_by_key
};
289 for my $category (@{$self->categories}) {
290 $index->{$category->{key
}} = $category;
293 $CACHE{refaddr
($self)}{category_by_key
} = $index;
296 return $index->{$key};
299 =method find_payee_by_key
301 $payee = $homebank->find_payee_by_key($key);
303 Find a payee with the
given key
.
307 sub find_payee_by_key
{
309 my $key = shift or return;
311 my $index = $CACHE{refaddr
($self)}{payee_by_key
};
314 for my $payee (@{$self->payees}) {
315 $index->{$payee->{key
}} = $payee;
318 $CACHE{refaddr
($self)}{payee_by_key
} = $index;
321 return $index->{$key};
324 =method find_transactions_by_transfer_key
326 @transactions = $homebank->find_transactions_by_transfer_key($key);
328 Find all transactions that share the same transfer key
.
332 sub find_transactions_by_transfer_key
{
334 my $key = shift or return;
336 my $index = $CACHE{refaddr
($self)}{transactions_by_transfer_key
};
339 for my $transaction (@{$self->transactions}) {
340 my $xfkey = $transaction->{transfer_key
} or next;
341 push @{$index->{$xfkey} ||= []}, $transaction;
344 $CACHE{refaddr
($self)}{transactions_by_transfer_key
} = $index;
347 return @{$index->{$key} || []};
350 =method find_transaction_transfer_pair
352 $other_transaction = $homebank->find_transaction_transfer_pair($transaction);
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
.
359 Returns
undef or empty
if no corresponding transaction
is found
.
363 sub find_transaction_transfer_pair
{
365 my $transaction = shift;
367 return if $transaction->{paymode
} ne 'internaltransfer';
369 my $transfer_key = $transaction->{transfer_key
};
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;
376 warn "Found internal transfer with no tranfer key.\n" if !defined $transfer_key;
378 my $dst_account = $self->find_account_by_key($transaction->{dst_account
});
380 warn "Found internal transfer with no destination account.\n";
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
};
392 my @matching = $self->find_transactions_by_transfer_key($t->{transfer_key
});
393 next if 1 < @matching; # other transaction must also be orphaned
395 push @candidates, $t;
398 my $transaction_day = _ymd_to_julian
($transaction->{date
});
400 # sort the candidates so we can pick the nearest one by date
401 my @ordered_candidates =
403 sort { $a->[0] <=> $b->[0] }
404 map { [abs($transaction_day - _ymd_to_julian
($_->{date
})), $_] } @candidates;
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";
414 =method sorted_transactions
416 $transations = $homebank->sorted_transactions;
418 Get an arrayref of transactions sorted by date
(earliest first
).
422 sub sorted_transactions
{
425 my $sorted_transactions = $CACHE{refaddr
($self)}{sorted_transactions
};
426 if (!$sorted_transactions) {
427 $sorted_transactions = [sort { $a->{date
} cmp $b->{date
} } @{$self->transactions}];
429 $CACHE{refaddr
($self)}{sorted_transactions
} = $sorted_transactions;
432 return $sorted_transactions;
435 =method full_category_name
437 $category_name = $homebank->full_category_name($key);
439 Generate the full name
for a category
, taking category inheritance into consideration
.
450 sub full_category_name
{
452 my $key = shift or return;
454 my $cat = $self->find_category_by_key($key);
456 my @categories = ($cat);
458 while (my $parent_key = $cat->{parent
}) {
459 $cat = $self->find_category_by_key($parent_key);
460 unshift @categories, $cat;
463 return join(':', map { $_->{name
} } @categories);
466 =method format_amount
468 $formatted_amount = $homebank->format_amount($amount);
469 $formatted_amount = $homebank->format_amount($amount, $currency);
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
.
479 my $currency = shift || $self->base_currency;
481 $currency = $self->find_currency_by_key($currency) if !ref($currency);
482 _croak
'Must provide a valid currency' if !$currency;
484 my $format = "\% .$currency->{frac}f";
485 my ($whole, $fraction) = split(/\./, sprintf($format, $amount));
487 my $num = join($currency->{dchar
}, commify
($whole, $currency->{gchar
}), $fraction);
489 $num = $currency->{syprf
} ? "$currency->{symbol} $num" : "$num $currency->{symbol}";
496 $homebank_data = parse_file
($filepath);
498 Read
and parse a HomeBank
.xhb file from a filesystem
.
503 my $filepath = shift or _usage
(q{parse_file($filepath)});
505 open(my $fh, '<', $filepath) or die "open failed: $!";
506 my $str_in = do { local $/; <$fh> };
508 return parse_string
($str_in);
513 $homebank_data = parse_string
($str);
515 Parse a HomeBank file from a string
.
520 my $str = shift or die _usage
(q{parse_string($str)});
529 my $xml_parser = XML
::Parser
::Lite-
>new(
535 if ($node eq 'properties') {
536 $attr{currency
} = delete $attr{curr
} if $attr{curr
};
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};
545 my $flags = delete $attr{flags
} || 0;
546 while (my ($shift, $name) = each %ACCOUNT_FLAGS) {
547 $attr{flags
}{$name} = $flags & (1 << $shift) ? 1 : 0;
550 push @accounts, \
%attr;
552 elsif ($node eq 'pay') { # payee
553 push @payees, \
%attr;
555 elsif ($node eq 'cur') { # currency
556 $attr{symbol
} = delete $attr{symb
} if $attr{symb
};
558 my $flags = delete $attr{flags
} || 0;
559 while (my ($shift, $name) = each %CURRENCY_FLAGS) {
560 $attr{flags
}{$name} = $flags & (1 << $shift) ? 1 : 0;
563 push @currencies, \
%attr;
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;
571 push @categories, \
%attr;
573 elsif ($node eq 'ope') { # transaction
574 $attr{paymode
} = $TRANSACTION_PAYMODES{$attr{paymode
} || ''} || 'unknown';
575 $attr{status
} = $TRANSACTION_STATUSES{delete $attr{st
}} || 'unknown';
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
};
582 $attr{date
} = _rdn_to_ymd
($attr{date
}) if $attr{date
};
584 my $flags = delete $attr{flags
} || 0;
585 while (my ($shift, $name) = each %TRANSACTION_FLAGS) {
586 $attr{flags
}{$name} = $flags & (1 << $shift) ? 1 : 0;
589 push @transactions, \
%attr;
594 $xml_parser->parse($str);
597 properties
=> \
%properties,
598 accounts
=> \
@accounts,
600 categories
=> \
@categories,
601 currencies
=> \
@currencies,
602 transactions
=> \
@transactions,
606 sub _rdn_to_unix_epoch
{
608 my $jan01_1970 = 719163;
609 return ($rdn - $jan01_1970) * 86400;
614 my $epoch = _rdn_to_unix_epoch
($rdn);
615 my $time = gmtime($epoch);
621 my $t = Time
::Piece-
>strptime($ymd, '%Y-%m-%d');
622 return $t->julian_day;