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__ |