File Coverage

blib/lib/EB/Booking/IV.pm

Criterion	Covered	Total	%
statement	21	201	10.4
branch	0	150	0.0
condition	0	85	0.0
subroutine	7	9	77.7
pod	0	2	0.0
total	28	447	6.2

#! perl --			-*- coding: utf-8 -*-

use utf8;

package main;

our $cfg;
our $dbh;

package EB::Booking::IV;

# Author          : Johan Vromans
# Created On      : Thu Jul  7 14:50:41 2005
# Last Modified By: Johan Vromans
# Last Modified On: Tue Apr 24 12:25:35 2018
# Update Count    : 371
# Status          : Unknown, Use with caution!

################ Common stuff ################

use strict;
use warnings;

# Dagboek type 1: Inkoop
# Dagboek type 2: Verkoop

use EB;
use EB::Format;
use EB::Report::Journal;
use base qw(EB::Booking);

my $trace_updates = $cfg->val(__PACKAGE__, "trace_updates", 0);	# for debugging

sub perform {
    my ($self, $args, $opts) = @_;

    return unless $self->adm_open;

    my $dagboek = $opts->{dagboek};
    my $dagboek_type = $opts->{dagboek_type};
    my $bsk_ref = $opts->{ref};
    my $bsk_att = $opts->{bijlage};

    if ( defined $bsk_att ) {
	return unless $self->check_attachment($bsk_att);
    }

    unless ( $dagboek_type == DBKTYPE_INKOOP || $dagboek_type == DBKTYPE_VERKOOP) {
	warn("?".__x("Ongeldige operatie (IV) voor dagboek type {type}",
		     type => $dagboek_type)."\n");
	return;
    }

    my $iv = $dagboek_type == DBKTYPE_INKOOP;
    my $totaal = $opts->{totaal};
    my $does_btw = $dbh->does_btw;

    my $bky = $self->{bky} ||= $opts->{boekjaar} || $dbh->adm("bky");

    if ( defined($totaal) ) {
	my $t = amount($totaal);
	return "?".__x("Ongeldig totaal: {total}", total => $totaal)
	  unless defined $t;
	$totaal = $t;
    }

    my ($begin, $end);
    return unless ($begin, $end) = $self->begindate;

    my $date;
    if ( $date = parse_date($args->[0], substr($begin, 0, 4)) ) {
	shift(@$args);
    }
    else {
	return "?".__x("Onherkenbare datum: {date}",
		       date => $args->[0])."\n"
	  if ($args->[0]||"") =~ /^[[:digit:]]+-/;
	$date = iso8601date();
    }

    return "?"._T("Deze opdracht is onvolledig. Gebruik de \"help\" opdracht voor meer aanwijzingen.")."\n"
      unless @$args >= 3;

    return unless $self->in_bky($date, $begin, $end);

    if ( $does_btw && $dbh->adm("btwbegin") && $date lt $dbh->adm("btwbegin") ) {
	warn("?"._T("De boekingsdatum valt in de periode waarover al BTW aangifte is gedaan")."\n");
	return;
    }

    my $gdesc = "";
    my $debcode;
    my $rr;

    if ( $cfg->val(qw(general ivdesc), undef) ) {
	$gdesc  = shift(@$args);
	my $arg = shift(@$args);
	( $debcode, $bsk_ref ) = relref($arg, $bsk_ref);
	if ( defined $bsk_ref && $bsk_ref =~ /^\d+$/ ) {
	    warn("?".__x("Boekingsreferentie moet tenminste één niet-numeriek teken bevatten: {ref}", ref => $bsk_ref)."\n");
	    return;
	}

	$rr = $dbh->do("SELECT rel_code, rel_acc_id, rel_btw_status FROM Relaties" .
		       " WHERE UPPER(rel_code) = ?" .
		       "  AND " . ($iv ? "NOT " : "") . "rel_debcrd" .
		       "  AND rel_ledger = ?",
		       uc($debcode), $dagboek);
	unless ( defined($rr) ) {
	    unshift(@$args, $arg);
	    ( $debcode, $bsk_ref ) = relref($gdesc, $bsk_ref);
	    $gdesc = "";
	    $rr = $dbh->do("SELECT rel_code, rel_acc_id, rel_btw_status FROM Relaties" .
			   " WHERE UPPER(rel_code) = ?" .
			   "  AND " . ($iv ? "NOT " : "") . "rel_debcrd" .
			   "  AND rel_ledger = ?",
			   uc($debcode), $dagboek);
	    unless ( defined($rr) ) {
		warn("?".__x("Onbekende {what}: {who}",
			     what => lc($iv ? _T("Crediteur") : _T("Debiteur")),
			     who => $debcode)."\n");
		return;
	    }
	}
    }
    else {
	my $arg = shift(@$args);
	( $debcode, $bsk_ref ) = relref($arg, $bsk_ref);
	if ( defined $bsk_ref && $bsk_ref =~ /^\d+$/ ) {
	    warn("?".__x("Boekingsreferentie moet tenminste één niet-numeriek teken bevatten: {ref}", ref => $bsk_ref)."\n");
	    return;
	}

	$rr = $dbh->do("SELECT rel_code, rel_acc_id, rel_btw_status FROM Relaties" .
		       " WHERE UPPER(rel_code) = ?" .
		       "  AND " . ($iv ? "NOT " : "") . "rel_debcrd" .
		       "  AND rel_ledger = ?",
		       uc($debcode), $dagboek);
	unless ( defined($rr) ) {
	    $gdesc = $arg;
	    ( $debcode, $bsk_ref ) = relref(shift(@$args), $bsk_ref);
	    $rr = $dbh->do("SELECT rel_code, rel_acc_id, rel_btw_status FROM Relaties" .
			   " WHERE UPPER(rel_code) = ?" .
			   "  AND " . ($iv ? "NOT " : "") . "rel_debcrd" .
			   "  AND rel_ledger = ?",
			   uc($debcode), $dagboek);
	    unless ( defined($rr) ) {
		warn("?".__x("Onbekende {what}: {who}",
			     what => lc($iv ? _T("Crediteur") : _T("Debiteur")),
			     who => $debcode)."\n");
		return;
	    }
	}
    }

    my ($rel_acc_id, $rel_btw);
    ($debcode, $rel_acc_id, $rel_btw) = @$rr;

    my $btw_adapt = $cfg->val(qw(strategy btw_adapt), 0);
    my $nr = 1;
    my $bsk_id;
    my $bsk_nr;
    my $did = 0;

    while ( @$args ) {
	return "?"._T("Deze opdracht is onvolledig. Gebruik de \"help\" opdracht voor meer aanwijzingen.")."\n"
	  unless @$args >= 2;
	my ($desc, $amt, $acct) = splice(@$args, 0, 3);
	my $bsr_ref;
	$desc = $gdesc if $desc !~ /\S/;
	$gdesc = $desc if $gdesc !~ /\S/;
	$acct ||= $rel_acc_id;
	if ( $opts->{verbose} ) {
	    my $t = $desc;
	    $t = '"' . $desc . '"' if $t =~ /\s/;
	    warn(" "._T("boekstuk").": $t $amt $acct\n");
	}
	unless ( $desc =~ /\S/ ) {
	    warn("?"._T("De omschrijving van de boekstukregel ontbreekt")."\n");
	    return;
	}

	if  ( $acct !~ /^\d+$/ ) {
	    if ( $acct =~ /^(\d*)([cd])/i ) {
		warn("?"._T("De \"D\" of \"C\" toevoeging aan het rekeningnummer is hier niet toegestaan")."\n");
		return;
	    }
	    warn("?".__x("Ongeldig grootboekrekeningnummer: {acct}", acct => $acct )."\n");
	    return;
	}
	my $rr = $dbh->do("SELECT acc_desc,acc_balres,acc_kstomz,acc_debcrd,acc_btw".
			  " FROM Accounts".
			  " WHERE acc_id = ?", $acct);
	unless ( $rr ) {
	    warn("?".__x("Onbekende grootboekrekening: {acct}",
			 acct => $acct)."\n");
	    $dbh->rollback if $dbh->in_transaction;
	    return;
	}
	my ($adesc, $balres, $kstomz, $debcrd, $btw_id) = @$rr;
	if ( $balres ) {
	    warn("!".__x("Grootboekrekening {acct} ({desc}) is een balansrekening",
			 acct => $acct, desc => $adesc)."\n") if 0;
	    #$dbh->rollback;
	    #return;
	}
	if ( $btw_id && !$does_btw ) {
	    croak("INTERNAL ERROR: ".
		  __x("Grootboekrekening {acct} heeft BTW in een BTW-vrije administratie",
		      acct => $acct));
	}

	if ( $nr == 1 ) {
	    $bsk_nr = $self->bsk_nr($opts);
	    return unless defined($bsk_nr);
	    $bsk_id = $dbh->get_sequence("boekstukken_bsk_id_seq");
	    if ( $bsk_ref and $dbh->do("SELECT count(*)".
				       " FROM Boekstukken, Boekstukregels".
				       " WHERE bsk_id = bsr_bsk_id".
				       " AND upper(bsk_ref) = ?".
				       " AND upper(bsr_rel_code) = ?".
				       " AND bsk_bky = ?",
				       uc($bsk_ref), uc($debcode), $bky)->[0] ) {
		warn("?".__x("Referentie {ref} bestaat al voor relatie {rel}",
			     rel => $debcode, ref => $bsk_ref)."\n");
		return;
	    }


	    $dbh->begin_work;
	    $dbh->sql_insert("Boekstukken",
			     [qw(bsk_id bsk_nr bsk_ref bsk_desc bsk_dbk_id bsk_date bsk_bky)],
			     $bsk_id, $bsk_nr, $bsk_ref, $gdesc, $dagboek, $date, $bky);
	}

	# Amount can override BTW id with @X postfix.
	my ($namt, $btw_spec, $btw_explicit) =
	  $does_btw ? $self->amount_with_btw($amt, $btw_id) : amount($amt);
	unless ( defined($namt) ) {
	    warn("?".__x("Ongeldig bedrag: {amt}", amt => $amt)."\n");
	    return;
	}

	$amt = $iv ? $namt : -$namt;

	if ( $does_btw ) {
	    ($btw_id, $kstomz) = $self->parse_btw_spec($btw_spec, $btw_id, $kstomz);
	    unless ( defined($btw_id) ) {
		warn("?".__x("Ongeldige BTW-specificatie: {spec}", spec => $btw_spec)."\n");
		return;
	    }
	}

	# Bepalen van de BTW.
	# Voor neutrale boekingen (@N, of op een neutrale rekening) wordt geen BTW
	# toegepast. Op _alle_ andere wel. De BTW kan echter nul zijn, of void.
	# Het eerste wordt bewerkstelligd door $btw_id op 0 te zetten, het tweede
	# door $btw_acc geen waarde te geven.
	my $btwclass = 0;
	my $btw_acc;
	if ( defined($kstomz) ) {
	    # BTW toepassen.
	    if ( $kstomz ? !$iv : $iv ) {
		#warn("?".__x("U kunt geen {ko} boeken in een {iv} dagboek",
		warn("!".__x("Pas op! U boekt {ko} in een {iv} dagboek",
			     ko => $kstomz ? _T("kosten") : _T("omzet"),
			     iv => $iv ? _T("inkoop") : _T("verkoop"),
			    )."\n");
		#return;
	    }
	    # Void BTW voor non-EU en verlegd.
	    if ( $btw_id && ($rel_btw == BTWTYPE_NORMAAL || $rel_btw == BTWTYPE_INTRA) ) {

		my $res = $dbh->do( "SELECT btw_tariefgroep, btw_start, btw_end, btw_alias, btw_desc, btw_incl".
				    " FROM BTWTabel".
				    " WHERE btw_id = ?",
				    $btw_id );
		my $incl = $res->[5];

		if ( $incl && $rel_btw == BTWTYPE_INTRA ) {
		    if ( $btw_explicit ) {	# user specified -> warning
			warn("!".__x("BTW code {code} is inclusief BTW maar relatie {rel} is intra-communautair",
				     code => $btw_id, rel => $debcode)."\n" );
		    }
		    warn("!".__x("Er wordt geen BTW berekend voor intra-relatie {rel}",
				     rel => $debcode)."\n" );
		}

		my $tg;
		unless ( defined($res) && defined( $tg = $res->[0] ) ) {
		    warn("?".__x("Onbekende BTW-code: {code}", code => $btw_id)."\n");
		    return;
		}
		if ( defined( $res->[1] ) && $res->[1] gt $date ) {
		    my $ok = 0;
		    if ( $btw_adapt && !$btw_explicit ) {
			my $rr = $dbh->do( "SELECT btw_id, btw_desc".
					   " FROM BTWTabel".
					   " WHERE btw_tariefgroep = ?".
					   " AND btw_end >= ?".
					   " AND " . ( $incl ? "" : "NOT " ) . "btw_incl".
					   " ORDER BY btw_id",
					   $tg, $date );
			if ( $rr && $rr->[0] ) {
			    warn("%".__x("BTW-code: {code} aangepast naar {new} i.v.m. de boekingsdatum",
					 code => $res->[3]||$res->[4]||$btw_id,
					 new => $rr->[1]||$rr->[0],
					)."\n");
			    $btw_id = $rr->[0];
			    $ok++;
			}
		    }
		    unless ( $ok ) {
			warn("!".__x("BTW-code: {code} is nog niet geldig op de boekingsdatum",
				     code => $res->[3]||$res->[4]||$btw_id)."\n");
		    }
		}
		if ( defined( $res->[2] ) && $res->[2] lt $date ) {
		    my $ok = 0;
		    if ( $btw_adapt && !$btw_explicit ) {
			my $rr = $dbh->do( "SELECT btw_id, btw_desc".
					   " FROM BTWTabel".
					   " WHERE btw_tariefgroep = ?".
					   " AND btw_start <= ?".
					   " AND " . ( $incl ? "" : "NOT " ) . "btw_incl".
					   " ORDER BY btw_id",
					   $tg, $date );
			if ( $rr && $rr->[0] ) {
			    warn("%".__x("BTW-code: {code} aangepast naar {new} i.v.m. de boekingsdatum",
					 code => $res->[3]||$res->[4]||$btw_id,
					 new => $rr->[1]||$rr->[0],
					)."\n");
			    $btw_id = $rr->[0];
			    $ok++;
			}
		    }
		    unless ( $ok ) {
			warn("!".__x("BTW-code: {code} is niet meer geldig op de boekingsdatum",
				     code => $res->[3]||$res->[4]||$btw_id)."\n");
		    }
		}
		my $tp = BTWTARIEVEN->[$tg];
		my $t = qw(v i)[$iv] . lc(substr($tp, 0, 1));
		$btw_acc = $dbh->std_acc("btw_$t");
	    }
	}
	elsif ( $btw_id ) {
	    warn("?"._T("BTW toepassen is niet mogelijk op een neutrale rekening")."\n");
	    return;
	}
	# ASSERT: $btw_id != 0 implies defined($kstomz).

	$dbh->sql_insert("Boekstukregels",
			 [qw(bsr_nr bsr_date bsr_bsk_id bsr_desc bsr_amount
			     bsr_btw_id bsr_btw_acc bsr_btw_class bsr_type bsr_acc_id
			     bsr_rel_code bsr_dbk_id bsr_ref)],
			 $nr++, $date, $bsk_id, $desc, $amt,
			 $btw_id, $btw_acc,
			 BTWKLASSE($does_btw ? defined($kstomz) : 0, $rel_btw, defined($kstomz) ? $kstomz : $iv),
			 0, $acct, $debcode, $dagboek, $bsr_ref);
    }

    my $ret = $self->journalise($bsk_id, $iv, $totaal);
#    $rr = [ @$ret ];
#    shift(@$rr);
#    $rr = [ sort { $a->[5] <=> $b->[5] } @$rr ];
#    foreach my $r ( @$rr ) {
#	my (undef, undef, undef, undef, $nr, $ac, $amt) = @$r;
#	next unless $nr;
#	warn("update $ac with ".numfmt($amt)."\n") if $trace_updates;
#	$dbh->upd_account($ac, $amt);
#    }
    my $tot = $ret->[$#{$ret}]->[8]; # ERROR PRONE
    $dbh->sql_exec("UPDATE Boekstukken SET bsk_amount = ?, bsk_open = ? WHERE bsk_id = ?",
		   $tot, $tot, $bsk_id)->finish;

    $dbh->store_journal($ret);

    $tot = -$tot if $iv;
    my $fail = defined($totaal) && $tot != $totaal;
    if ( $opts->{journal} ) {
	warn("?"._T("Dit overzicht is ter referentie, de boeking is niet uitgevoerd!")."\n") if $fail;
	EB::Report::Journal->new->journal
	    ({select => $bsk_id,
	      d_boekjaar => $bky,
	      detail => 1});
    }

    if ( $fail ) {
	$dbh->rollback;
	return "?".__x("Boeking {bk} is niet uitgevoerd!",
		       bk => join(":", $dbh->lookup($dagboek, qw(Dagboeken dbk_id dbk_desc)), $bsk_nr))." ".
	  __x(" Boekstuk totaal is {act} in plaats van {exp}",
	      act => numfmt($tot), exp => numfmt($totaal)) . ".";
    }

    $self->add_attachment( $bsk_att, $bsk_id ) if $bsk_att;
    $dbh->commit;

    # TODO -- need this to get a current booking.
    $opts->{verbose} || 1
      ? join(":", $dbh->lookup($dagboek, qw(Dagboeken dbk_id dbk_desc)), $bsk_nr)
	: "";
}

sub relref {
    my ( $rel, $ref ) = @_;
    return ( $rel, $ref ) if defined $ref;
    if ( $rel =~ /^(.+):(.+)/ ) {
	( $rel, $ref ) = ( $1, $2 );
    }
    return ( $rel, $ref );
}

1;