File Coverage

blib/lib/Ledger/Parser.pm
Criterion Covered Total %
statement 167 183 91.2
branch 80 100 80.0
condition 40 55 72.7
subroutine 18 19 94.7
pod 3 3 100.0
total 308 360 85.5


line stmt bran cond sub pod time code
1             package Ledger::Parser;
2              
3             our $DATE = '2015-03-26'; # DATE
4             our $VERSION = '0.04'; # VERSION
5              
6 1     1   105497 use 5.010001;
  1         3  
  1         24  
7 1     1   3 use strict;
  1         1  
  1         17  
8 1     1   3 use utf8;
  1         1  
  1         6  
9 1     1   12 use warnings;
  1         2  
  1         13  
10 1     1   3 use Carp;
  1         1  
  1         37  
11              
12 1     1   383 use Time::Moment;
  1         2379  
  1         46  
13              
14             use constant +{
15 1         2239 COL_TYPE => 0,
16              
17             COL_B_RAW => 1,
18              
19             COL_T_DATE => 1,
20             COL_T_EDATE => 2,
21             COL_T_WS1 => 3,
22             COL_T_STATE => 4,
23             COL_T_WS2 => 5,
24             COL_T_CODE => 6,
25             COL_T_WS3 => 7,
26             COL_T_DESC => 8,
27             COL_T_WS4 => 7,
28             COL_T_COMMENT => 8,
29             COL_T_NL => 9,
30             COL_T_PARSE_DATE => 10,
31             COL_T_PARSE_EDATE => 11,
32             COL_T_PARSE_TX => 12,
33              
34             COL_P_WS1 => 1,
35             COL_P_OPAREN => 2,
36             COL_P_ACCOUNT => 3,
37             COL_P_CPAREN => 4,
38             COL_P_WS2 => 5,
39             COL_P_AMOUNT => 6,
40             COL_P_WS3 => 7,
41             COL_P_COMMENT => 8,
42             COL_P_NL => 9,
43             COL_P_PARSE_AMOUNT => 10,
44              
45             COL_C_CHAR => 1,
46             COL_C_COMMENT => 2,
47             COL_C_NL => 3,
48              
49             COL_TC_WS1 => 1,
50             COL_TC_COMMENT => 2,
51             COL_TC_NL => 3,
52 1     1   5 };
  1         0  
53              
54             # note: $RE_xxx is capturing, $re_xxx is non-capturing
55             our $re_date = qr!(?:\d{4}[/-])?\d{1,2}[/-]\d{1,2}!;
56             our $RE_date = qr!(?:(\d{4})[/-])?(\d{1,2})[/-](\d{1,2})!;
57              
58             our $re_account_part = qr/(?:
59             [^\s:\[\(;]+?[ \t]??[^\s:\[\(;]*?
60             )+?/x; # don't allow double whitespace
61             our $re_account = qr/$re_account_part(?::$re_account_part)*/;
62             our $re_commodity = qr/[A-Z_]+[A-Za-z_]*|[\$£€¥]/;
63             our $re_amount = qr/(?:-?)
64             (?:$re_commodity)?
65             \s* (?:-?[0-9,]+\.?[0-9]*)
66             \s* (?:$re_commodity)?
67             /x;
68             our $RE_amount = qr/(-?)
69             ($re_commodity)?
70             (\s*) (-?[0-9,]+\.?[0-9]*)
71             (\s*) ($re_commodity)?
72             /x;
73              
74             sub new {
75 1     1 1 20724 my ($class, %attrs) = @_;
76              
77 1   50     14 $attrs{input_date_format} //= 'YYYY/MM/DD';
78 1   33     105 $attrs{year} //= (localtime)[5] + 1900;
79             #$attrs{strict} //= 0; # check valid account names
80              
81             # checking
82 1 50       28 $attrs{input_date_format} =~ m!\A(YYYY/MM/DD|YYYY/DD/MM)\z!
83             or croak "Invalid input_date_format: choose YYYY/MM/DD or YYYY/DD/MM";
84              
85 1         17 bless \%attrs, $class;
86             }
87              
88             sub _parse_date {
89 23     23   35 my ($self, $str) = @_;
90 23 50       134 return [400,"Invalid date syntax '$str'"] unless $str =~ /\A(?:$RE_date)\z/;
91              
92 23         49 my $tm;
93 23         24 eval {
94 23 50       72 if ($self->{input_date_format} eq 'YYYY/MM/DD') {
95 23   66     244 $tm = Time::Moment->new(
96             day => $3,
97             month => $2,
98             year => $1 || $self->{year},
99             );
100             } else {
101 0   0     0 $tm = Time::Moment->new(
102             day => $2,
103             month => $3,
104             year => $1 || $self->{year},
105             );
106             }
107             };
108 23 100       41 if ($@) { return [400, "Invalid date '$str': $@"] }
  1         7  
109 22         88 [200, "OK", $tm];
110             }
111              
112             sub _parse_amount {
113 27     27   28 my ($self, $str) = @_;
114 27 50       190 return [400, "Invalid amount syntax '$str'"]
115             unless $str =~ /\A(?:$RE_amount)\z/;
116              
117 27         55 my ($minsign, $commodity1, $ws1, $num, $ws2, $commodity2) =
118             ($1, $2, $3, $4, $5, $6);
119 27 100 100     57 if ($commodity1 && $commodity2) {
120 1         5 return [400, "Invalid amount '$str' (double commodity)"];
121             }
122 26         34 $num =~ s/,//g;
123 26 100       43 $num *= -1 if $minsign;
124 26 100 100     160 return [200, "OK", [
      100        
125             $num, # raw number
126             ($commodity1 || $commodity2) // '', # commodity
127             $commodity1 ? "B$ws1" : "A$ws2", # format: B(efore)|A(fter) + spaces
128             ]];
129             }
130              
131             # this routine takes the raw parsed lines and parse a transaction data from it.
132             # the _ledger_raw keys are used when we transport the transaction data outside
133             # and back in again, we want to be able to reconstruct the original
134             # transaction/posting lines if they are not modified exactly (for round-trip
135             # purposes).
136             sub _parse_tx {
137 18     18   23 my ($self, $parsed, $linum0) = @_;
138              
139 18         22 my $t_line = $parsed->[$linum0-1];
140 18         70 my $tx = {
141             date => $t_line->[COL_T_PARSE_DATE],
142             description => $t_line->[COL_T_DESC],
143             _ledger_raw => $t_line,
144             postings => [],
145             };
146 18 50       30 $tx->{edate} = $t_line->[COL_T_PARSE_EDATE] if $t_line->[COL_T_EDATE];
147              
148 18         18 my $linum = $linum0;
149 18         15 while (1) {
150 64 100       102 last if $linum++ > @$parsed-1;
151 46         39 my $line = $parsed->[$linum-1];
152 46         42 my $type = $line->[COL_TYPE];
153 46 100       54 if ($type eq 'P') {
    50          
154 41   50     54 my $oparen = $line->[COL_P_OPAREN] // '';
155 41 100       25 push @{ $tx->{postings} }, {
  41 100       225  
    100          
    100          
156             account => $line->[COL_P_ACCOUNT],
157             is_virtual => $oparen eq '(' ? 1 : $oparen eq '[' ? 2 : 0,
158             amount => $line->[COL_P_PARSE_AMOUNT] ?
159             $line->[COL_P_PARSE_AMOUNT][0] : undef,
160             commodity => $line->[COL_P_PARSE_AMOUNT] ?
161             $line->[COL_P_PARSE_AMOUNT][1] : undef,
162             _ledger_raw => $line,
163             };
164             } elsif ($type eq 'TC') {
165             # ledger associates a transaction comment with a posting that
166             # precedes it. if there is a transaction comment before any posting,
167             # we will stick it to the _ledger_raw_comments. otherwise, it will
168             # goes to each posting's _ledger_raw_comments.
169 5 100       4 if (@{ $tx->{postings} }) {
  5         9  
170 1         1 push @{ $tx->{postings}[-1]{_ledger_raw_comments} }, $line;
  1         2  
171             } else {
172 4         4 push @{ $tx->{_ledger_raw_comments} }, $line;
  4         10  
173             }
174             } else {
175 0         0 last;
176             }
177             }
178              
179             # some sanity checks for the transaction
180             CHECK:
181             {
182 18         13 my $num_postings = @{$tx->{postings}};
  18         15  
  18         20  
183 18 100       36 last CHECK if !$num_postings;
184 17 50 66     30 if ($num_postings == 1 && !defined(!$tx->{postings}[0]{amount})) {
185             #$self->_err("Posting amount cannot be null");
186             # ledger allows this
187 0         0 last CHECK;
188             }
189 17         16 my $num_nulls = 0;
190 17         12 my %bals; # key = commodity
191 17         15 for my $p (@{ $tx->{postings} }) {
  17         25  
192 41 100       50 if (!defined($p->{amount})) {
193 15         11 $num_nulls++;
194 15         18 next;
195             }
196 26         46 $bals{$p->{commodity}} += $p->{amount};
197             }
198 17 100       38 last CHECK if $num_nulls == 1;
199 4 100       9 if ($num_nulls) {
200 1         2 $self->_err("There can only be one posting with null amount");
201             }
202 3         31 for (keys %bals) {
203 3 100       15 $self->_err("Transaction not balanced, " .
    100          
204             (-$bals{$_}) . ($_ ? " $_":"")." needed")
205             if $bals{$_} != 0;
206             }
207             }
208              
209 15         31 [200, "OK", $tx];
210             }
211              
212             sub _err {
213 9     9   12 my ($self, $msg) = @_;
214 9         151 croak join(
215             "",
216 9 50       10 @{ $self->{_include_stack} } ? "$self->{_include_stack}[0] " : "",
217             "line $self->{_linum}: ",
218             $msg
219             );
220             }
221              
222             sub _push_include_stack {
223 19     19   105 require Cwd;
224              
225 19         24 my ($self, $path) = @_;
226              
227             # included file's path is based on the main (topmost) file
228 19 50       17 if (@{ $self->{_include_stack} }) {
  19         54  
229 0         0 require File::Spec;
230 0         0 my (undef, $dir, $file) =
231             File::Spec->splitpath($self->{_include_stack}[-1]);
232 0         0 $path = File::Spec->rel2abs($path, $dir);
233             }
234              
235 19 50       821 my $abs_path = Cwd::abs_path($path) or return [400, "Invalid path name"];
236 0         0 return [409, "Recursive", $abs_path]
237 19 50       18 if grep { $_ eq $abs_path } @{ $self->{_include_stack} };
  19         56  
238 19         24 push @{ $self->{_include_stack} }, $abs_path;
  19         41  
239 19         56 return [200, "OK", $abs_path];
240             }
241              
242             sub _pop_include_stack {
243 10     10   11 my $self = shift;
244              
245 10 50       9 die "BUG: Overpopped _pop_include_stack" unless @{$self->{_include_stack}};
  10         25  
246 10         9 pop @{ $self->{_include_stack} };
  10         14  
247             }
248              
249             sub _init_read {
250 19     19   27 my $self = shift;
251              
252 19         44 $self->{_include_stack} = [];
253             }
254              
255             sub _read_file {
256 19     19   28 my ($self, $filename) = @_;
257 19 50       566 open my $fh, "<", $filename
258             or die "Can't open file '$filename': $!";
259 19         78 binmode($fh, ":utf8");
260 19         58 local $/;
261 19         638 return ~~<$fh>;
262             }
263              
264             sub read_file {
265 19     19 1 36002 my ($self, $filename) = @_;
266 19         61 $self->_init_read;
267 19         56 my $res = $self->_push_include_stack($filename);
268 19 50       50 die "Can't read '$filename': $res->[1]" unless $res->[0] == 200;
269 19         50 $res =
270             $self->_read_string($self->_read_file($filename));
271 10         28 $self->_pop_include_stack;
272 10         45 $res;
273             }
274              
275             sub read_string {
276 0     0 1 0 my ($self, $str) = @_;
277 0         0 $self->_init_read;
278 0         0 $self->_read_string($str);
279             }
280              
281             sub _read_string {
282 19     19   47 my ($self, $str) = @_;
283              
284 19         34 my $res = [];
285              
286 19         19 my $in_tx;
287              
288 19         84 my @lines = split /^/, $str;
289 19         54 local $self->{_linum} = 0;
290             LINE:
291 19         31 for my $line (@lines) {
292 128         99 $self->{_linum}++;
293              
294             # transaction is broken by an empty/all-whitespace line or a
295             # non-indented line. once we found a complete transaction, parse it.
296 128 100 66     395 if ($in_tx && ($line !~ /\S/ || $line =~ /^\S/)) {
      66        
297 17         42 my $parse_tx = $self->_parse_tx($res, $in_tx);
298 14 50       23 if ($parse_tx->[0] != 200) {
299 0         0 $self->_err($parse_tx->[1]);
300             }
301 14         23 $res->[$in_tx - 1][COL_T_PARSE_TX] = $parse_tx->[2];
302 14         17 $in_tx = 0;
303             }
304              
305             # blank line (B)
306 125 100       259 if ($line !~ /\S/) {
307 25         48 push @$res, [
308             'B',
309             $line, # COL_B_RAW
310             ];
311 25         28 next LINE;
312             }
313              
314             # transaction line (T)
315 100 100       166 if ($line =~ /^\d/) {
316 23 50       339 $line =~ m<^($re_date) # 1) actual date
317             (?: = ($re_date))? # 2) effective date
318             (?: (\s+) ([!*]) )? # 3) ws 4) state
319             (?: (\s+) \(([^\)]+)\) )? # 5) ws 6) code
320             (\s+) (\S.*?) # 7) ws 8) desc
321             (?: (\s{2,}) ;(\S.+?) )? # 9) ws 10) comment
322             (\R?)\z # 11) nl
323             >x
324             or $self->_err("Invalid transaction line syntax");
325 23         125 my $parsed_line = ['T', $1, $2, $3, $4, $5, $6, $7, $8, $9];
326              
327 23         56 my $parse_date = $self->_parse_date($1);
328 23 100       49 if ($parse_date->[0] != 200) {
329 1         4 $self->_err($parse_date->[1]);
330             }
331 22         47 $parsed_line->[COL_T_PARSE_DATE] = $parse_date->[2];
332              
333 22 50       43 if ($2) {
334 0         0 my $parse_edate = $self->_parse_date($2);
335 0 0       0 if ($parse_edate->[0] != 200) {
336 0         0 $self->_err($parse_edate->[1]);
337             }
338 0         0 $parsed_line->[COL_T_PARSE_EDATE] = $parse_edate->[2];
339             }
340              
341 22         29 $in_tx = $self->{_linum};
342 22         23 push @$res, $parsed_line;
343 22         53 next LINE;
344             }
345              
346             # comment line (C)
347 77 100       253 if ($line =~ /^([;#%|*])(.*?)(\R?)\z/) {
348 26         118 push @$res, ['C', $1, $2, $3];
349 26         37 next LINE;
350             }
351              
352             # transaction comment (TC)
353 51 100 100     167 if ($in_tx && $line =~ /^(\s+);(.*?)(\R?)\z/) {
354 5         12 push @$res, ['TC', $1, $2, $3];
355 5         6 next LINE;
356             }
357              
358             # posting (P)
359 46 100 66     149 if ($in_tx && $line =~ /^\s/) {
360 45 100       1291 $line =~ m!^(\s+) # 1) ws1
361             (\[|\()? # 2) oparen
362             ($re_account) # 3) account
363             (\]|\))? # 4) cparen
364             (?: (\s{2,})($re_amount) )? # 5) ws2 6) amount
365             (?: (\s*) ;(.*?))? # 7) ws 8) note
366             (\R?)\z # 9) nl
367             !x
368             or $self->_err("Invalid posting line syntax");
369             # brace must match
370 44   100     230 my ($oparen, $cparen) = ($2 // '', $4 // '');
      100        
371 44 100 66     151 unless (!$oparen && !$cparen ||
      100        
      66        
      100        
      66        
372             $oparen eq '[' && $cparen eq ']' ||
373             $oparen eq '(' && $cparen eq ')') {
374 2         3 $self->_err("Parentheses/braces around account don't match");
375             }
376 42         162 my $parsed_line = ['P', $1, $oparen, $3, $cparen,
377             $5, $6, $7, $8, $9];
378 42 100       68 if (defined $6) {
379 27         51 my $parse_amount = $self->_parse_amount($6);
380 27 100       53 if ($parse_amount->[0] != 200) {
381 1         3 $self->_err($parse_amount->[1]);
382             }
383 26         46 $parsed_line->[COL_P_PARSE_AMOUNT] = $parse_amount->[2];
384             }
385 41         45 push @$res, $parsed_line;
386 41         60 next LINE;
387             }
388              
389 1         3 $self->_err("Invalid syntax");
390              
391             }
392              
393             # make sure we always end with newline
394 10 100       21 if (@$res) {
395 9 100       101 $res->[-1][-1] .= "\n"
396             unless $res->[-1][-1] =~ /\R\z/;
397             }
398              
399 10 100       20 if ($in_tx) {
400 1         3 my $parse_tx = $self->_parse_tx($res, $in_tx);
401 1 50       4 if ($parse_tx->[0] != 200) {
402 0         0 $self->_err($parse_tx->[1]);
403             }
404 1         3 $res->[$in_tx - 1][COL_T_PARSE_TX] = $parse_tx->[2];
405             }
406              
407 10         656 require Ledger::Journal;
408 10         53 Ledger::Journal->new(_parser=>$self, _parsed=>$res);
409             }
410              
411             1;
412             # ABSTRACT: Parse Ledger journals
413              
414             __END__