Dogcows Code - chaz/homebank2ledger/blob - 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;