Dogcows Code - chaz/homebank2ledger/blob - lib/File/HomeBank.pm

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