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 file_version
 156
 157     $version = $homebank->file_version;
 158
 159 Get the file format version.
 160
 161 =cut
 162
 163 sub file_version {
 164     shift->{homebank}{version};
 165 }
 166
 167 =method title
 168
 169     $title = $homebank->title;
 170
 171 Get the title or owner property.
 172
 173 =cut
 174
 175 sub title {
 176     shift->{properties}{title};
 177 }
 178
 179 =method base_currency
 180
 181     $base_currency = $homebank->base_currency;
 182
 183 Get the key of the base currency.
 184
 185 =cut
 186
 187 sub base_currency {
 188     shift->{properties}{currency};
 189 }
 190
 191 =method accounts
 192
 193 Get an arrayref of accounts.
 194
 195 =method categories
 196
 197 Get an arrayref of categories.
 198
 199 =method currencies
 200
 201 Get an arrayref of currencies.
 202
 203 =method payees
 204
 205 Get an arrayref of payees.
 206
 207 =method tags
 208
 209 Get an arrayref of tags.
 210
 211 =method transactions
 212
 213 Get an arrayref of transactions.
 214
 215 =cut
 216
 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} || [] }
 222
 223 sub tags {
 224     my $self = shift;
 225
 226     my %tags;
 227
 228     for my $transaction (@{$self->transactions}) {
 229         for my $tag (split(/\h+/, $transaction->{tags} || '')) {
 230             $tags{$tag} = 1;
 231         }
 232     }
 233
 234     return [keys %tags];
 235 }
 236
 237 =method find_account_by_key
 238
 239     $account = $homebank->find_account_by_key($key);
 240
 241 Find an account with the given key.
 242
 243 =cut
 244
 245 sub find_account_by_key {
 246     my $self = shift;
 247     my $key  = shift or return;
 248
 249     my $index = $CACHE{refaddr($self)}{account_by_key};
 250     if (!$index) {
 251         # build index
 252         for my $account (@{$self->accounts}) {
 253             $index->{$account->{key}} = $account;
 254         }
 255
 256         $CACHE{refaddr($self)}{account_by_key} = $index;
 257     }
 258
 259     return $index->{$key};
 260 }
 261
 262 =method find_currency_by_key
 263
 264     $currency = $homebank->find_currency_by_key($key);
 265
 266 Find a currency with the given key.
 267
 268 =cut
 269
 270 sub find_currency_by_key {
 271     my $self = shift;
 272     my $key  = shift or return;
 273
 274     my $index = $CACHE{refaddr($self)}{currency_by_key};
 275     if (!$index) {
 276         # build index
 277         for my $currency (@{$self->currencies}) {
 278             $index->{$currency->{key}} = $currency;
 279         }
 280
 281         $CACHE{refaddr($self)}{currency_by_key} = $index;
 282     }
 283
 284     return $index->{$key};
 285 }
 286
 287 =method find_category_by_key
 288
 289     $category = $homebank->find_category_by_key($key);
 290
 291 Find a category with the given key.
 292
 293 =cut
 294
 295 sub find_category_by_key {
 296     my $self = shift;
 297     my $key  = shift or return;
 298
 299     my $index = $CACHE{refaddr($self)}{category_by_key};
 300     if (!$index) {
 301         # build index
 302         for my $category (@{$self->categories}) {
 303             $index->{$category->{key}} = $category;
 304         }
 305
 306         $CACHE{refaddr($self)}{category_by_key} = $index;
 307     }
 308
 309     return $index->{$key};
 310 }
 311
 312 =method find_payee_by_key
 313
 314     $payee = $homebank->find_payee_by_key($key);
 315
 316 Find a payee with the given key.
 317
 318 =cut
 319
 320 sub find_payee_by_key {
 321     my $self = shift;
 322     my $key  = shift or return;
 323
 324     my $index = $CACHE{refaddr($self)}{payee_by_key};
 325     if (!$index) {
 326         # build index
 327         for my $payee (@{$self->payees}) {
 328             $index->{$payee->{key}} = $payee;
 329         }
 330
 331         $CACHE{refaddr($self)}{payee_by_key} = $index;
 332     }
 333
 334     return $index->{$key};
 335 }
 336
 337 =method find_transactions_by_transfer_key
 338
 339     @transactions = $homebank->find_transactions_by_transfer_key($key);
 340
 341 Find all transactions that share the same transfer key.
 342
 343 =cut
 344
 345 sub find_transactions_by_transfer_key {
 346     my $self = shift;
 347     my $key  = shift or return;
 348
 349     my $index = $CACHE{refaddr($self)}{transactions_by_transfer_key};
 350     if (!$index) {
 351         # build index
 352         for my $transaction (@{$self->transactions}) {
 353             my $xfkey = $transaction->{transfer_key} or next;
 354             push @{$index->{$xfkey} ||= []}, $transaction;
 355         }
 356
 357         $CACHE{refaddr($self)}{transactions_by_transfer_key} = $index;
 358     }
 359
 360     return @{$index->{$key} || []};
 361 }
 362
 363 =method find_transaction_transfer_pair
 364
 365     $other_transaction = $homebank->find_transaction_transfer_pair($transaction);
 366
 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.
 371
 372 Returns undef or empty if no corresponding transaction is found.
 373
 374 =cut
 375
 376 sub find_transaction_transfer_pair {
 377     my $self = shift;
 378     my $transaction = shift;
 379
 380     return if $transaction->{paymode} ne 'internaltransfer';
 381
 382     my $transfer_key = $transaction->{transfer_key};
 383
 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;
 388
 389     warn "Found internal transfer with no tranfer key.\n" if !defined $transfer_key;
 390
 391     my $dst_account = $self->find_account_by_key($transaction->{dst_account});
 392     if (!$dst_account) {
 393         warn "Found internal transfer with no destination account.\n";
 394         return;
 395     }
 396
 397     my @candidates;
 398
 399     for my $t (@{$self->transactions}) {
 400         next if $t->{paymode} ne 'internaltransfer';
 401         next if $t->{account} != $transaction->{dst_account};
 402         next if $t->{dst_account} != $transaction->{account};
 403         next if $t->{amount} != -$transaction->{amount};
 404
 405         my @matching = $self->find_transactions_by_transfer_key($t->{transfer_key});
 406         next if 1 < @matching;  # other transaction must also be orphaned
 407
 408         push @candidates, $t;
 409     }
 410
 411     my $transaction_day = _ymd_to_julian($transaction->{date});
 412
 413     # sort the candidates so we can pick the nearest one by date
 414     my @ordered_candidates =
 415         map { $_->[1] }
 416         sort { $a->[0] <=> $b->[0] }
 417         map { [abs($transaction_day - _ymd_to_julian($_->{date})), $_] } @candidates;
 418
 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";
 423         return $winner;
 424     }
 425 }
 426
 427 =method sorted_transactions
 428
 429     $transations = $homebank->sorted_transactions;
 430
 431 Get an arrayref of transactions sorted by date (oldest first).
 432
 433 =cut
 434
 435 sub sorted_transactions {
 436     my $self = shift;
 437
 438     my $sorted_transactions = $CACHE{refaddr($self)}{sorted_transactions};
 439     if (!$sorted_transactions) {
 440         $sorted_transactions = [sort { $a->{date} cmp $b->{date} } @{$self->transactions}];
 441
 442         $CACHE{refaddr($self)}{sorted_transactions} = $sorted_transactions;
 443     }
 444
 445     return $sorted_transactions;
 446 }
 447
 448 =method full_category_name
 449
 450     $category_name = $homebank->full_category_name($key);
 451
 452 Generate the full name for a category, taking category inheritance into consideration.
 453
 454     Income
 455       Salary    <--
 456
 457 will become:
 458
 459     "Income:Salary"
 460
 461 =cut
 462
 463 sub full_category_name {
 464     my $self = shift;
 465     my $key  = shift or return;
 466
 467     my $cat = $self->find_category_by_key($key);
 468
 469     my @categories = ($cat);
 470
 471     while (my $parent_key = $cat->{parent}) {
 472         $cat = $self->find_category_by_key($parent_key);
 473         unshift @categories, $cat;
 474     }
 475
 476     return join(':', map { $_->{name} } @categories);
 477 }
 478
 479 =method format_amount
 480
 481     $formatted_amount = $homebank->format_amount($amount);
 482     $formatted_amount = $homebank->format_amount($amount, $currency);
 483
 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.
 486
 487 =cut
 488
 489 sub format_amount {
 490     my $self     = shift;
 491     my $amount   = shift;
 492     my $currency = shift || $self->base_currency;
 493
 494     $currency = $self->find_currency_by_key($currency) if !ref($currency);
 495     _croak 'Must provide a valid currency' if !$currency;
 496
 497     my $format = "\% .$currency->{frac}f";
 498     my ($whole, $fraction) = split(/\./, sprintf($format, $amount));
 499
 500     my $num = join($currency->{dchar}, commify($whole, $currency->{gchar}), $fraction);
 501
 502     $num = $currency->{syprf} ? "$currency->{symbol} $num" : "$num $currency->{symbol}";
 503
 504     return $num;
 505 }
 506
 507 =func parse_file
 508
 509     $homebank_data = parse_file($filepath);
 510
 511 Read and parse a HomeBank .xhb file from a filesystem.
 512
 513 =cut
 514
 515 sub parse_file {
 516     my $filepath = shift or _usage(q{parse_file($filepath)});
 517
 518     open(my $fh, '<', $filepath) or die "open failed: $!";
 519     my $str_in = do { local $/; <$fh> };
 520
 521     return parse_string($str_in);
 522 }
 523
 524 =func parse_string
 525
 526     $homebank_data = parse_string($str);
 527
 528 Parse a HomeBank file from a string.
 529
 530 =cut
 531
 532 sub parse_string {
 533     my $str = shift or die _usage(q{parse_string($str)});
 534
 535     my %homebank;
 536     my %properties;
 537     my @accounts;
 538     my @payees;
 539     my @categories;
 540     my @currencies;
 541     my @transactions;
 542
 543     my $xml_parser = XML::Parser::Lite->new(
 544         Handlers => {
 545             Start   => sub {
 546                 shift;
 547                 my $node = shift;
 548                 my %attr = @_;
 549
 550                 # decode all attribute values
 551                 for my $key (keys %attr) {
 552                     $attr{$key} = _decode_xml_entities($attr{$key});
 553                 }
 554
 555                 if ($node eq 'homebank') {
 556                     $attr{version} = delete $attr{v} if $attr{v};
 557                     %homebank = %attr;
 558                 }
 559                 elsif ($node eq 'properties') {
 560                     $attr{currency} = delete $attr{curr} if $attr{curr};
 561                     %properties = %attr;
 562                 }
 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};
 568
 569                     my $flags = delete $attr{flags} || 0;
 570                     while (my ($shift, $name) = each %ACCOUNT_FLAGS) {
 571                         $attr{flags}{$name} = $flags & (1 << $shift) ? 1 : 0;
 572                     }
 573
 574                     push @accounts, \%attr;
 575                 }
 576                 elsif ($node eq 'pay') {    # payee
 577                     push @payees, \%attr;
 578                 }
 579                 elsif ($node eq 'cur') {    # currency
 580                     $attr{symbol} = delete $attr{symb} if $attr{symb};
 581
 582                     my $flags = delete $attr{flags} || 0;
 583                     while (my ($shift, $name) = each %CURRENCY_FLAGS) {
 584                         $attr{flags}{$name} = $flags & (1 << $shift) ? 1 : 0;
 585                     }
 586
 587                     push @currencies, \%attr;
 588                 }
 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;
 593                     }
 594
 595                     for my $bnum (0 .. 12) {
 596                         $attr{budget_amounts}[$bnum] = delete $attr{"b$bnum"} if $attr{"b$bnum"};
 597                     }
 598
 599                     push @categories, \%attr;
 600                 }
 601                 elsif ($node eq 'ope') {    # transaction
 602                     $attr{paymode} = $TRANSACTION_PAYMODES{$attr{paymode}   || ''} || 'unknown';
 603                     $attr{status}  = $TRANSACTION_STATUSES{delete $attr{st} || ''} || 'unknown';
 604
 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};
 609
 610                     $attr{date} = _rdn_to_ymd($attr{date}) if $attr{date};
 611
 612                     my $flags = delete $attr{flags} || 0;
 613                     while (my ($shift, $name) = each %TRANSACTION_FLAGS) {
 614                         $attr{flags}{$name} = $flags & (1 << $shift) ? 1 : 0;
 615                     }
 616
 617                     push @transactions, \%attr;
 618                 }
 619             },
 620         },
 621     );
 622     $xml_parser->parse($str);
 623
 624     return {
 625         homebank        => \%homebank,
 626         properties      => \%properties,
 627         accounts        => \@accounts,
 628         payees          => \@payees,
 629         categories      => \@categories,
 630         currencies      => \@currencies,
 631         transactions    => \@transactions,
 632     };
 633 }
 634
 635 sub _decode_xml_entities {
 636     my $str = shift;
 637     # decoding entities can be extremely slow, so don't bother if it doesn't look like there are any
 638     # entities to decode
 639     return $str if $str !~ /&(?:#\d+)|[A-Za-z0-9]+;/;
 640     return XML::Entities::decode('all', $str);
 641 }
 642
 643 sub _rdn_to_unix_epoch {
 644     my $rdn = shift;
 645     my $jan01_1970 = 719163;
 646     return ($rdn - $jan01_1970) * 86400;
 647 }
 648
 649 sub _rdn_to_ymd {
 650     my $rdn = shift;
 651     my $epoch = _rdn_to_unix_epoch($rdn);
 652     my $time = gmtime($epoch);
 653     return $time->ymd;
 654 };
 655
 656 sub _ymd_to_julian {
 657     my $ymd = shift;
 658     my $t = Time::Piece->strptime($ymd, '%Y-%m-%d');
 659     return $t->julian_day;
 660 }
 661
 662 1;