File Coverage

blib/lib/EB/Booking/BKM.pm
Criterion Covered Total %
statement 18 334 5.3
branch 0 218 0.0
condition 0 106 0.0
subroutine 6 9 66.6
pod 0 3 0.0
total 24 670 3.5


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