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.001'; # 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                     push @categories, \%attr;
 415                 }
 416                 elsif ($node eq 'ope') {    # transaction
 417                     $attr{paymode} = $TRANSACTION_PAYMODES{$attr{paymode} || ''} || 'unknown';
 418                     $attr{status}  = $TRANSACTION_STATUSES{delete $attr{st}} || 'unknown';
 419
 420                     $attr{transfer_key}   = delete $attr{kxfer} if $attr{kxfer};
 421                     $attr{split_amount}   = delete $attr{samt}  if $attr{samt};
 422                     $attr{split_memo}     = delete $attr{smem}  if $attr{smem};
 423                     $attr{split_category} = delete $attr{scat}  if $attr{scat};
 424
 425                     $attr{date} = _rdn_to_ymd($attr{date}) if $attr{date};
 426
 427                     my $flags = delete $attr{flags} || 0;
 428                     while (my ($shift, $name) = each %TRANSACTION_FLAGS) {
 429                         $attr{flags}{$name} = $flags & (1 << $shift) ? 1 : 0;
 430                     }
 431
 432                     push @transactions, \%attr;
 433                 }
 434             },
 435         },
 436     );
 437     $xml_parser->parse($str);
 438
 439     return {
 440         properties      => \%properties,
 441         accounts        => \@accounts,
 442         payees          => \@payees,
 443         categories      => \@categories,
 444         currencies      => \@currencies,
 445         transactions    => \@transactions,
 446     };
 447 }
 448
 449 sub _decode_xml_entities {
 450     my $str = shift;
 451     # decoding entities can be extremely slow, so don't bother if it doesn't look like there are any
 452     # entities to decode
 453     return $str if $str !~ /&(?:#\d+)|[A-Za-z0-9]+;/;
 454     return XML::Entities::decode('all', $str);
 455 }
 456
 457 sub _rdn_to_unix_epoch {
 458     my $rdn = shift;
 459     my $jan01_1970 = 719163;
 460     return ($rdn - $jan01_1970) * 86400;
 461 }
 462
 463 sub _rdn_to_ymd {
 464     my $rdn = shift;
 465     my $epoch = _rdn_to_unix_epoch($rdn);
 466     my $time = gmtime($epoch);
 467     return $time->ymd;
 468 };
 469
 470 sub _ymd_to_julian {
 471     my $ymd = shift;
 472     my $t = Time::Piece->strptime($ymd, '%Y-%m-%d');
 473     return $t->julian_day;
 474 }
 475
 476 1;
 477
 478 __END__
 479
 480 =pod
 481
 482 =encoding UTF-8
 483
 484 =head1 NAME
 485
 486 File::HomeBank - Parse HomeBank files
 487
 488 =head1 VERSION
 489
 490 version 0.001
 491
 492 =head1 SYNOPSIS
 493
 494     # Functional:
 495
 496     use File::HomeBank qw(parse_file);
 497
 498     my $raw_data = parse_file('path/to/homebank.xhb');
 499
 500     # Or OOP:
 501
 502     my $homebank = File::HomeBank->new(file => 'path/to/homebank.xhb');
 503
 504     for my $account (@{$homebank->accounts}) {
 505         print "Found account named $account->{name}\n";
 506     }
 507
 508 =head1 DESCRIPTION
 509
 510 This module parses L<HomeBank|http://homebank.free.fr/> files.
 511
 512 =head1 ATTRIBUTES
 513
 514 =head2 file
 515
 516 Get the filepath (if parsed from a file).
 517
 518 =head1 METHODS
 519
 520 =head2 new
 521
 522     $homebank = File::HomeBank->new(string => $str);
 523     $homebank = File::HomeBank->new(file => $filepath);
 524
 525 Construct a L<File::HomeBank>.
 526
 527 =head2 title
 528
 529     $title = $homebank->title;
 530
 531 Get the title or owner property.
 532
 533 =head2 base_currency
 534
 535     $base_currency = $homebank->base_currency;
 536
 537 Get the key of the base currency.
 538
 539 =head2 accounts
 540
 541 Get an arrayref of accounts.
 542
 543 =head2 categories
 544
 545 Get an arrayref of categories.
 546
 547 =head2 currencies
 548
 549 Get an arrayref of currencies.
 550
 551 =head2 payees
 552
 553 Get an arrayref of payees.
 554
 555 =head2 tags
 556
 557 Get an arrayref of tags.
 558
 559 =head2 transactions
 560
 561 Get an arrayref of transactions.
 562
 563 =head2 find_account_by_key
 564
 565     $account = $homebank->find_account_by_key($key);
 566
 567 Find a account with the given key.
 568
 569 =head2 find_currency_by_key
 570
 571     $currency = $homebank->find_currency_by_key($key);
 572
 573 Find a currency with the given key.
 574
 575 =head2 find_category_by_key
 576
 577     $category = $homebank->find_category_by_key($key);
 578
 579 Find a category with the given key.
 580
 581 =head2 find_payee_by_key
 582
 583     $payee = $homebank->find_payee_by_key($key);
 584
 585 Find a payee with the given key.
 586
 587 =head2 find_transactions_by_transfer_key
 588
 589     @transactions = $homebank->find_transactions_by_transfer_key($key);
 590
 591 Find all transactions that share the same transfer key.
 592
 593 =head2 find_transaction_transfer_pair
 594
 595     $other_transaction = $homebank->find_transaction_transfer_pair($transaction);
 596
 597 Given a transaction hashref, return its corresponding transaction if it is an internal transfer. If
 598 the transaction is an internal transaction with a destination account but is orphaned (has no
 599 matching transfer key), this also looks for another orphaned transaction in the destination account
 600 that it can call its partner.
 601
 602 Returns undef or empty if no corresponding transaction is found.
 603
 604 =head2 sorted_transactions
 605
 606     $transations = $homebank->sorted_transactions;
 607
 608 Get an arrayref of transactions sorted by date (oldest first).
 609
 610 =head2 full_category_name
 611
 612     $category_name = $homebank->full_category_name($key);
 613
 614 Generate the full name for a category, taking category inheritance into consideration.
 615
 616     Income
 617       Salary    <--
 618
 619 will become:
 620
 621     "Income:Salary"
 622
 623 =head2 format_amount
 624
 625     $formatted_amount = $homebank->format_amount($amount);
 626     $formatted_amount = $homebank->format_amount($amount, $currency);
 627
 628 Formats an amount in either the base currency (for the whole file) or in the given currency.
 629 Currency can be a key or the actualy currency structure.
 630
 631 =head1 FUNCTIONS
 632
 633 =head2 parse_file
 634
 635     $homebank_data = parse_file($filepath);
 636
 637 Read and parse a HomeBank .xhb file from a filesystem.
 638
 639 =head2 parse_string
 640
 641     $homebank_data = parse_string($str);
 642
 643 Parse a HomeBank file from a string.
 644
 645 =head1 BUGS
 646
 647 Please report any bugs or feature requests on the bugtracker website
 648 L<https://github.com/chazmcgarvey/homebank2ledger/issues>
 649
 650 When submitting a bug or request, please include a test-file or a
 651 patch to an existing test-file that illustrates the bug or desired
 652 feature.
 653
 654 =head1 AUTHOR
 655
 656 Charles McGarvey <chazmcgarvey@brokenzipper.com>
 657
 658 =head1 COPYRIGHT AND LICENSE
 659
 660 This software is Copyright (c) 2019 by Charles McGarvey.
 661
 662 This is free software, licensed under:
 663
 664   The MIT (X11) License
 665
 666 =cut