File Coverage

blib/lib/EB/Booking/IV.pm
Criterion Covered Total %
statement 21 183 11.4
branch 0 134 0.0
condition 0 79 0.0
subroutine 7 8 87.5
pod 0 1 0.0
total 28 405 6.9


line stmt bran cond sub pod time code
1             #! perl -- -*- coding: utf-8 -*-
2              
3 1     1   1309 use utf8;
  1         2  
  1         4  
4              
5             package main;
6              
7             our $cfg;
8             our $dbh;
9              
10             package EB::Booking::IV;
11              
12             # Author : Johan Vromans
13             # Created On : Thu Jul 7 14:50:41 2005
14             # Last Modified By: Johan Vromans
15             # Last Modified On: Mon Aug 27 13:23:24 2012
16             # Update Count : 343
17             # Status : Unknown, Use with caution!
18              
19             ################ Common stuff ################
20              
21 1     1   47 use strict;
  1         1  
  1         15  
22 1     1   3 use warnings;
  1         0  
  1         19  
23              
24             # Dagboek type 1: Inkoop
25             # Dagboek type 2: Verkoop
26              
27 1     1   3 use EB;
  1         0  
  1         156  
28 1     1   4 use EB::Format;
  1         1  
  1         105  
29 1     1   398 use EB::Report::Journal;
  1         2  
  1         39  
30 1     1   4 use base qw(EB::Booking);
  1         1  
  1         1728  
31              
32             my $trace_updates = $cfg->val(__PACKAGE__, "trace_updates", 0); # for debugging
33              
34             sub perform {
35 0     0 0   my ($self, $args, $opts) = @_;
36              
37 0 0         return unless $self->adm_open;
38              
39 0           my $dagboek = $opts->{dagboek};
40 0           my $dagboek_type = $opts->{dagboek_type};
41 0           my $bsk_ref = $opts->{ref};
42              
43 0 0 0       if ( defined $bsk_ref && $bsk_ref =~ /^\d+$/ ) {
44 0           warn("?".__x("Boekingsreferentie moet tenminste één niet-numeriek teken bevatten: {ref}", ref => $bsk_ref)."\n");
45 0           return;
46             }
47              
48 0 0 0       unless ( $dagboek_type == DBKTYPE_INKOOP || $dagboek_type == DBKTYPE_VERKOOP) {
49 0           warn("?".__x("Ongeldige operatie (IV) voor dagboek type {type}",
50             type => $dagboek_type)."\n");
51 0           return;
52             }
53              
54 0           my $iv = $dagboek_type == DBKTYPE_INKOOP;
55 0           my $totaal = $opts->{totaal};
56 0           my $does_btw = $dbh->does_btw;
57              
58 0   0       my $bky = $self->{bky} ||= $opts->{boekjaar} || $dbh->adm("bky");
      0        
59              
60 0 0         if ( defined($totaal) ) {
61 0           my $t = amount($totaal);
62 0 0         return "?".__x("Ongeldig totaal: {total}", total => $totaal)
63             unless defined $t;
64 0           $totaal = $t;
65             }
66              
67 0           my ($begin, $end);
68 0 0         return unless ($begin, $end) = $self->begindate;
69              
70 0           my $date;
71 0 0         if ( $date = parse_date($args->[0], substr($begin, 0, 4)) ) {
72 0           shift(@$args);
73             }
74             else {
75 0 0 0       return "?".__x("Onherkenbare datum: {date}",
76             date => $args->[0])."\n"
77             if ($args->[0]||"") =~ /^[[:digit:]]+-/;
78 0           $date = iso8601date();
79             }
80              
81 0 0         return "?"._T("Deze opdracht is onvolledig. Gebruik de \"help\" opdracht voor meer aanwijzingen.")."\n"
82             unless @$args >= 3;
83              
84 0 0         return unless $self->in_bky($date, $begin, $end);
85              
86 0 0 0       if ( $does_btw && $dbh->adm("btwbegin") && $date lt $dbh->adm("btwbegin") ) {
      0        
87 0           warn("?"._T("De boekingsdatum valt in de periode waarover al BTW aangifte is gedaan")."\n");
88 0           return;
89             }
90              
91 0           my $gdesc = "";
92 0           my $debcode;
93             my $rr;
94              
95 0 0         if ( $cfg->val(qw(general ivdesc), undef) ) {
96 0           $gdesc = shift(@$args);
97 0           $debcode = shift(@$args);
98 0 0         $rr = $dbh->do("SELECT rel_code, rel_acc_id, rel_btw_status FROM Relaties" .
99             " WHERE UPPER(rel_code) = ?" .
100             " AND " . ($iv ? "NOT " : "") . "rel_debcrd" .
101             " AND rel_ledger = ?",
102             uc($debcode), $dagboek);
103 0 0         unless ( defined($rr) ) {
104 0           unshift(@$args, $debcode);
105 0           $debcode = $gdesc;
106 0           $gdesc = "";
107 0 0         $rr = $dbh->do("SELECT rel_code, rel_acc_id, rel_btw_status FROM Relaties" .
108             " WHERE UPPER(rel_code) = ?" .
109             " AND " . ($iv ? "NOT " : "") . "rel_debcrd" .
110             " AND rel_ledger = ?",
111             uc($debcode), $dagboek);
112 0 0         unless ( defined($rr) ) {
113 0 0         warn("?".__x("Onbekende {what}: {who}",
114             what => lc($iv ? _T("Crediteur") : _T("Debiteur")),
115             who => $debcode)."\n");
116 0           return;
117             }
118             }
119             }
120             else {
121 0           $debcode = shift(@$args);
122 0 0         $rr = $dbh->do("SELECT rel_code, rel_acc_id, rel_btw_status FROM Relaties" .
123             " WHERE UPPER(rel_code) = ?" .
124             " AND " . ($iv ? "NOT " : "") . "rel_debcrd" .
125             " AND rel_ledger = ?",
126             uc($debcode), $dagboek);
127 0 0         unless ( defined($rr) ) {
128 0           $gdesc = $debcode;
129 0           $debcode = shift(@$args);
130 0 0         $rr = $dbh->do("SELECT rel_code, rel_acc_id, rel_btw_status FROM Relaties" .
131             " WHERE UPPER(rel_code) = ?" .
132             " AND " . ($iv ? "NOT " : "") . "rel_debcrd" .
133             " AND rel_ledger = ?",
134             uc($debcode), $dagboek);
135 0 0         unless ( defined($rr) ) {
136 0 0         warn("?".__x("Onbekende {what}: {who}",
137             what => lc($iv ? _T("Crediteur") : _T("Debiteur")),
138             who => $debcode)."\n");
139 0           return;
140             }
141             }
142             }
143              
144 0           my ($rel_acc_id, $rel_btw);
145 0           ($debcode, $rel_acc_id, $rel_btw) = @$rr;
146              
147 0           my $btw_adapt = $cfg->val(qw(strategy btw_adapt), 0);
148 0           my $nr = 1;
149 0           my $bsk_id;
150             my $bsk_nr;
151 0           my $did = 0;
152              
153 0           while ( @$args ) {
154 0 0         return "?"._T("Deze opdracht is onvolledig. Gebruik de \"help\" opdracht voor meer aanwijzingen.")."\n"
155             unless @$args >= 2;
156 0           my ($desc, $amt, $acct) = splice(@$args, 0, 3);
157 0           my $bsr_ref;
158 0 0         $desc = $gdesc if $desc !~ /\S/;
159 0 0         $gdesc = $desc if $gdesc !~ /\S/;
160 0   0       $acct ||= $rel_acc_id;
161 0 0         if ( $opts->{verbose} ) {
162 0           my $t = $desc;
163 0 0         $t = '"' . $desc . '"' if $t =~ /\s/;
164 0           warn(" "._T("boekstuk").": $t $amt $acct\n");
165             }
166 0 0         unless ( $desc =~ /\S/ ) {
167 0           warn("?"._T("De omschrijving van de boekstukregel ontbreekt")."\n");
168 0           return;
169             }
170              
171 0 0         if ( $acct !~ /^\d+$/ ) {
172 0 0         if ( $acct =~ /^(\d*)([cd])/i ) {
173 0           warn("?"._T("De \"D\" of \"C\" toevoeging aan het rekeningnummer is hier niet toegestaan")."\n");
174 0           return;
175             }
176 0           warn("?".__x("Ongeldig grootboekrekeningnummer: {acct}", acct => $acct )."\n");
177 0           return;
178             }
179 0           my $rr = $dbh->do("SELECT acc_desc,acc_balres,acc_kstomz,acc_debcrd,acc_btw".
180             " FROM Accounts".
181             " WHERE acc_id = ?", $acct);
182 0 0         unless ( $rr ) {
183 0           warn("?".__x("Onbekende grootboekrekening: {acct}",
184             acct => $acct)."\n");
185 0 0         $dbh->rollback if $dbh->in_transaction;
186 0           return;
187             }
188 0           my ($adesc, $balres, $kstomz, $debcrd, $btw_id) = @$rr;
189 0 0         if ( $balres ) {
190 0           warn("!".__x("Grootboekrekening {acct} ({desc}) is een balansrekening",
191             acct => $acct, desc => $adesc)."\n") if 0;
192             #$dbh->rollback;
193             #return;
194             }
195 0 0 0       if ( $btw_id && !$does_btw ) {
196 0           croak("INTERNAL ERROR: ".
197             __x("Grootboekrekening {acct} heeft BTW in een BTW-vrije administratie",
198             acct => $acct));
199             }
200              
201 0 0         if ( $nr == 1 ) {
202 0           $bsk_nr = $self->bsk_nr($opts);
203 0 0         return unless defined($bsk_nr);
204 0           $bsk_id = $dbh->get_sequence("boekstukken_bsk_id_seq");
205 0 0 0       if ( $bsk_ref and $dbh->do("SELECT count(*)".
206             " FROM Boekstukken, Boekstukregels".
207             " WHERE bsk_id = bsr_bsk_id".
208             " AND upper(bsk_ref) = ?".
209             " AND upper(bsr_rel_code) = ?".
210             " AND bsk_bky = ?",
211             uc($bsk_ref), uc($debcode), $bky)->[0] ) {
212 0           warn("?".__x("Referentie {ref} bestaat al voor relatie {rel}",
213             rel => $debcode, ref => $bsk_ref)."\n");
214 0           return;
215             }
216              
217              
218 0           $dbh->begin_work;
219 0           $dbh->sql_insert("Boekstukken",
220             [qw(bsk_id bsk_nr bsk_ref bsk_desc bsk_dbk_id bsk_date bsk_bky)],
221             $bsk_id, $bsk_nr, $bsk_ref, $gdesc, $dagboek, $date, $bky);
222             }
223              
224             # Amount can override BTW id with @X postfix.
225 0 0         my ($namt, $btw_spec, $btw_explicit) =
226             $does_btw ? $self->amount_with_btw($amt, $btw_id) : amount($amt);
227 0 0         unless ( defined($namt) ) {
228 0           warn("?".__x("Ongeldig bedrag: {amt}", amt => $amt)."\n");
229 0           return;
230             }
231              
232 0 0         $amt = $iv ? $namt : -$namt;
233              
234 0 0         if ( $does_btw ) {
235 0           ($btw_id, $kstomz) = $self->parse_btw_spec($btw_spec, $btw_id, $kstomz);
236 0 0         unless ( defined($btw_id) ) {
237 0           warn("?".__x("Ongeldige BTW-specificatie: {spec}", spec => $btw_spec)."\n");
238 0           return;
239             }
240             }
241              
242             # Bepalen van de BTW.
243             # Voor neutrale boekingen (@N, of op een neutrale rekening) wordt geen BTW
244             # toegepast. Op _alle_ andere wel. De BTW kan echter nul zijn, of void.
245             # Het eerste wordt bewerkstelligd door $btw_id op 0 te zetten, het tweede
246             # door $btw_acc geen waarde te geven.
247 0           my $btwclass = 0;
248 0           my $btw_acc;
249 0 0         if ( defined($kstomz) ) {
    0          
250             # BTW toepassen.
251 0 0         if ( $kstomz ? !$iv : $iv ) {
    0          
252             #warn("?".__x("U kunt geen {ko} boeken in een {iv} dagboek",
253 0 0         warn("!".__x("Pas op! U boekt {ko} in een {iv} dagboek",
    0          
254             ko => $kstomz ? _T("kosten") : _T("omzet"),
255             iv => $iv ? _T("inkoop") : _T("verkoop"),
256             )."\n");
257             #return;
258             }
259             # Void BTW voor non-EU en verlegd.
260 0 0 0       if ( $btw_id && ($rel_btw == BTWTYPE_NORMAAL || $rel_btw == BTWTYPE_INTRA) ) {
      0        
261              
262 0           my $res = $dbh->do( "SELECT btw_tariefgroep, btw_start, btw_end, btw_alias, btw_desc, btw_incl".
263             " FROM BTWTabel".
264             " WHERE btw_id = ?",
265             $btw_id );
266 0           my $incl = $res->[5];
267              
268 0           my $tg;
269 0 0 0       unless ( defined($res) && defined( $tg = $res->[0] ) ) {
270 0           warn("?".__x("Onbekende BTW-code: {code}", code => $btw_id)."\n");
271 0           return;
272             }
273 0 0 0       if ( defined( $res->[1] ) && $res->[1] gt $date ) {
274 0           my $ok = 0;
275 0 0 0       if ( $btw_adapt && !$btw_explicit ) {
276 0 0         my $rr = $dbh->do( "SELECT btw_id, btw_desc".
277             " FROM BTWTabel".
278             " WHERE btw_tariefgroep = ?".
279             " AND btw_end >= ?".
280             " AND " . ( $incl ? "" : "NOT " ) . "btw_incl".
281             " ORDER BY btw_id",
282             $tg, $date );
283 0 0 0       if ( $rr && $rr->[0] ) {
284 0   0       warn("%".__x("BTW-code: {code} aangepast naar {new} i.v.m. de boekingsdatum",
      0        
285             code => $res->[3]||$res->[4]||$btw_id,
286             new => $rr->[1]||$rr->[0],
287             )."\n");
288 0           $btw_id = $rr->[0];
289 0           $ok++;
290             }
291             }
292 0 0         unless ( $ok ) {
293 0   0       warn("!".__x("BTW-code: {code} is nog niet geldig op de boekingsdatum",
294             code => $res->[3]||$res->[4]||$btw_id)."\n");
295             }
296             }
297 0 0 0       if ( defined( $res->[2] ) && $res->[2] lt $date ) {
298 0           my $ok = 0;
299 0 0 0       if ( $btw_adapt && !$btw_explicit ) {
300 0 0         my $rr = $dbh->do( "SELECT btw_id, btw_desc".
301             " FROM BTWTabel".
302             " WHERE btw_tariefgroep = ?".
303             " AND btw_start <= ?".
304             " AND " . ( $incl ? "" : "NOT " ) . "btw_incl".
305             " ORDER BY btw_id",
306             $tg, $date );
307 0 0 0       if ( $rr && $rr->[0] ) {
308 0   0       warn("%".__x("BTW-code: {code} aangepast naar {new} i.v.m. de boekingsdatum",
      0        
309             code => $res->[3]||$res->[4]||$btw_id,
310             new => $rr->[1]||$rr->[0],
311             )."\n");
312 0           $btw_id = $rr->[0];
313 0           $ok++;
314             }
315             }
316 0 0         unless ( $ok ) {
317 0   0       warn("!".__x("BTW-code: {code} is niet meer geldig op de boekingsdatum",
318             code => $res->[3]||$res->[4]||$btw_id)."\n");
319             }
320             }
321 0           my $tp = BTWTARIEVEN->[$tg];
322 0           my $t = qw(v i)[$iv] . lc(substr($tp, 0, 1));
323 0           $btw_acc = $dbh->std_acc("btw_$t");
324             }
325             }
326             elsif ( $btw_id ) {
327 0           warn("?"._T("BTW toepassen is niet mogelijk op een neutrale rekening")."\n");
328 0           return;
329             }
330             # ASSERT: $btw_id != 0 implies defined($kstomz).
331              
332 0 0         $dbh->sql_insert("Boekstukregels",
    0          
333             [qw(bsr_nr bsr_date bsr_bsk_id bsr_desc bsr_amount
334             bsr_btw_id bsr_btw_acc bsr_btw_class bsr_type bsr_acc_id
335             bsr_rel_code bsr_dbk_id bsr_ref)],
336             $nr++, $date, $bsk_id, $desc, $amt,
337             $btw_id, $btw_acc,
338             BTWKLASSE($does_btw ? defined($kstomz) : 0, $rel_btw, defined($kstomz) ? $kstomz : $iv),
339             0, $acct, $debcode, $dagboek, $bsr_ref);
340             }
341              
342 0           my $ret = $self->journalise($bsk_id, $iv, $totaal);
343             # $rr = [ @$ret ];
344             # shift(@$rr);
345             # $rr = [ sort { $a->[5] <=> $b->[5] } @$rr ];
346             # foreach my $r ( @$rr ) {
347             # my (undef, undef, undef, undef, $nr, $ac, $amt) = @$r;
348             # next unless $nr;
349             # warn("update $ac with ".numfmt($amt)."\n") if $trace_updates;
350             # $dbh->upd_account($ac, $amt);
351             # }
352 0           my $tot = $ret->[$#{$ret}]->[8]; # ERROR PRONE
  0            
353 0           $dbh->sql_exec("UPDATE Boekstukken SET bsk_amount = ?, bsk_open = ? WHERE bsk_id = ?",
354             $tot, $tot, $bsk_id)->finish;
355              
356 0           $dbh->store_journal($ret);
357              
358 0 0         $tot = -$tot if $iv;
359 0   0       my $fail = defined($totaal) && $tot != $totaal;
360 0 0         if ( $opts->{journal} ) {
361 0 0         warn("?"._T("Dit overzicht is ter referentie, de boeking is niet uitgevoerd!")."\n") if $fail;
362 0           EB::Report::Journal->new->journal
363             ({select => $bsk_id,
364             d_boekjaar => $bky,
365             detail => 1});
366             }
367              
368 0 0         if ( $fail ) {
369 0           $dbh->rollback;
370 0           return "?"._T("Boeking ".
371             join(":", $dbh->lookup($dagboek, qw(Dagboeken dbk_id dbk_desc)), $bsk_nr).
372             " is niet uitgevoerd!")." ".
373             __x(" Boekstuk totaal is {act} in plaats van {exp}",
374             act => numfmt($tot), exp => numfmt($totaal)) . ".";
375             }
376             else {
377 0           $dbh->commit;
378             }
379              
380             # TODO -- need this to get a current booking.
381 0 0 0       $opts->{verbose} || 1
382             ? join(":", $dbh->lookup($dagboek, qw(Dagboeken dbk_id dbk_desc)), $bsk_nr)
383             : "";
384             }
385              
386             1;