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