File Coverage

blib/lib/EB/Booking/BKM.pm
Criterion Covered Total %
statement 18 328 5.4
branch 0 210 0.0
condition 0 103 0.0
subroutine 6 9 66.6
pod 0 3 0.0
total 24 653 3.6


line stmt bran cond sub pod time code
1             #! perl
2              
3             package main;
4              
5             our $cfg;
6             our $dbh;
7              
8             package EB::Booking::BKM;
9              
10             # Author : Johan Vromans
11             # Created On : Thu Jul 7 14:50:41 2005
12             # Last Modified By: Johan Vromans
13             # Last Modified On: Mon Aug 27 13:24:53 2012
14             # Update Count : 547
15             # Status : Unknown, Use with caution!
16              
17             ################ Common stuff ################
18              
19 1     1   1064 use strict;
  1         2  
  1         23  
20 1     1   3 use warnings;
  1         1  
  1         21  
21              
22             # Dagboek type 3: Bank
23             # Dagboek type 4: Kas
24             # Dagboek type 5: Memoriaal
25              
26 1     1   3 use EB;
  1         1  
  1         155  
27 1     1   4 use EB::Format;
  1         0  
  1         111  
28 1     1   4 use EB::Report::Journal;
  1         1  
  1         23  
29 1     1   4 use base qw(EB::Booking);
  1         1  
  1         3220  
30              
31             my $trace_updates = $cfg->val(__PACKAGE__, "trace_updates", 0); # for debugging
32              
33             sub perform {
34 0     0 0   my ($self, $args, $opts) = @_;
35              
36 0 0         return unless $self->adm_open;
37              
38 0           my $dagboek = $opts->{dagboek};
39 0           my $dagboek_type = $opts->{dagboek_type};
40 0           my $totaal = $opts->{totaal};
41 0           my $saldo = $opts->{saldo};
42 0           my $beginsaldo = $opts->{beginsaldo};
43 0           my $does_btw = $dbh->does_btw;
44 0           my $verbose = $opts->{verbose};
45              
46 0 0         if ( defined($totaal) ) {
47 0           my $t = amount($totaal);
48 0 0         return "?".__x("Ongeldig totaal: {total}", total => $totaal)
49             unless defined $t;
50 0           $totaal = $t;
51             }
52              
53 0 0         if ( defined($saldo) ) {
54 0           my $t = amount($saldo);
55 0 0         return "?".__x("Ongeldig saldo: {saldo}", saldo => $saldo)
56             unless defined $t;
57 0           $saldo = $t;
58             }
59              
60 0 0         if ( defined($beginsaldo) ) {
61 0           my $t = amount($beginsaldo);
62 0 0         return "?".__x("Ongeldig beginsaldo: {saldo}", saldo => $beginsaldo)
63             unless defined $t;
64 0           $beginsaldo = $t;
65             }
66              
67 0   0       my $bky = $self->{bky} ||= $opts->{boekjaar} || $dbh->adm("bky");
      0        
68              
69 0           my ($begin, $end);
70 0 0         return unless ($begin, $end) = $self->begindate;
71              
72 0           my $date;
73 0 0         if ( $date = parse_date($args->[0], substr($begin, 0, 4)) ) {
74 0           shift(@$args);
75             }
76             else {
77 0 0 0       return "?".__x("Onherkenbare datum: {date}",
78             date => $args->[0])."\n"
79             if ($args->[0]||"") =~ /^[[:digit:]]+-/;
80 0           $date = iso8601date();
81             }
82              
83 0 0         return "?"._T("Deze opdracht is onvolledig. Gebruik de \"help\" opdracht voor meer aanwijzingen.")."\n"
84             unless @$args;
85              
86 0 0         return unless $self->in_bky($date, $begin, $end);
87              
88 0           my $gdesc = shift(@$args);
89              
90 0           my $bsk_nr = $self->bsk_nr($opts);
91 0 0         return unless defined($bsk_nr);
92              
93 0           my $nr = 1;
94 0           my $bsk_id;
95 0           my $gacct = $dbh->lookup($dagboek, qw(Dagboeken dbk_id dbk_acc_id));
96 0           my $btw_adapt = $cfg->val(qw(strategy btw_adapt), 0);
97              
98 0 0         if ( $gacct ) {
99 0           my $vsaldo = saldo_for($dagboek, $bsk_nr-1, $bky);
100 0 0         if ( defined $beginsaldo ) {
    0          
101 0 0 0       return "?".__x("Beginsaldo komt niet overeen met het eindsaldo van de voorgaande boeking",
102             s1 => numfmt($beginsaldo), s2 => numfmt($vsaldo))."\n"
103             if defined($vsaldo) && $vsaldo != $beginsaldo;
104 0 0         print(__x("Beginsaldo: {bal}", bal => numfmt($beginsaldo)), "\n")
105             if $verbose;
106             }
107             elsif ( defined $vsaldo ) {
108 0           $beginsaldo = $vsaldo;
109 0 0         print(__x("Saldo voorgaande boeking: {bal}", bal => numfmt($beginsaldo)), "\n")
110             if $verbose;
111             }
112             else {
113 0           $beginsaldo = $dbh->lookup($gacct, qw(Accounts acc_id acc_balance));
114 0 0         print(__x("Huidig saldo: {bal}", bal => numfmt($beginsaldo)), "\n")
115             if $verbose;
116             }
117             }
118              
119 0           $bsk_id = $dbh->get_sequence("boekstukken_bsk_id_seq");
120 0           $dbh->begin_work;
121 0           $dbh->sql_insert("Boekstukken",
122             [qw(bsk_id bsk_nr bsk_desc bsk_dbk_id bsk_date bsk_bky)],
123             $bsk_id, $bsk_nr, $gdesc, $dagboek, $date, $bky);
124 0           my $tot = 0;
125 0           my $did = 0;
126 0           my $fail = 0;
127              
128             ENTRY:
129 0           while ( @$args ) {
130 0           my $type = shift(@$args);
131 0           my $bsr_ref;
132              
133 0 0 0       if ( $type eq "std" ) {
    0          
134 0 0         return "?"._T("Deze opdracht is onvolledig. Gebruik de \"help\" opdracht voor meer aanwijzingen.")."\n"
135             unless @$args >= 3;
136 0           my $dd = parse_date($args->[0], substr($begin, 0, 4));
137 0 0         if ( $dd ) {
138 0           shift(@$args);
139 0 0         return unless $self->in_bky($dd, $begin, $end);
140 0 0 0       if ( $does_btw && $dbh->adm("btwbegin") && $dd lt $dbh->adm("btwbegin") ) {
      0        
141 0           warn("?"._T("De boekingsdatum valt in de periode waarover al BTW aangifte is gedaan")."\n");
142 0           return;
143             }
144             }
145             else {
146 0 0 0       return "?".__x("Onherkenbare datum: {date}",
147             date => $args->[0])."\n"
148             if ($args->[0]||"") =~ /^[[:digit:]]+-/;
149 0           $dd = $date;
150             }
151 0 0         return "?"._T("Deze opdracht is onvolledig. Gebruik de \"help\" opdracht voor meer aanwijzingen.")."\n"
152             unless @$args >= 3;
153              
154 0           my ($desc, $amt, $acct) = splice(@$args, 0, 3);
155 0 0         if ( $opts->{verbose} ) {
156 0           my $t = $desc;
157 0 0         $t = '"' . $desc . '"' if $t =~ /\s/;
158 0           warn(" "._T("boekstuk").": std $t $amt $acct\n");
159             }
160              
161 0 0         if ( $acct !~ /^\d+$/ ) {
162 0 0         if ( $acct =~ /^(\d+)([cd])/i ) {
163 0           warn("?"._T("De \"D\" of \"C\" toevoeging aan het rekeningnummer is hier niet toegestaan")."\n");
164             }
165             else {
166 0           warn("?".__x("Ongeldig grootboekrekeningnummer: {acct}", acct => $acct )."\n");
167             }
168 0           $fail++;
169 0           next;
170             }
171              
172 0           my $rr = $dbh->do("SELECT acc_desc,acc_balres,acc_kstomz,acc_btw".
173             " FROM Accounts".
174             " WHERE acc_id = ?", $acct);
175 0 0         unless ( $rr ) {
176 0           warn("?".__x("Onbekende grootboekrekening: {acct}",
177             acct => $acct)."\n");
178 0           $fail++;
179 0           next;
180             }
181 0           my ($adesc, $balres, $kstomz, $btw_id) = @$rr;
182              
183 0 0 0       if ( $balres && $dagboek_type != DBKTYPE_MEMORIAAL ) {
184 0           warn("!".__x("Grootboekrekening {acct} ({desc}) is een balansrekening",
185             acct => $acct, desc => $adesc)."\n") if 0;
186             }
187 0 0 0       if ( $btw_id && !$does_btw ) {
188 0           croak("INTERNAL ERROR: ".
189             __x("Grootboekrekening {acct} heeft BTW in een BTW-vrije administratie",
190             acct => $acct));
191             }
192              
193 0           my $bid;
194 0           my $oamt = $amt;
195 0           my $btw_explicit;
196 0 0         ($amt, $bid, $btw_explicit) =
197             $does_btw ? $self->amount_with_btw($amt, undef) : amount($amt);
198 0 0         unless ( defined($amt) ) {
199 0           warn("?".__x("Ongeldig bedrag: {amt}", amt => $oamt)."\n");
200 0           $fail++;
201 0           next;
202             }
203 0 0 0       $btw_id = 0, undef($bid) if defined($bid) && !$bid; # override: @0
204              
205             # For memorials, if there's BTW associated, it must be explicitly confirmed.
206 0 0 0       if ( $btw_id && !defined($bid) && $dagboek_type == DBKTYPE_MEMORIAAL ) {
      0        
207 0           warn("?"._T("Boekingen met BTW zijn niet mogelijk in een memoriaal.".
208             " De BTW is op nul gesteld.")."\n");
209 0           $btw_id = 0;
210             }
211              
212 0           my $btw_acc;
213 0 0         if ( defined($bid) ) {
214              
215 0           ($btw_id, $kstomz) = $self->parse_btw_spec($bid, $btw_id, $kstomz);
216 0 0         unless ( defined($btw_id) ) {
217 0           warn("?".__x("Ongeldige BTW-specificatie: {spec}", spec => $bid)."\n");
218 0           $fail++;
219 0           next;
220             }
221              
222 0 0 0       if ( !defined($kstomz) && $btw_id ) {
223 0           warn("?"._T("BTW toepassen is niet mogelijk op een neutrale rekening")."\n");
224 0           $fail++;
225 0           next;
226             }
227             }
228 0 0         if ( $btw_id ) {
229 0           my $res = $dbh->do( "SELECT btw_tariefgroep, btw_start, btw_end, btw_alias, btw_desc, btw_incl".
230             " FROM BTWTabel".
231             " WHERE btw_id = ?",
232             $btw_id );
233 0           my $incl = $res->[5];
234              
235 0           my $tg;
236 0 0 0       unless ( defined($res) && defined( $tg = $res->[0] ) ) {
237 0           warn("?".__x("Onbekende BTW-code: {code}", code => $btw_id)."\n");
238 0           return;
239             }
240 0 0         croak("INTERNAL ERROR: btw code $btw_id heeft tariefgroep $tg")
241             unless $tg;
242 0 0 0       if ( defined( $res->[1] ) && $res->[1] gt $dd ) {
243 0           my $ok = 0;
244 0 0 0       if ( $btw_adapt && !$btw_explicit ) {
245 0 0         my $rr = $dbh->do( "SELECT btw_id, btw_desc".
246             " FROM BTWTabel".
247             " WHERE btw_tariefgroep = ?".
248             " AND btw_end >= ?".
249             " AND " . ( $incl ? "" : "NOT " ) . "btw_incl".
250             " ORDER BY btw_id",
251             $tg, $dd );
252 0 0 0       if ( $rr && $rr->[0] ) {
253 0   0       warn("%".__x("BTW-code: {code} aangepast naar {new} i.v.m. de boekingsdatum",
      0        
254             code => $res->[3]||$res->[4]||$btw_id,
255             new => $rr->[1]||$rr->[0],
256             )."\n");
257 0           $btw_id = $rr->[0];
258 0           $ok++;
259             }
260             }
261 0 0         unless ( $ok ) {
262 0   0       warn("!".__x("BTW-code: {code} is nog niet geldig op de boekingsdatum",
263             code => $res->[3]||$res->[4]||$btw_id)."\n");
264             }
265             }
266 0 0 0       if ( defined( $res->[2] ) && $res->[2] lt $dd ) {
267 0           my $ok = 0;
268 0 0 0       if ( $btw_adapt && !$btw_explicit ) {
269 0 0         my $rr = $dbh->do( "SELECT btw_id, btw_desc".
270             " FROM BTWTabel".
271             " WHERE btw_tariefgroep = ?".
272             " AND btw_start <= ?".
273             " AND " . ( $incl ? "" : "NOT " ) . "btw_incl".
274             " ORDER BY btw_id",
275             $tg, $dd );
276 0 0 0       if ( $rr && $rr->[0] ) {
277 0   0       warn("%".__x("BTW-code: {code} aangepast naar {new} i.v.m. de boekingsdatum",
      0        
278             code => $res->[3]||$res->[4]||$btw_id,
279             new => $rr->[1]||$rr->[0],
280             )."\n");
281 0           $btw_id = $rr->[0];
282 0           $ok++;
283             }
284             }
285 0 0         unless ( $ok ) {
286 0   0       warn("!".__x("BTW-code: {code} is niet meer geldig op de boekingsdatum",
287             code => $res->[3]||$res->[4]||$btw_id)."\n");
288             }
289             }
290 0           my $tp = BTWTARIEVEN->[$tg];
291 0           my $t = qw(v i)[$kstomz] . lc(substr($tp, 0, 1));
292 0           $btw_acc = $dbh->std_acc("btw_$t");
293             }
294              
295 0           my $btw = 0;
296 0           my $bsr_amount = $amt;
297 0           my $orig_amount = $amt;
298 0           my ($btw_ink, $btw_verk);
299 0 0         if ( $btw_id ) {
300             ( $bsr_amount, $btw, $btw_ink, $btw_verk ) =
301 0           @{$self->norm_btw($bsr_amount, $btw_id)};
  0            
302 0           $amt = $bsr_amount - $btw;
303             }
304 0           $orig_amount = -$orig_amount;
305              
306 0 0 0       $dbh->sql_insert("Boekstukregels",
307             [qw(bsr_nr bsr_date bsr_bsk_id bsr_desc bsr_amount
308             bsr_btw_id bsr_btw_acc bsr_btw_class bsr_type
309             bsr_acc_id bsr_rel_code bsr_dbk_id bsr_ref)],
310             $nr++, $dd, $bsk_id, $desc, $orig_amount,
311             $btw_id, $btw_acc,
312             BTWKLASSE($does_btw ? defined($kstomz) : 0, BTWTYPE_NORMAAL, $kstomz||0),
313             0, $acct, undef, undef, $bsr_ref);
314              
315             # warn("update $acct with ".numfmt(-$amt)."\n") if $trace_updates;
316             # $dbh->upd_account($acct, -$amt);
317 0           $tot += $amt;
318              
319 0 0         if ( $btw ) {
320             # my $btw_acct =
321             # $dbh->lookup($acct, qw(Accounts acc_id acc_debcrd)) ? $btw_ink : $btw_verk;
322             # warn("update $btw_acct with ".numfmt(-$btw)."\n") if $trace_updates;
323             # $dbh->upd_account($btw_acct, -$btw);
324 0           $tot += $btw;
325             }
326              
327              
328             }
329             elsif ( $type eq "deb" || $type eq "crd" ) {
330 0 0         my $debcrd = $type eq "deb" ? 1 : 0;
331 0 0         return "?"._T("Deze opdracht is onvolledig. Gebruik de \"help\" opdracht voor meer aanwijzingen.")."\n"
332             unless @$args >= 2;
333 0           my $dd = parse_date($args->[0], substr($begin, 0, 4));
334 0 0         if ( $dd ) {
335 0           shift(@$args);
336 0 0         return unless $self->in_bky($dd, $begin, $end);
337 0 0 0       if ( $does_btw && $dbh->adm("btwbegin") && $dd lt $dbh->adm("btwbegin") ) {
      0        
338 0           warn("?"._T("De boekingsdatum valt in de periode waarover al BTW aangifte is gedaan")."\n");
339 0           return;
340             }
341             }
342             else {
343 0 0 0       return "?".__x("Onherkenbare datum: {date}",
344             date => $args->[0])."\n"
345             if ($args->[0]||"") =~ /^[[:digit:]]+-/;
346 0           $dd = $date;
347             }
348 0 0         return "?"._T("Deze opdracht is onvolledig. Gebruik de \"help\" opdracht voor meer aanwijzingen.")."\n"
349             unless @$args >= 2;
350              
351 0           my ($rel, $amt) = splice(@$args, 0, 2);
352 0 0         warn(" "._T("boekstuk").": $type $rel $amt\n")
353             if $verbose;
354              
355 0           my $oamt = $amt;
356 0           $amt = amount($amt);
357 0 0         unless ( defined($amt) ) {
358 0           warn("?".__x("Ongeldig bedrag: {amt}", amt => $oamt)."\n");
359 0           $fail++;
360 0           next;
361             }
362              
363 0           my ($rr, $sql, @sql_args);
364 0 0         if ( $rel =~ /:/ ) {
365 0           $bsr_ref = $rel; # store in db
366 0           my ($id, $bsk, $err) = $dbh->bskid($rel, $bky);
367 0 0         unless ( defined($id) ) {
368 0           warn("?$err\n");
369 0           $fail++;
370 0           next;
371             }
372 0           $sql = "SELECT bsk_nr, bsk_id, dbk_id, dbk_acc_id, bsk_desc, bsk_amount, bsr_rel_code".
373             " FROM Boekstukken, Boekstukregels, Dagboeken" .
374             " WHERE bsk_id = ?".
375             " AND bsk_dbk_id = dbk_id".
376             " AND bsr_bsk_id = bsk_id".
377             " AND bsr_nr = 1".
378             " AND dbk_type = ?";
379 0 0         @sql_args = ( $id, $debcrd ? DBKTYPE_VERKOOP : DBKTYPE_INKOOP);
380 0           $rr = $dbh->do($sql, @sql_args);
381 0 0         unless ( defined($rr) ) {
382             # Can this happen???
383 0           warn("?".__x("Geen post gevonden voor boekstuk {bsk}",
384             bsk => $rel)."\n");
385 0           $fail++;
386 0           next;
387             }
388             }
389             elsif ( 1 ) {
390             # Lookup rel code.
391 0 0         $rr = $dbh->do("SELECT rel_code FROM Relaties" .
392             " WHERE upper(rel_code) = ?" .
393             " AND " . ($debcrd ? "" : "NOT ") . "rel_debcrd",
394             uc($rel));
395 0 0         unless ( defined($rr) ) {
396 0 0         warn("?".__x("Onbekende {what}: {who}",
397             what => lc($type eq "deb" ? _T("Debiteur") : _T("Crediteur")),
398             who => $rel)."\n");
399 0           $fail++;
400 0           next;
401             }
402             # Get actual code.
403 0           $rel = $rr->[0];
404              
405             # Zoek open posten.
406 0           my $ddd;
407 0           my $delta = $cfg->val(qw(strategy bkm_multi_delta), 0);
408 0           $delta = undef; # disable for now.
409 0 0         $ddd = parse_date($dd, substr($begin, 0, 4), $delta) if $delta;
410 0 0         $sql = "SELECT bsk_open, bsk_nr, bsk_id, dbk_id, dbk_acc_id, bsk_desc, bsk_amount ".
411             " FROM Boekstukken, Boekstukregels, Dagboeken" .
412             " WHERE bsk_open != 0".
413             " AND dbk_type = ?".
414             " AND bsk_dbk_id = dbk_id".
415             " AND bsr_bsk_id = bsk_id".
416             " AND bsr_rel_code = ?".
417             " AND bsr_nr = 1".
418             ( $delta ? " AND bsr_date <= ?" : "" ).
419             " ORDER BY bsr_date";
420 0 0         @sql_args = ( $debcrd ? DBKTYPE_VERKOOP : DBKTYPE_INKOOP,
    0          
421             $rel, $delta ? $ddd : () );
422              
423             # Resultset of candidates.
424 0           my $res = [];
425 0           my $sth = $dbh->sql_exec($sql, @sql_args);
426 0           while ( $rr = $sth->fetchrow_arrayref ) {
427 0 0         if ( $rr->[0] == $amt ) { # exact match
428 0           $res = [[@$rr]];
429 0           last;
430             }
431             else {
432             # Add.
433 0           push(@$res, [@$rr]);
434             }
435             }
436 0           $sth->finish;
437              
438 0           my $wmsg;
439 0 0 0       if ( @$res == 0 ) {
    0          
    0          
440             # Nothing.
441 0           undef $rr;
442             }
443             elsif ( @$res == 1 && $res->[0]->[0] == $amt ) {
444             # Exact match. Use it.
445 0           $rr = $res->[0];
446             }
447             # Knapsack slows down terribly with large search sets. Limit it.
448             elsif ( @$res <= $cfg->val(qw(strategy bkm_multi_max), 15) ) {
449             # Use exact knapsack matching to find possible components.
450 0           my @amts = map { $_->[0] } @$res;
  0            
451 0 0         if ( my @k = partition($amt, \@amts) ) {
452             # We found something. Check strategy.
453 0 0         if ( $cfg->val(qw(strategy bkm_multi), 0) ) {
454             # We may split.
455 0           my @t; # for reporting
456 0           foreach ( @{$k[0]} ) {
  0            
457 0           push(@t, numfmt($amts[$_]));
458             # Push back the data in the input queue.
459 0           unshift(@$args, $type, $dd, $rel, numfmt_plain($amts[$_]));
460             }
461             # Inform the user.
462 0           my $t = shift(@t);
463 0           warn("!".__x("Betaling {rel} {amt} voldoet de open posten {amtss} en {amts}",
464             rel => $rel,
465             amt => numfmt($amt),
466             amtss => join(", ", @t),
467             amts => $t)."\n");
468 0           next ENTRY;
469             }
470             else {
471 0           undef $rr;
472 0           foreach my $k ( @k ) {
473 0           my @t; # for reporting
474 0           foreach ( @{$k} ) {
  0            
475 0           push(@t, numfmt($amts[$_]));
476             }
477 0           my $t = shift(@t);
478 0 0         $wmsg .= "\n%" if $wmsg;
479             # $wmsg .= __x("Wellicht de betaling van de open posten {amtss} en {amts}?",
480             # amtss => join(", ", @t),
481             # amts => $t);
482 0           $wmsg .= _T("Wellicht de betaling van de volgende open posten:");
483 0           foreach ( @{$k} ) {
  0            
484 0           my ($open, $bsknr, $bskid, $dbk_id, $bsk_desc, $bsk_amount) = @{$res->[$_]};
  0            
485 0           $wmsg .= sprintf("\n%% %s %s %s",
486             join(":",
487             $dbh->lookup($dbk_id,
488             qw(Dagboeken dbk_id dbk_desc)),
489             $bsknr), numfmt($open), $bsk_desc);
490             }
491             }
492             }
493             }
494             # Punt it.
495             else {
496 0           undef $rr;
497             }
498             }
499             else {
500 0           $wmsg = __x("Geen alternatieven beschikbaar (teveel open posten)");
501 0           undef $rr;
502             }
503              
504 0 0         unless ( defined($rr) ) {
505 0           warn("?".__x("Geen open post van {amt} gevonden voor relatie {rel}",
506             amt => numfmt($amt),
507             rel => $rel)."\n");
508 0 0         if ( $wmsg) {
    0          
509 0           warn("%".$wmsg."\n");
510             }
511             elsif ( @$res ) {
512 0           warn("%".__x("Open posten voor relatie {rel}:", rel => $rel)."\n");
513 0           foreach ( @$res ) {
514 0           my ($open, $bsknr, $bskid, $dbk_id, $dbk_acc_id, $bsk_desc, $bsk_amount) = @$_;
515 0           warn(sprintf("%% %s %s %s\n",
516             join(":",
517             $dbh->lookup($dbk_id,
518             qw(Dagboeken dbk_id dbk_desc)),
519             $bsknr), numfmt($open), $bsk_desc));
520             }
521             }
522 0           $fail++;
523 0           next;
524             }
525 0           $rr = [@$rr, $rel];
526 0           shift(@$rr);
527             }
528             else {
529             # Lookup rel code.
530             $rr = $dbh->do("SELECT rel_code FROM Relaties" .
531             " WHERE upper(rel_code) = ?" .
532             " AND " . ($debcrd ? "" : "NOT ") . "rel_debcrd",
533             uc($rel));
534             unless ( defined($rr) ) {
535             warn("?".__x("Onbekende {what}: {who}",
536             what => lc($type eq "deb" ? _T("Debiteur") : _T("Crediteur")),
537             who => $rel)."\n");
538             $fail++;
539             next;
540             }
541             # Get actual code.
542             $rel = $rr->[0];
543              
544             # Find associated booking.
545             $sql = "SELECT bsk_id, dbk_id, dbk_acc_id, bsk_desc, bsk_amount ".
546             " FROM Boekstukken, Boekstukregels, Dagboeken" .
547             " WHERE bsk_open != 0".
548             ($amt ? " AND bsk_open = ?" : "").
549             " AND dbk_type = ?".
550             " AND bsk_dbk_id = dbk_id".
551             " AND bsr_bsk_id = bsk_id".
552             " AND bsr_rel_code = ?".
553             " ORDER BY bsr_date";
554             @sql_args = ( $amt ? $amt : (),
555             $debcrd ? DBKTYPE_VERKOOP : DBKTYPE_INKOOP,
556             $rel);
557             $rr = $dbh->do($sql, @sql_args);
558             unless ( defined($rr) ) {
559             warn("?".__x("Geen open post van {amt} gevonden voor relatie {rel}",
560             amt => numfmt($amt),
561             rel => $rel)."\n");
562             $fail++;
563             next;
564             }
565             $rr = [@$rr, $rel];
566             }
567              
568 0           my ($bsknr, $bskid, $dbk_id, $dbk_acc_id, $bsk_desc, $bsk_amount, $bsr_rel) = @$rr;
569             #my $acct = $dbh->std_acc($debcrd ? "deb" : "crd");
570 0           my $acct = $dbk_acc_id;
571              
572 0 0         $dbh->sql_insert("Boekstukregels",
573             [qw(bsr_nr bsr_date bsr_bsk_id bsr_desc bsr_amount
574             bsr_btw_id bsr_type bsr_acc_id bsr_btw_class
575             bsr_rel_code bsr_dbk_id bsr_paid bsr_ref)],
576             $nr++, $dd, $bsk_id, "*".$bsk_desc, -$amt, 0,
577             $type eq "deb" ? 1 : 2, $acct, 0, $bsr_rel, $dbk_id,
578             $bskid, $bsr_ref);
579 0           $dbh->sql_exec("UPDATE Boekstukken".
580             " SET bsk_open = bsk_open - ?".
581             " WHERE bsk_id = ?",
582             $amt, $bskid);
583              
584             # warn("update $acct with ".numfmt(-$amt)."\n") if $trace_updates;
585             # $dbh->upd_account($acct, -$amt);
586 0           $tot += $amt;
587             }
588             else {
589 0           warn("?".__x("Onbekend transactietype: {type}", type => $type)."\n");
590 0           $fail++;
591 0           next;
592             }
593             }
594              
595 0 0         if ( $gacct ) {
    0          
596 0 0         warn("update $gacct with ".numfmt($tot)."\n") if $trace_updates;
597 0           $dbh->upd_account($gacct, $tot);
598             # my $new = $dbh->lookup($gacct, qw(Accounts acc_id acc_balance));
599 0           my $new = $beginsaldo + $tot;
600 0 0         print(__x("Nieuw saldo: {bal}", bal => numfmt($new)), "\n")
601             if $verbose;
602 0           $dbh->sql_exec("UPDATE Boekstukken".
603             " SET bsk_saldo = ?, bsk_isaldo = ?".
604             " WHERE bsk_id = ?",
605             $new, $beginsaldo, $bsk_id)->finish;
606 0 0         if ( defined $saldo ) {
607 0 0         unless ( $saldo == $new ) {
608 0           warn("?".__x("Saldo {new} klopt niet met de vereiste waarde {act}",
609             new => numfmt($new), act => numfmt($saldo))."\n");
610 0           $fail++;
611             }
612             }
613 0 0 0       if ( defined($totaal) and $tot != $totaal ) {
614 0           $fail++;
615 0           warn("?".__x(" Boekstuk totaal is {act} in plaats van {exp}",
616             act => numfmt($tot), exp => numfmt($totaal)) . "\n");
617             }
618 0           my $isaldo = saldo_for($dagboek, $bsk_nr+1, $bky, "isaldo");
619 0 0 0       if ( defined($isaldo) and $isaldo != $new ) {
620 0           $fail++;
621 0           warn("?".__x("Saldo {new} klopt niet met beginsaldo eropvolgende boekstuk {isaldo}",
622             new => numfmt($new), isaldo => numfmt($isaldo)) . "\n");
623             }
624             }
625             elsif ( $tot ) {
626 0           warn("?".__x("Boekstuk is niet in balans (verschil is {diff})",
627             diff => numfmt($tot))."\n");
628 0           $fail++;
629             }
630 0           $dbh->sql_exec("UPDATE Boekstukken SET bsk_amount = ? WHERE bsk_id = ?",
631             $tot, $bsk_id)->finish;
632              
633 0           $dbh->store_journal($self->journalise($bsk_id));
634              
635 0 0         if ( $opts->{journal} ) {
636 0 0         warn("?"._T("Dit overzicht is ter referentie, de boeking is niet uitgevoerd!")."\n") if $fail;
637 0           EB::Report::Journal->new->journal
638             ({select => $bsk_id,
639             d_boekjaar => $bky,
640             detail => 1});
641             }
642              
643 0 0         if ( $fail ) {
644 0           warn("?"._T("Boeking ".
645             join(":", ($dbh->lookup($dagboek, qw(Dagboeken dbk_id dbk_desc)), $bsk_nr)).
646             " is niet uitgevoerd!")."\n");
647 0           $dbh->rollback;
648 0           return undef;
649             }
650 0           $dbh->commit;
651              
652             # TODO -- need this to get a current booking.
653 0 0 0       $verbose || 1
654             ? join(":", $dbh->lookup($dagboek, qw(Dagboeken dbk_id dbk_desc)), $bsk_nr)
655             : "";
656             }
657              
658             sub saldo_for {
659 0     0 0   my ($dbk, $nr, $bky, $ww) = (@_, "saldo");
660 0           my $sth = $dbh->sql_exec("SELECT bsk_$ww FROM Boekstukken".
661             " WHERE bsk_dbk_id = ? AND bsk_nr = ?".
662             " AND bsk_bky = ?",
663             $dbk, $nr, $bky);
664 0           my $rr = $sth->fetchrow_arrayref;
665 0           $sth->finish;
666 0 0 0       if ( $rr && defined($rr->[0]) ) {
667 0           return $rr->[0];
668             }
669 0           return;
670             }
671              
672             # Adapted from 'Higher Order Perl' (Mark Jason Dominus),
673             # sec 5.1.1 "Finding All Possible Partitions".
674              
675             sub partition {
676 0     0 0   my ($target, $values, $ix) = @_;
677 0 0         return [] if $target == 0;
678              
679 0 0         $ix = [ 0 .. $#{$values} ] unless defined $ix;
  0            
680 0 0         return () if @$ix == 0;
681              
682 0           my ($first, @rest) = @$ix;
683 0           my @solutions = partition($target - $values->[$first], $values, \@rest);
684 0           return ( (map { [ $first, @$_ ] } @solutions),
  0            
685             partition($target, $values, \@rest));
686             }
687              
688             1;