Dogcows Code - chaz/homebank2ledger/blob - lib/App/HomeBank2Ledger/Formatter/Beancount.pm

   1 package App::HomeBank2Ledger::Formatter::Beancount;
   2 # ABSTRACT: Beancount formatter
   3
   4 =head1 DESCRIPTION
   5
   6 This is a formatter for L<Beancount|http://furius.ca/beancount/>.
   7
   8 =head1 SEE ALSO
   9
  10 L<App::HomeBank2Ledger::Formatter>
  11
  12 =cut
  13
  14 use v5.10.1;    # defined-or
  15 use warnings;
  16 use strict;
  17
  18 use App::HomeBank2Ledger::Util qw(commify rtrim);
  19 use Scalar::Util qw(looks_like_number);
  20
  21 use parent 'App::HomeBank2Ledger::Formatter';
  22
  23 our $VERSION = '9999.999'; # VERSION
  24
  25 my %STATUS_SYMBOLS = (
  26     cleared => '*',
  27     pending => '!',
  28 );
  29 my $UNKNOWN_DATE = '0001-01-01';
  30
  31 sub _croak { require Carp; Carp::croak(@_) }
  32
  33 sub format {
  34     my $self   = shift;
  35     my $ledger = shift;
  36
  37     my @out = (
  38         $self->format_header,
  39         $self->format_accounts($ledger),
  40         $self->format_commodities($ledger),
  41         # $self->format_payees,
  42         # $self->format_tags,
  43         $self->format_transactions($ledger),
  44     );
  45
  46     return join($/, map { rtrim($_) } @out);
  47 }
  48
  49 =method format_header
  50
  51     @lines = $formatter->format_header;
  52
  53 Get formatted header. For example,
  54
  55     ; Name: My Finances
  56     ; File: path/to/finances.xhb
  57
  58 =cut
  59
  60 sub format_header {
  61     my $self = shift;
  62
  63     my @out;
  64
  65     if (my $name = $self->name) {
  66         push @out, "; Name: $name";
  67     }
  68     if (my $file = $self->file) {
  69         push @out, "; File: $file";
  70     }
  71
  72     push @out, '';
  73
  74     return @out;
  75 }
  76
  77 =method format_accounts
  78
  79     @lines = $formatter->format_accounts($ledger);
  80
  81 Get formatted accounts. For example,
  82
  83     2003-02-14 open Assets:Bank:Credit-Union:Savings
  84     2003-02-14 open Assets:Bank:Credit-Union:Checking
  85     ...
  86
  87 =cut
  88
  89 sub format_accounts {
  90     my $self   = shift;
  91     my $ledger = shift;
  92
  93     my @out;
  94
  95     for my $account (sort @{$ledger->accounts}) {
  96         my $oldest_transaction = $self->_find_oldest_transaction_by_account($account, $ledger);
  97         my $account_date = $oldest_transaction->{date} || $UNKNOWN_DATE;
  98         $account = $self->_format_account($account);
  99
 100         push @out, "${account_date} open ${account}";
 101     }
 102     push @out, '';
 103
 104     return @out;
 105 }
 106
 107 =method format_commodities
 108
 109     @lines = $formatter->format_commodities($ledger);
 110
 111 Get formattted commodities. For example,
 112
 113     2003-02-14 commodity USD
 114         name: "US Dollar"
 115     ...
 116
 117 =cut
 118
 119 sub format_commodities {
 120     my $self   = shift;
 121     my $ledger = shift;
 122
 123     my @out;
 124
 125     for my $commodity (@{$ledger->commodities}) {
 126         my $oldest_transaction = $self->_find_oldest_transaction_by_commodity($commodity, $ledger);
 127         my $commodity_date = $oldest_transaction->{date} || $UNKNOWN_DATE;
 128
 129         push @out, "${commodity_date} commodity $commodity->{iso}";
 130         push @out, '    name: '.$self->_format_string($commodity->{name}) if $commodity->{name};
 131     }
 132
 133     push @out, '';
 134
 135     return @out;
 136 }
 137
 138 =method format_transactions
 139
 140     @lines = $formatter->format_transactions($ledger);
 141
 142 Get formatted transactions. For example,
 143
 144     2003-02-14 * "Opening Balance"
 145         Assets:Bank:Credit-Union:Savings           458.21 USD
 146         Assets:Bank:Credit-Union:Checking          194.17 USD
 147         Equity:Opening-Balances
 148
 149     ...
 150
 151 =cut
 152
 153 sub format_transactions {
 154     my $self   = shift;
 155     my $ledger = shift;
 156
 157     my @out;
 158
 159     for my $transaction (@{$ledger->transactions}) {
 160         push @out, $self->_format_transaction($transaction);
 161     }
 162
 163     return @out;
 164 }
 165
 166 sub _format_transaction {
 167     my $self        = shift;
 168     my $transaction = shift;
 169
 170     my $account_width = $self->account_width;
 171
 172     my $date        = $transaction->{date};
 173     my $status      = $transaction->{status};
 174     my $payee       = $transaction->{payee} || '';
 175     my $memo        = $transaction->{memo}  || '';
 176     my @postings    = @{$transaction->{postings}};
 177
 178     my @out;
 179
 180     # figure out the Ledger transaction status
 181     my $status_symbol = $STATUS_SYMBOLS{$status || ''};
 182     if (!$status_symbol) {
 183         my %posting_statuses = map { ($_->{status} || '') => 1 } @postings;
 184         if (keys(%posting_statuses) == 1) {
 185             my ($status) = keys %posting_statuses;
 186             $status_symbol = $STATUS_SYMBOLS{$status || 'none'} || '';
 187         }
 188     }
 189
 190     push @out, sprintf('%s%s%s%s', $date,
 191         $status_symbol    && ' '.$status_symbol || ' *',   # status (or "txn") is required
 192         ($payee || $memo) && ' '.$self->_format_string($payee),
 193         $memo             && ' '.$self->_format_string($memo),
 194     );
 195
 196     if (my %tags = map { $_ => 1 } map { @{$_->{tags} || []} } @postings) {
 197         my @tags = map { "#$_" } keys %tags;
 198         $out[-1] .= ' '.join(' ', @tags);
 199     }
 200
 201     my $metadata = $transaction->{metadata} || {};
 202     for my $key (sort keys %$metadata) {
 203         my $value = looks_like_number($metadata->{$key}) ? $metadata->{$key}
 204                                                          : $self->_format_string($metadata->{$key});
 205         push @out, "    ; ${key}: ${value}";
 206     }
 207
 208     for my $posting (@postings) {
 209         my @line;
 210
 211         my $posting_status_symbol = '';
 212         if (!$status_symbol) {
 213             $posting_status_symbol = $STATUS_SYMBOLS{$posting->{status} || ''} || '';
 214         }
 215
 216         my $account = $self->_format_account($posting->{account});
 217
 218         push @line, ($posting_status_symbol ? "  $posting_status_symbol " : '    ');
 219         push @line, sprintf("\%-${account_width}s", $account);
 220         push @line, '  ';
 221         if (defined $posting->{amount}) {
 222             push @line, $self->_format_amount($posting->{amount}, $posting->{commodity});
 223             my $lot_price = $posting->{lot_price};
 224             my $lot_date  = $posting->{lot_date};
 225             my $lot_ref   = $posting->{lot_ref};
 226             if ($lot_price || $lot_date || $lot_ref) {
 227                 push @line, ' {',
 228                             join(', ',
 229                                 $lot_price ? $self->_format_amount($lot_price->{amount}, $lot_price->{commodity}) : (),
 230                                 $lot_date  ? $lot_date : (),
 231                                 $lot_ref   ? $self->_format_string($lot_ref) : (),
 232                             ),
 233                             '}';
 234             }
 235             if (my $cost = $posting->{total_cost} // $posting->{cost}) {
 236                 my $is_total = defined $posting->{total_cost};
 237                 my $cost_symbol = $is_total ? '@@' : '@';
 238                 push @line, ' ', $cost_symbol, ' ',
 239                             $self->_format_amount($cost->{amount}, $cost->{commodity});
 240             }
 241         }
 242
 243         push @out, join('', @line);
 244
 245         my $metadata = $posting->{metadata} || {};
 246         for my $key (sort keys %$metadata) {
 247             my $value = looks_like_number($metadata->{$key}) ? $metadata->{$key}
 248                                                              : $self->_format_string($metadata->{$key});
 249             push @out, "      ; ${key}: ${value}";
 250         }
 251     }
 252
 253     push @out, '';
 254
 255     return @out;
 256 }
 257
 258 sub _format_account {
 259     my $self = shift;
 260     my $account = shift;
 261     $account =~ s/[^A-Za-z0-9:]+/-/g;
 262     $account =~ s/-+/-/g;
 263     $account =~ s/(?:^|(?<=:))([a-z])/uc($1)/eg;
 264     return $account;
 265 }
 266
 267 sub _format_string {
 268     my $self = shift;
 269     my $str  = shift;
 270     $str =~ s/"/\\"/g;
 271     return "\"$str\"";
 272 }
 273
 274 sub _format_amount {
 275     my $self      = shift;
 276     my $amount    = shift;
 277     my $commodity = shift or _croak 'Must provide a valid currency';
 278
 279     my $format = "\% .$commodity->{frac}f";
 280     my ($whole, $fraction) = split(/\./, sprintf($format, $amount));
 281     $fraction ||= 0;
 282
 283     # beancount doesn't support different notations
 284     my $num = commify($whole);
 285     if ($commodity->{frac}) {
 286         $num .= ".$fraction";
 287     }
 288
 289     $num = "$num $commodity->{iso}";
 290
 291     return $num;
 292 }
 293
 294 sub _find_oldest_transaction_by_account {
 295     my $self    = shift;
 296     my $account = shift;
 297     my $ledger  = shift;
 298
 299     $account = $self->_format_account($account);
 300
 301     my $oldest = $self->{oldest_transaction_by_account};
 302     if (!$oldest) {
 303         # build index
 304         for my $transaction (@{$ledger->transactions}) {
 305             for my $posting (@{$transaction->{postings}}) {
 306                 my $account = $self->_format_account($posting->{account});
 307
 308                 if ($transaction->{date} lt ($oldest->{$account}{date} || '9999-99-99')) {
 309                     $oldest->{$account} = $transaction;
 310                 }
 311             }
 312         }
 313
 314         $self->{oldest_transaction_by_account} = $oldest;
 315     }
 316
 317     return $oldest->{$account};
 318 }
 319
 320 sub _find_oldest_transaction_by_commodity {
 321     my $self      = shift;
 322     my $commodity = shift;
 323     my $ledger    = shift;
 324
 325     my $oldest = $self->{oldest_transaction_by_commodity};
 326     if (!$oldest) {
 327         # build index
 328         for my $transaction (@{$ledger->transactions}) {
 329             for my $posting (@{$transaction->{postings}}) {
 330                 my $symbol = $posting->{commodity}{symbol};
 331                 next if !$symbol;
 332
 333                 if ($transaction->{date} lt ($oldest->{$symbol}{date} || '9999-99-99')) {
 334                     $oldest->{$symbol} = $transaction;
 335                 }
 336             }
 337         }
 338
 339         $self->{oldest_transaction_by_commodity} = $oldest;
 340     }
 341
 342     return $oldest->{$commodity->{symbol}};
 343 }
 344
 345 1;