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