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