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