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