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

   1 package App::HomeBank2Ledger::Formatter::Beancount;
   2 # ABSTRACT: Beancount formatter
   3
   4
   5 use warnings;
   6 use strict;
   7
   8 use App::HomeBank2Ledger::Util qw(commify rtrim);
   9
  10 use parent 'App::HomeBank2Ledger::Formatter';
  11
  12 our $VERSION = '0.001'; # VERSION
  13
  14 my %STATUS_SYMBOLS = (
  15     cleared => '*',
  16     pending => '!',
  17 );
  18 my $UNKNOWN_DATE = '0001-01-01';
  19
  20 sub _croak { require Carp; Carp::croak(@_) }
  21
  22 sub format {
  23     my $self   = shift;
  24     my $ledger = shift;
  25
  26     my @out = (
  27         $self->_format_header,
  28         $self->_format_accounts($ledger),
  29         $self->_format_commodities($ledger),
  30         # $self->_format_payees,
  31         # $self->_format_tags,
  32         $self->_format_transactions($ledger),
  33     );
  34
  35     return join($/, map { rtrim($_) } @out);
  36 }
  37
  38 sub _format_header {
  39     my $self = shift;
  40
  41     my @out;
  42
  43     if (my $name = $self->name) {
  44         push @out, "; Name: $name";
  45     }
  46
  47     my $file = $self->file;
  48     push @out, "; Converted from ${file} using homebank2ledger ${VERSION}";
  49
  50     push @out, '';
  51
  52     return @out;
  53 }
  54
  55 sub _format_accounts {
  56     my $self   = shift;
  57     my $ledger = shift;
  58
  59     my @out;
  60
  61     for my $account (sort @{$ledger->accounts}) {
  62         my $oldest_transaction = $self->_find_oldest_transaction_by_account($account, $ledger);
  63         my $account_date = $oldest_transaction->{date} || $UNKNOWN_DATE;
  64         $account = $self->_format_account($account);
  65
  66         push @out, "${account_date} open ${account}";
  67     }
  68     push @out, '';
  69
  70     return @out;
  71 }
  72
  73 sub _format_commodities {
  74     my $self   = shift;
  75     my $ledger = shift;
  76
  77     my @out;
  78
  79     for my $commodity (@{$ledger->commodities}) {
  80         my $oldest_transaction = $self->_find_oldest_transaction_by_commodity($commodity, $ledger);
  81         my $commodity_date = $oldest_transaction->{date} || $UNKNOWN_DATE;
  82
  83         push @out, "${commodity_date} commodity $commodity->{iso}";
  84         push @out, '    name: '.$self->_format_string($commodity->{name}) if $commodity->{name};
  85     }
  86
  87     push @out, '';
  88
  89     return @out;
  90 }
  91
  92 sub _format_transactions {
  93     my $self   = shift;
  94     my $ledger = shift;
  95
  96     my @out;
  97
  98     for my $transaction (@{$ledger->transactions}) {
  99         push @out, $self->_format_transaction($transaction);
 100     }
 101
 102     return @out;
 103 }
 104
 105 sub _format_transaction {
 106     my $self        = shift;
 107     my $transaction = shift;
 108
 109     my $account_width = $self->account_width;
 110
 111     my $date        = $transaction->{date};
 112     my $status      = $transaction->{status};
 113     my $payee       = $transaction->{payee} || '';
 114     my $memo        = $transaction->{memo}  || '';
 115     my @postings    = @{$transaction->{postings}};
 116
 117     my @out;
 118
 119     # figure out the Ledger transaction status
 120     my $status_symbol = $STATUS_SYMBOLS{$status || ''};
 121     if (!$status_symbol) {
 122         my %posting_statuses = map { ($_->{status} || '') => 1 } @postings;
 123         if (keys(%posting_statuses) == 1) {
 124             my ($status) = keys %posting_statuses;
 125             $status_symbol = $STATUS_SYMBOLS{$status || 'none'} || '';
 126         }
 127     }
 128
 129     push @out, sprintf('%s%s%s%s', $date,
 130         $status_symbol    && ' '.$status_symbol || ' *',   # status (or "txn") is required
 131         ($payee || $memo) && ' '.$self->_format_string($payee),
 132         $memo             && ' '.$self->_format_string($memo),
 133     );
 134
 135     if (my %tags = map { $_ => 1 } map { @{$_->{tags} || []} } @postings) {
 136         my @tags = map { "#$_" } keys %tags;
 137         $out[-1] .= ' '.join(' ', @tags);
 138     }
 139
 140     for my $posting (@postings) {
 141         my @line;
 142
 143         my $posting_status_symbol = '';
 144         if (!$status_symbol) {
 145             $posting_status_symbol = $STATUS_SYMBOLS{$posting->{status} || ''} || '';
 146         }
 147
 148         my $account = $self->_format_account($posting->{account});
 149
 150         push @line, ($posting_status_symbol ? "  $posting_status_symbol " : '    ');
 151         push @line, sprintf("\%-${account_width}s", $account);
 152         push @line, '  ';
 153         push @line, $self->_format_amount($posting->{amount}, $posting->{commodity}) if defined $posting->{amount};
 154
 155         push @out, join('', @line);
 156     }
 157
 158     push @out, '';
 159
 160     return @out;
 161 }
 162
 163 sub _format_account {
 164     my $self = shift;
 165     my $account = shift;
 166     $account =~ s/[^A-Za-z0-9:]+/-/g;
 167     $account =~ s/-+/-/g;
 168     $account =~ s/(?:^|(?<=:))([a-z])/uc($1)/eg;
 169     return $account;
 170 }
 171
 172 sub _format_string {
 173     my $self = shift;
 174     my $str  = shift;
 175     $str =~ s/"/\\"/g;
 176     return "\"$str\"";
 177 }
 178
 179 sub _format_amount {
 180     my $self      = shift;
 181     my $amount    = shift;
 182     my $commodity = shift or _croak 'Must provide a valid currency';
 183
 184     my $format = "\% .$commodity->{frac}f";
 185     my ($whole, $fraction) = split(/\./, sprintf($format, $amount));
 186
 187     # beancount doesn't support different notations
 188     my $num = join('.', commify($whole), $fraction);
 189
 190     $num = "$num $commodity->{iso}";
 191
 192     return $num;
 193 }
 194
 195 sub _find_oldest_transaction_by_account {
 196     my $self    = shift;
 197     my $account = shift;
 198     my $ledger  = shift;
 199
 200     $account = $self->_format_account($account);
 201
 202     my $oldest = $self->{oldest_transaction_by_account};
 203     if (!$oldest) {
 204         # build index
 205         for my $transaction (@{$ledger->transactions}) {
 206             for my $posting (@{$transaction->{postings}}) {
 207                 my $account = $self->_format_account($posting->{account});
 208
 209                 if ($transaction->{date} lt ($oldest->{$account}{date} || '9999-99-99')) {
 210                     $oldest->{$account} = $transaction;
 211                 }
 212             }
 213         }
 214
 215         $self->{oldest_transaction_by_account} = $oldest;
 216     }
 217
 218     return $oldest->{$account};
 219 }
 220
 221 sub _find_oldest_transaction_by_commodity {
 222     my $self      = shift;
 223     my $commodity = shift;
 224     my $ledger    = shift;
 225
 226     my $oldest = $self->{oldest_transaction_by_commodity};
 227     if (!$oldest) {
 228         # build index
 229         for my $transaction (@{$ledger->transactions}) {
 230             for my $posting (@{$transaction->{postings}}) {
 231                 my $symbol = $posting->{commodity}{symbol};
 232                 next if !$symbol;
 233
 234                 if ($transaction->{date} lt ($oldest->{$symbol}{date} || '9999-99-99')) {
 235                     $oldest->{$symbol} = $transaction;
 236                 }
 237             }
 238         }
 239
 240         $self->{oldest_transaction_by_commodity} = $oldest;
 241     }
 242
 243     return $oldest->{$commodity->{symbol}};
 244 }
 245
 246 1;
 247
 248 __END__
 249
 250 =pod
 251
 252 =encoding UTF-8
 253
 254 =head1 NAME
 255
 256 App::HomeBank2Ledger::Formatter::Beancount - Beancount formatter
 257
 258 =head1 VERSION
 259
 260 version 0.001
 261
 262 =head1 DESCRIPTION
 263
 264 This is a formatter for L<Beancount|http://furius.ca/beancount/>.
 265
 266 =head1 SEE ALSO
 267
 268 L<App::HomeBank2Ledger::Formatter>
 269
 270 =head1 BUGS
 271
 272 Please report any bugs or feature requests on the bugtracker website
 273 L<https://github.com/chazmcgarvey/homebank2ledger/issues>
 274
 275 When submitting a bug or request, please include a test-file or a
 276 patch to an existing test-file that illustrates the bug or desired
 277 feature.
 278
 279 =head1 AUTHOR
 280
 281 Charles McGarvey <chazmcgarvey@brokenzipper.com>
 282
 283 =head1 COPYRIGHT AND LICENSE
 284
 285 This software is Copyright (c) 2019 by Charles McGarvey.
 286
 287 This is free software, licensed under:
 288
 289   The MIT (X11) License
 290
 291 =cut