Annotation of pta/pta.pl, Revision 1.4
1.1 schwarze 1: #!/usr/bin/perl
2: #
3: # Copyright (c) 2020 Ingo Schwarze <schwarze@openbsd.org>
4: #
5: # Permission to use, copy, modify, and distribute this software for any
6: # purpose with or without fee is hereby granted, provided that the above
7: # copyright notice and this permission notice appear in all copies.
8: #
9: # THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES
10: # WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF
11: # MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR
12: # ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES
13: # WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN
14: # ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF
15: # OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE.
16:
17: use warnings;
18: use strict;
19:
20: use Getopt::Std qw(getopts);
21:
22: our ($opt_a, $opt_b, $opt_c, $opt_L, $opt_n, $opt_p, $opt_s);
23:
24: my %accounts; # {ano}{type, text}; from pta-accounts(5)
25: my %alist; # {ano}{subname, ''}[]; contains lists of entries
26: my %cclist; # {cc}{ano}[]; contains lists of entries
27: my %entry; # {year, month, day, date, id, contra,
28: # amount, rel, old, days, skip, cc, text, sum}
29: my %prices; # {cc}{year, month, day, date, days, price}
30: my %profit; # {cc}[]; contains lists of profit entries
31: my %ptot; # {cc}{profit, percent, capital, pcpa, days}
32:
33: my %atypes = (
34: A => 'Assets',
35: Q => 'Equity',
36: L => 'Liabilities',
37: R => 'Revenue',
38: S => 'Statistical accounts',
39: X => 'Expenses',
40: );
41:
42: my $translations = {
1.4 ! schwarze 43: en => {},
1.1 schwarze 44: de => {
45: 'Account list' => 'Kontenblatt',
46: 'Assets' => 'Aktiva',
47: 'Balance sheet' => 'Bilanz',
48: 'change in price' => 'Kursaenderung',
49: 'Cost center' => 'Kostenstelle',
50: 'current period' => 'aktuelle Periode',
51: 'Equity' => 'Eigenkapital',
52: 'Expenses' => 'Aufwand',
53: 'Liabilities' => 'Fremdkapital',
54: 'loss' => 'Verlust',
55: 'mismatch' => 'Diskrepanz',
56: 'Partial balance sheet' => 'Teilbilanz',
57: 'previous years' => 'Vorjahre',
58: 'profit' => 'Gewinn',
59: 'Profits and losses' => 'Gewinne und Verluste',
60: 'Revenue' => 'Ertrag',
61: 'since' => 'seit',
62: 'Statistical accounts' => 'Statistische Konten',
63: 'Subaccount list' => 'Unterkontenblatt',
64: 'total' => 'Summe',
65: 'total assets' => 'Bilanzsumme',
66: 'total loss' => 'Gesamtverlust',
67: 'total profit' => 'Gesamtgewinn',
68: }
69: };
70:
71: # === SUBROUTINES =====================================================
72:
73: sub translate ($) {
74: my $en = shift;
1.4 ! schwarze 75: return $translations->{$en} || $en;
1.1 schwarze 76: }
77:
78: sub translate_type ($) {
79: my $type = shift;
1.4 ! schwarze 80: my $en = $atypes{substr $type, 0, 1};
! 81: return $en ? translate $en : $type;
1.1 schwarze 82: }
83:
84: # Handles account entries (not journal entries) with respect to
85: # subaccounts, running totals, cost centers,
86: # and realized profits and losses in the profit table,
87: # but does not handle unrealized profits and losses.
88: sub make_entry (\%$) {
89: my ($entry, $ano) = @_;
90: my $sub = $accounts{$ano}{type} =~ /[RX]/ &&
91: $entry->{text} =~ s/\((.*?)\) *// ? $1 : '';
92: my $old = $alist{$ano}{$sub} ? $alist{$ano}{$sub}[-1]{sum} : 0;
93: push @{$alist{$ano}{$sub}}, {%$entry, sum => $old + $entry->{amount}};
94: my $cc = $entry->{cc} or return;
95: $old = $cclist{$cc}{$ano} ? $cclist{$cc}{$ano}[-1]{sum} : 0;
96: push @{$cclist{$cc}{$ano}}, {%$entry, sum => $old + $entry->{amount}};
97: push @{$profit{$cc}}, {
98: %$entry,
99: old => $prices{$cc}{price},
100: amount => -$entry->{amount},
101: rel => -$entry->{amount} / $prices{$cc}{price},
102: } if $accounts{$ano}{type} =~ /p/;
103: }
104:
105: # For account lists, not for balance sheets.
106: sub print_amount ($) {
107: my $amount = shift;
108: if ($amount < 0) {
109: printf "%9s %9.2f", '', -$amount;
110: } else {
111: printf "%9.2f %9s", $amount, '';
112: }
113: }
114:
115: sub print_amount_text ($$) {
116: my ($entry, $account) = @_;
117: print_amount $entry->{amount};
118: printf " %10.2f %s\n",
119: $entry->{sum} * ($account->{type} =~ /[ASX]/ ? 1 : -1),
120: $entry->{text};
121: }
122:
123: # For balance sheets, not for account lists.
124: sub print_sum ($$$$$) {
125: my ($list, $ano, $indent, $debit, $credit) = @_;
126: my $type = $accounts{$ano}{type};
127: my $amount = $list->[-1]{sum};
128: printf "%*s%05u ", $indent, '', $ano;
129: if ($type =~ /[AX]/ || ($type eq 'S' && $amount >= 0)) {
130: printf "%9.2f %9s", $amount, '';
131: $$debit += $amount;
132: } else {
133: printf "%9s %9.2f", '', -$amount;
134: $$credit -= $amount;
135: }
136: printf " %s\n", $accounts{$ano}{text};
137: }
138:
139: sub usage () {
140: printf STDERR "usage: %s [-abcnps] [-L de]\n", $0;
141: exit 1;
142: }
143:
144: # === MAIN PROGRAM =====================================================
145:
146: getopts 'abcL:nps' or usage;
147: $opt_a = $opt_b = $opt_c = $opt_p = $opt_s = 1
148: unless $opt_a || $opt_b || $opt_c || $opt_n || $opt_p || $opt_s;
1.4 ! schwarze 149: unless ($translations = $translations->{$opt_L || 'en'}) {
! 150: printf STDERR "unsupported language: -L %s\n", $opt_L;
1.1 schwarze 151: usage;
152: }
153:
154: my $fn = 'accounts.txt';
155: open my $in, $fn or die "$fn: $!";
156: while (<$in>) {
157: chomp;
158: next if /^(?:#|$)/;
159: my $line = $_;
160: s/^(\d+) +// or die "$fn account number parse error: $line";
161: my $account = {};
162: $accounts{$1} = $account;
163: s/^([ALQRSX]p?) +// or die "$fn account type parse error: $line";
164: $account->{type} = $1;
165: $account->{text} = $_;
166: }
167: close $in;
168:
169: # === JOURNAL PARSER ===================================================
170:
171: $fn = 'journal.txt';
172: open $in, $fn or die "$fn: $!";
173: while (<$in>) {
174: chomp;
175: next if /^(?:#|$)/;
176: my $line = $_;
177:
178: # --- Subsequent line of a split entry. ------------------------
179:
180: if (%entry) {
181: s/^ *(\d+) +// or die "$fn split account parse error: $line";
182: my $ano = $1;
183: /^(-?\d+\.\d+) +(.*)/
184: or die "$fn split amount parse error: $line";
185: my ($amount, $text) = ($1, $2);
186: my $cc = $1 if $text =~ s/\[(.*?)\] *//;
187: $accounts{$ano} or die "unknown account $ano: $line";
188: $amount *= $entry{amount} < 0 ? -1 : +1;
189:
190: # Combine the text on the split side.
191: my $newentry = {
192: %entry,
193: amount => $amount,
194: text => "$entry{text} $text",
195: };
196: if ($cc) {
197: $newentry->{cc} = $cc;
198: $newentry->{text} = "[$cc] $newentry->{text}";
199: }
200: make_entry %$newentry, $ano;
201:
202: # Append split account numbers on the combined side.
203: my $contra = $entry{contra};
204: $alist{$contra}{''}[-1]{text} .= " $ano"
205: unless $alist{$contra}{''}[-1]{text} =~ / $ano/;
206:
207: # If the split side specifies a cost center,
208: # manually create the cost center entry on the combined
209: # side because make_entry was only called once there.
210: if ($cc) {
211: my $old = $cclist{$cc}{$contra} ?
212: $cclist{$cc}{$contra}[-1]{sum} : 0;
213: $newentry->{contra} = $ano;
214: $newentry->{amount} *= -1;
215: $newentry->{sum} = $old - $amount;
216: push @{$cclist{$cc}{$contra}}, $newentry;
217: }
218:
219: # Keep track of the remaining amount.
220: $entry{amount} -= $amount;
221: %entry = () if abs($entry{amount}) < 0.005;
222: next;
223: }
224:
225: # --- Parse a normal journal entry or a price line. ------------
226:
227: s/^(\d{4})(\d{2})(\d{2}) +// or die "$fn date parse error: $line";
228: my ($year, $month, $day) = ($1, $2, $3);
229: s/^([A-Z]+(?:\d+\/\d+)?) +// or die "$fn ID parse error: $line";
230: my $id = $1;
231: s/^(\d+) +// or die "$fn debit account number parse error: $line";
232: my $debit = $1;
233: my ($credit, $oldpc, $newpc);
234: if (s/^(\d+)#(\d+) +//) {
235: $oldpc = $1;
236: $newpc = $2;
237: } elsif (s/^(\d+) +//) {
238: $credit = $1;
239: } else {
240: die "$fn credit account number parse error: $line";
241: }
242: /^(\d+\.\d+) +(.*)/ or die "$fn amount parse error: $line";
243: my ($amount, $text) = ($1, $2);
244: my $cc = $1 if $text =~ /\[(.*?)\]/;
245:
246: # --- Handle a price line. -------------------------------------
247:
248: if ($oldpc || $newpc) {
249: defined $cc or die "$fn price without cost center: $line";
250: my $old = $prices{$cc};
251: my $new = {
252: year => $year,
253: month => $month,
254: day => $day,
255: date => "$year-$month-$day",
256: days => ($month - 1) * 30 + ($day - 1),
257: price => $newpc * $amount,
258: };
259: $prices{$cc} = $new unless $prices{$cc} && $oldpc == $newpc;
260: next unless $oldpc;
261:
262: # --- Some units were already held. --------------------
263:
264: my $oldval = $old ? $old->{price} :
265: $cclist{$cc}{$debit}[-1]{sum};
266: my $diff = $oldpc * $amount - $oldval;
267: my $newprofit = {
268: year => $year,
269: month => $month,
270: day => $day,
271: date => $new->{date},
272: id => $id,
273: amount => $diff,
274: old => $oldval,
275: rel => $diff / $oldval,
276: text => (sprintf "[%s] %s", $cc,
277: (translate 'change in price')),
278: };
279: if ($old) {
280: # Record a gain or loss in this period.
281: $newprofit->{olddate} = $old->{date};
282: $newprofit->{days} = $new->{days} - $old->{days} +
283: ($new->{year} - $old->{year}) * 360;
284: $newprofit->{text} .= sprintf " %s %s (%dd)",
285: (translate 'since'), $old->{date},
286: $newprofit->{days};
287: } else {
288: # Record a gain or loss before this period.
289: $newprofit->{skip} = 1;
290: $newprofit->{text} .= sprintf " (%s)",
291: (translate 'previous years');
292: }
293: push @{$profit{$cc}}, $newprofit;
294:
295: # --- Obsolete one previous line, if needed. -----------
296:
297: for (my $i = $#{$profit{$cc}} - 1; $i >= 0; $i--) {
298: my $oldprofit = $profit{$cc}[$i];
299: next unless $oldprofit->{olddate};
300: $oldprofit->{skip} = 1
301: if $oldprofit->{olddate} eq $old->{date};
302: last;
303: }
304: next;
305: }
306:
307: # --- Handle a normal journal entry. ---------------------------
308:
309: %entry = (
310: year => $year,
311: month => $month,
312: day => $day,
313: date => "$year-$month-$day",
314: id => $id,
315: text => $text,
316: cc => $cc,
317: );
318: if ($debit) {
319: $accounts{$debit} or die "unknown debit account $debit: $line";
320: my %newentry = (%entry, contra => $credit, amount => $amount);
321: make_entry %newentry, $debit;
322: } else {
323: $credit or die "splitting both sides: $line";
324: # Remember a credit side split.
325: $entry{contra} = $credit;
326: $entry{amount} = $amount;
327: }
328: if ($credit) {
329: $accounts{$credit}
330: or die "unknown credit account $credit: $line";
331: my %newentry = (%entry, contra => $debit, amount => -$amount);
332: make_entry %newentry, $credit;
333: # This entry is not split: clear it after processing.
334: %entry = () if $debit;
335: } else {
336: # Remember a debit side split.
337: $entry{contra} = $debit;
338: $entry{amount} = -$amount;
339: }
340: }
341: # The last journal entry is an incomplete split.
342: die "$fn split parse error: EOF" if %entry;
343: close $in;
344:
345: # === OUTPUT ===========================================================
346:
347: for my $ano (sort keys %accounts) {
348: next unless $alist{$ano};
349:
350: # --- Subaccount lists. ----------------------------------------
351:
352: if ($opt_s) {
353: for my $sub (sort keys %{$alist{$ano}}) {
354: next if $sub eq '';
355: printf "\n%s %s %s (%s) %s\n",
356: (translate 'Subaccount list'),
357: $ano, $accounts{$ano}{text},
358: (translate_type $accounts{$ano}{type}), $sub;
359: for my $entry (@{$alist{$ano}{$sub}}) {
360: printf "%10s %6s %5s ", $entry->{date},
361: $entry->{id}, $entry->{contra};
362: print_amount_text $entry, $accounts{$ano};
363: }
364: }
365: }
366:
367: # --- Account lists. -------------------------------------------
368:
369: my ($sum, $hassub);
370: if ($alist{$ano}{''}) {
371: $sum = $alist{$ano}{''}[-1]{sum};
372: } else {
373: $alist{$ano}{''} = [];
374: $sum = 0;
375: }
376:
377: # Entries outside any subaccount.
378: if ($opt_a) {
379: printf "\n%s %s %s (%s)\n", (translate 'Account list'),
380: $ano, $accounts{$ano}{text},
381: (translate_type $accounts{$ano}{type});
382: for my $entry (@{$alist{$ano}{''}}) {
383: printf "%10s %6s %5s ",
384: $entry->{date}, $entry->{id}, $entry->{contra};
385: print_amount_text $entry, $accounts{$ano};
386: }
387: }
388:
389: # Subaccount balances.
390: for my $sub (sort {
391: $alist{$ano}{$b}[-1]{sum} <=> $alist{$ano}{$a}[-1]{sum}
392: } grep { $_ ne '' } keys %{$alist{$ano}}) {
393: $hassub = 1;
394: $sum += $alist{$ano}{$sub}[-1]{sum};
395: if ($opt_a) {
396: printf "%24s", '';
397: print_amount $alist{$ano}{$sub}[-1]{sum};
398: printf " %10.2f %s\n",
399: $sum * ($accounts{$ano}{type} =~ /[ASX]/ ? 1 : -1),
400: $sub;
401: }
402: }
403: push @{$alist{$ano}{''}}, {sum => $sum} if $hassub;
404: }
405:
406: # --- Balance sheet. ---------------------------------------------------
407:
408: if ($opt_b) {
409: my $debit = 0;
410: my $credit = 0;
411: my $stat;
412: printf "\n%s\n", (translate 'Balance sheet');;
413: for my $ano (sort keys %accounts) {
414: $alist{$ano} or next;
415: if ($accounts{$ano}{type} =~ /S/) {
416: $stat = 1;
417: } else {
418: print_sum $alist{$ano}{''},
419: $ano, 18, \$debit, \$credit;
420: }
421: }
422: printf "%23s %9.2f %9.2f %s\n", '', $debit, $credit,
423: (translate 'total assets');
424: printf "%33s %9.2f %s\n", '', $credit - $debit, (translate 'mismatch')
425: if abs($credit - $debit) > 0.005;
426:
427: # --- Statistical accounts. ------------------------------------
428:
429: if ($stat) {
430: $debit = $credit = 0;
431: printf "\n%s\n", (translate 'Statistical accounts');;
432: for my $ano (sort keys %accounts) {
433: $alist{$ano} && $accounts{$ano}{type} =~ /S/ or next;
434: print_sum $alist{$ano}{''},
435: $ano, 18, \$debit, \$credit;
436: }
437: printf "%23s %9.2f %9.2f %s\n", '', $debit, $credit,
438: (translate 'total');
439: printf "%33s %9.2f %s\n", '',
440: $credit - $debit, (translate 'mismatch')
441: if abs($credit - $debit) > 0.005;
442: }
443: }
444:
445: # --- Cost centers. ----------------------------------------------------
446:
447: for my $cc (sort keys %cclist) {
448: if ($opt_c) {
449:
450: # --- Cost center account lists. -----------------------
451:
452: printf "\n%s [%s] %s\n", (translate 'Cost center'), $cc,
453: (translate 'Account list');
454: for my $ano (sort keys %accounts) {
455: next unless $cclist{$cc}{$ano};
456: printf "%19s %5s %30s *** %s (%s)\n",
457: '', $ano, '', $accounts{$ano}{text},
458: (translate_type $accounts{$ano}{type});
459: for my $entry (@{$cclist{$cc}{$ano}}) {
460: printf " %10s %6s %5s ", $entry->{date},
461: $entry->{id}, $entry->{contra};
462: print_amount_text $entry, $accounts{$ano};
463: }
464: }
465:
466: # --- Partial balance sheet. ---------------------------
467:
468: my $debit = 0;
469: my $credit = 0;
470: my $stat;
471: printf "\n%s [%s] %s\n", (translate 'Cost center'), $cc,
472: (translate 'Partial balance sheet');
473: for my $ano (sort keys %accounts) {
474: $cclist{$cc}{$ano} or next;
475: if ($accounts{$ano}{type} =~ /S/) {
476: $stat = 1;
477: } else {
478: print_sum $cclist{$cc}{$ano},
479: $ano, 20, \$debit, \$credit;
480: }
481: }
482: printf "%25s %9.2f %9.2f %s\n", '', $debit, $credit,
483: (translate 'total assets');
484:
485: # --- Cost center statistical accounts. ----------------
486:
487: if ($stat) {
488: $debit = $credit = 0;
489: printf "\n%s [%s] %s\n",
490: (translate 'Cost center'), $cc,
491: (translate 'Statistical accounts');
492: for my $ano (sort keys %accounts) {
493: $cclist{$cc}{$ano} &&
494: $accounts{$ano}{type} =~ /S/ or next;
495: print_sum $cclist{$cc}{$ano},
496: $ano, 20, \$debit, \$credit;
497: }
498: printf "%25s %9.2f %9.2f %s\n", '',
499: $debit, $credit, (translate 'total');
500: }
501: }
502:
503: # --- Cost center profits and losses. --------------------------
504:
1.3 schwarze 505: if ($opt_p && $profit{$cc}) {
1.1 schwarze 506: printf "\n%s [%s] %s\n", (translate 'Cost center'), $cc,
507: (translate 'Profits and losses');
508: my $pr = 0;
509: my $days = 0;
510: my $capital = 0;
511: for my $i (0 .. $#{$profit{$cc}}) {
512: my $entry = $profit{$cc}[$i];
513: printf " %s %6s %8.2f %5.1f%% of %8.2f ",
514: $entry->{date}, $entry->{id}, $entry->{amount},
515: 100.0 * $entry->{rel}, $entry->{old};
516: if ($entry->{days}) {
517: printf "%5.1f%% p.a.",
518: 36000.0 * $entry->{rel} / $entry->{days};
519: } else {
520: printf "%11s", '';
521: }
522: printf " %s", $entry->{text};
523: if ($entry->{skip}) {
524: print " --\n";
525: next;
526: } else {
527: print "\n";
528: }
529: $pr += $entry->{amount};
530: next unless $entry->{days};
531: $days += $entry->{days};
532: $capital += $entry->{old} * $entry->{days};
533: }
534: my $entry = {
535: profit => $pr,
536: percent => 100.0 * $pr / $capital * $days,
537: capital => $capital / $days,
538: pcpa => 36000.0 * $pr / $capital,
539: days => $days,
540: };
541: printf "%19s %8.2f %5.1f%% of %8.2f %5.1f%% p.a. " .
542: "[%s] %s (%s, %dd)\n", '', $pr, $entry->{percent},
543: $entry->{capital}, $entry->{pcpa}, $cc,
544: translate($pr < 0 ? 'total loss' : 'total profit'),
545: (translate 'current period'), $days;
546: $ptot{$cc} = $entry;
547: }
548: }
549:
550: # --- Global list of profits and losses. -------------------------------
551:
1.2 schwarze 552: if ($opt_p && %ptot) {
1.1 schwarze 553: my $pr = 0;
554: my $capital = 0;
555: my $maxd = 0;
556: printf "\n%s\n", (translate 'Profits and losses');
557: for my $cc (sort keys %ptot) {
558: printf "%9.2f %5.1f%% of %9.2f %5.1f%% p.a. %3dd [%s]\n",
559: $ptot{$cc}{profit}, $ptot{$cc}{percent},
560: $ptot{$cc}{capital}, $ptot{$cc}{pcpa},
561: $ptot{$cc}{days}, $cc;
562: $pr += $ptot{$cc}{profit};
563: $capital += $ptot{$cc}{capital} * $ptot{$cc}{days} / 360.0;
564: $maxd = $ptot{$cc}{days} if $maxd < $ptot{$cc}{days};
565: }
566: printf "%9.2f %5.1f%% of %9.2f %5.1f%% p.a. %3dd %s\n",
567: $pr, 100.0 * $pr / $capital * $maxd / 360.0,
568: 360.0 * $capital / $maxd, 100.0 * $pr / $capital, $maxd,
569: translate($pr < 0 ? 'total loss' : 'total profit');
570: }
571: exit 0;
CVSweb