File Coverage

blib/lib/EB/Booking.pm

Criterion	Covered	Total	%
statement	18	203	8.8
branch	0	126	0.0
condition	0	48	0.0
subroutine	6	20	30.0
pod	0	14	0.0
total	24	411	5.8

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

use utf8;

# Booking.pm -- Base class for Bookings.
# Author          : Johan Vromans
# Created On      : Sat Oct 15 23:36:51 2005
# Last Modified By: Johan Vromans
# Last Modified On: Thu Jan 26 16:39:38 2017
# Update Count    : 226
# Status          : Unknown, Use with caution!

package main;

our $cfg;
our $dbh;

package EB::Booking;

use strict;
use warnings;

use EB;
use EB::Format;
use EB::Tools::Attachments;

sub new {
    my ($class) = @_;
    $class = ref($class) || $class;
    return bless {} => $class;
}

sub adm_open {
    my ($self) = @_;
    unless ( $dbh->adm_open ) {
	warn("?"._T("De administratie is nog niet geopend")."\n");
	return;
    }
    1;
}

sub check_bsk_nr {
    my ($self, $opts) = @_;
    my $bsk_nr = $opts->{boekstuk};
    my $bky = $opts->{boekjaar};
    $bky = $dbh->adm("bky") unless defined($bky);
    my $dbk = $opts->{dagboek};
    my $rr = $dbh->do("SELECT count(*) FROM Boekstukken".
		      " WHERE bsk_nr = ? AND bsk_dbk_id = ? AND bsk_bky = ?",
		      $bsk_nr, $dbk, $bky);
    return 1 if defined($rr) && $rr->[0] == 0;
    warn("?".__x("Boekstuk {bsk} is reeds in gebruik",
		 bsk => join(":",
			     $dbh->lookup($dbk, qw(Dagboeken dbk_id dbk_desc)),
			     $bsk_nr))."\n");
    return;
}

sub bsk_nr {
    my ($self, $opts) = @_;
    my $bsk_nr;
    my $prev = defined($opts->{boekjaar}) && $opts->{boekjaar} ne $dbh->adm("bky");
    $bsk_nr = $opts->{boekstuk};
    if ( defined $bsk_nr ) {
	unless ( $bsk_nr =~ /^[0-9]+$/ ) {
	    warn("?"._T("Het boekstuknummer moet een geheel getal (volgnummer) zijn")."\n");
	    return;
	}
	return unless $self->check_bsk_nr($opts);
	my $t = $prev ? "0" : $opts->{dagboek};
	$dbh->set_sequence("bsk_nr_${t}_seq", $bsk_nr+1)
#	  if $dbh->get_sequence("bsk_nr_${t}_seq", "noincr") < $bsk_nr;
    }
    elsif ( $prev ) {
	warn("?"._T("Boekstukken in voorafgaande boekjaren moeten verplicht worden voorzien van een boekstuknummer")."\n");
	return;
	#$bsk_nr = $dbh->get_sequence("bsk_nr_0_seq");
    }
    else {
	$bsk_nr = $dbh->get_sequence("bsk_nr_".$opts->{dagboek}."_seq");
	$opts->{boekstuk} = $bsk_nr;
	return unless $self->check_bsk_nr($opts);
    }
    $bsk_nr;
}

sub begindate {
    my ($self) = @_;

    my $begin;
    my $end;
    if ( $self->{bky} ne $dbh->adm("bky") ) {
	my ($b, $e, $c) = @{$dbh->do("SELECT bky_begin, bky_end, bky_closed".
				     " FROM Boekjaren".
				     " WHERE bky_code = ?", $self->{bky})};
	if ( $c ) {
	    warn("?".__x("Boekjaar {code} is gesloten, er kan niet meer in worden gewijzigd",
		       code => $self->{bky})."\n");
	    return;
	}
	$begin = $b;
	$end = $e;
    }
    elsif ( $dbh->adm("closed") ) {
	warn("?"._T("De administratie is gesloten en kan niet meer worden gewijzigd")."\n");
	return;
    }
    $begin ||= $dbh->adm("begin");
    return $begin unless wantarray;
    $end ||= $dbh->adm("end");
    ($begin, $end);
}

sub in_bky {
    my ($self, $date, $begin, $end) = @_;
    if ( $date lt $begin ) {
	warn("?".__x("De boekingsdatum {date} valt vóór aanvang van dit boekjaar",
		     date => datefmt_full($date))."\n");
	return;
    }
    if ( $date gt $end ) {
	warn("?".__x("De boekingsdatum {date} valt na het einde van dit boekjaar",
		     date => datefmt_full($date))."\n");
	return;
    }
    1;
}

sub amount_with_btw {
    my ($self, $amt, $btw_spec) = @_;
    my $explicit;
    if ( $amt =~ /^(.+)\@(.+)$/ ) {
	$amt = $1;
	$btw_spec = $2;
	$explicit = $btw_spec !~ /^[hlgn]?[-+]?[ko]?$/i;
    }
    return (amount($amt), $btw_spec, $explicit);
}

sub parse_btw_spec {
    my ($self, $spec, $btw_id, $kstomz) = @_;
    return (0, undef) unless defined($spec);
    $spec = lc($spec);

    # Quickie for G/N.
    if ( $spec =~ /^([gn])$/ ) {
	return (0, undef);
    }
    # Quickie for K/O.
    elsif ( $spec =~ /^([ko])$/ ) {
	return ($btw_id, $1 eq 'k');
    }
    # Strip off trailing K|O.
    elsif ( $spec =~ /^([hl]|\d+)([-+]?)([ko])$/ || $spec =~ /^(\w+)([-+])([ko])$/ ) {
	$kstomz = $3 eq 'k';
	$spec = $1.$2;
    }

=begin deprecated

    # Deprecated since several years...
    elseif ( $spec =~ /^(.*)([iv])(.*)$/ ) {
	$kstomz = $2 eq 'i';
	$spec = $1.$3;
	warn("!".__x("BTW specificatie {spec}: Gebruik K of O in plaats van I of V",
		     spec => $_[0])."\n");
    }

=cut

    # Examine rest. Numeric -> BTW id.
    if ( $spec =~ /^(\d+)([-+])?$/ ) {
	$btw_id = $1;
	if ( defined $2 ) {
	    my $excl = $2 eq '-';
	    my $res = $dbh->do("SELECT btw_perc, btw_tariefgroep FROM BTWTabel".
			       " WHERE btw_id = ?",
			       $btw_id);
	    return unless $res;
	    $res = $dbh->do("SELECT btw_id FROM BTWTabel".
			    " WHERE btw_perc = ? AND btw_tariefgroep = ?".
			    "  AND ".($excl?"NOT ":"")."btw_incl",
			    $res->[0], $res->[1]);
	    return unless $res;
	    $btw_id = $res->[0];
	}
    }
    # H L H- L- H+ L+
    elsif ( $spec =~ /^([hl])([-+])?$/ ) {
	$btw_id = $1;
	my $excl;
	$excl = $2 eq '-' if defined $2;
	my $res = $dbh->da("SELECT btw_id, btw_alias, btw_desc FROM BTWTabel".
			   " WHERE btw_tariefgroep = ?".
			   " AND ".($excl?"NOT ":"")."btw_incl".
			   " ORDER BY btw_id ASC",
			   $btw_id eq "h" ? BTWTARIEF_HOOG : BTWTARIEF_LAAG);
	warn("!".__x("BTW aanduiding \"{spec}\" kent meerdere tariefcodes: {list} (code {code} \"{desc}\" is gebruikt)",
		     spec => $spec,
		     list => join(" ", map { defined($_->[1]) ? $_->[1] : $_->[0] } @$res),
		     code => $res->[0]->[0],
		     desc => $res->[0]->[2],
		    )."\n") if @$res != 1;
	$btw_id = $res->[0]->[0];
    }
    # alias
    elsif ( $spec =~ /^(\w\w+)([-+])?$/ ) {
	# warn("SPEC: $spec\n"); $dbh->trace(1);
	my $res = $dbh->do("SELECT btw_id, btw_perc, btw_tariefgroep FROM BTWTabel".
			   " WHERE btw_alias = ?",
			   lc $1);
	# $dbh->trace(0);
	return unless $res;

	$btw_id = $res->[0];
	if ( defined $2 ) {
	    my $excl = $2 eq '-';
	    # $dbh->trace(1);
	    $res = $dbh->do("SELECT btw_id FROM BTWTabel".
			    " WHERE btw_perc = ? AND btw_tariefgroep = ?".
			    "  AND ".($excl?"NOT ":"")."btw_incl",
			    $res->[1], $res->[2]);
	    # $dbh->trace(0);
	    return unless $res;
	    $btw_id = $res->[0];
	}
	# warn("SPEC: $spec => $btw_id\n");
    }
    # + -
    elsif ( $spec =~ /^([-+])$/ && $btw_id ) {
	my $res = $dbh->da("SELECT btw_id, btw_desc FROM BTWTabel".
			   " WHERE btw_tariefgroep =".
			   " ( SELECT btw_tariefgroep FROM BTWTabel".
			   " WHERE btw_id = ? )".
			   " AND ".($1 eq '-'?"NOT ":"")."btw_incl",
			   $btw_id);
	warn("!".__x("BTW aanduiding \"{spec}\" kent meerdere tariefcodes: {list} (code {code} \"{desc}\" is gebruikt)",
		     spec => $spec,
		     list => join(" ", map { $_->[0] } @$res),
		     code => $res->[0]->[0],
		     desc => $res->[0]->[1],
		    )."\n") if @$res != 1;
	$btw_id = $res->[0]->[0];
    }
    elsif ( $spec ne '' ) {
	return;
    }
    ($btw_id, $kstomz);
}

#### Class method
sub norm_btw {
    my ($self, $bsr_amt, $bsr_btw_id) = @_;
    my ($btw_perc, $btw_incl);
    if ( $bsr_btw_id ) {
	my $rr = $dbh->do("SELECT btw_perc, btw_incl, btw_tariefgroep".
			  " FROM BTWTabel".
			  " WHERE btw_id = ?", $bsr_btw_id);
	confess( "Unknown BTW: $bsr_btw_id" ) unless $rr;
	($btw_perc, $btw_incl) = @$rr;
    }

    return [ $bsr_amt, 0 ] unless $btw_perc;

    my $bruto = $bsr_amt;
    my $netto = $bsr_amt;

    if ( $btw_incl ) {
	$netto = numround($bruto * (1 / (1 + $btw_perc/BTWSCALE)));
    }
    else {
	$bruto = numround($netto * (1 + $btw_perc/BTWSCALE));
    }

    [ $bruto, $bruto - $netto, $btw_perc ];
}

#### Class method
sub dcfromtd {
    # Calculate a (debet,credit) pair from a (total,debet) pair.
    my ($total, $debet) = @_;
    return ($debet, $debet-$total) if defined($debet);
    return ($total, 0) if $total >= 0;
    (0, -$total);
}

#### Class method
sub journalise {
    my ($self, $bsk_id, $iv, $total) = @_;
    $total = -$total if defined($total) && !$iv;

    # date  bsk_id  bsr_seq(0)   dbk_id  (acc_id) amount debcrd desc(bsk) (rel)
    # date (bsk_id) bsr_seq(>0) (dbk_id)  acc_id  amount debcrd desc(bsr) rel(acc=1200/1600)
    my ($jnl_date, $jnl_bsk_id, $jnl_dbk_id, $jnl_acc_id,
	$jnl_amount, $jnl_desc, $jnl_rel);

    my $rr = $::dbh->do("SELECT bsk_nr, bsk_desc, bsk_dbk_id, bsk_date, bsk_ref".
		      " FROM Boekstukken".
		      " WHERE bsk_id = ?", $bsk_id);
    my ($bsk_nr, $bsk_desc, $bsk_dbk_id, $bsk_date, $bsk_ref) = @$rr;

    my ($dbktype, $dbkdcsplit, $dbk_acc_id) =
      @{$::dbh->do("SELECT dbk_type, dbk_dcsplit, dbk_acc_id".
		 " FROM Dagboeken".
		 " WHERE dbk_id = ?", $bsk_dbk_id)};
    my $sth = $::dbh->sql_exec("SELECT bsr_nr, bsr_date, ".
			     "bsr_desc, bsr_amount, bsr_btw_class, bsr_btw_id, ".
			     "bsr_btw_acc, bsr_type, bsr_acc_id, bsr_rel_code, bsr_dbk_id".
			     " FROM Boekstukregels".
			     " WHERE bsr_bsk_id = ?", $bsk_id);

    my $ret = [];
    my $tot = 0;
    my ($dtot, $ctot) = (0, 0);
    my ($vhtot, $vltot) = (0, 0);
    my $nr = 1;
    my $vat; 			# for automatic rounding VAT calc
    my $g_bsr_rel_code;

    while ( $rr = $sth->fetchrow_arrayref ) {
	my ($bsr_nr, $bsr_date, $bsr_desc, $bsr_amount, $bsr_btw_class,
	    $bsr_btw_id, $bsr_btw_acc, $bsr_type, $bsr_acc_id, $bsr_rel_code,
	    $bsr_rel_dbk) = @$rr;
	my $bsr_bsk_id = $bsk_id;
	my $btw = 0;
	my $amt = $bsr_amount;
	my $btw_intra = ($bsr_btw_class & BTWKLASSE_TYPE_BITS) == BTWTYPE_INTRA;
	$g_bsr_rel_code = $bsr_rel_code if defined $iv && $bsr_rel_code;

	if ( ($bsr_btw_class & BTWKLASSE_BTW_BIT) && $bsr_btw_id && $bsr_btw_acc && !$btw_intra ) {
	    ( $bsr_amount, $btw, my $perc ) =
	      @{$self->norm_btw($bsr_amount, $bsr_btw_id)};
	    $amt = $bsr_amount - $btw;
	    $vat->{$bsr_btw_acc}->{amt} += $amt;
	    $vat->{$bsr_btw_acc}->{btw} += $btw;
	    $vat->{$bsr_btw_acc}->{prc} = $perc;
	}
	$tot += $bsr_amount;
	$dtot += $bsr_amount if $bsr_amount < 0;
	$ctot += $bsr_amount if $bsr_amount > 0;
	my $btwtag = _T("BTW ");
	push(@$ret, [$bsk_date, $bsk_dbk_id, $bsk_id, $bsr_date, $bsr_nr, $nr++,
		     0, $bsr_acc_id,
		     $bsr_amount - $btw, undef, $bsr_desc,
		     $bsr_type ? ($bsr_rel_code, $bsr_rel_dbk) : (undef, undef), undef]);
	push(@$ret, [$bsk_date,  $bsk_dbk_id, $bsk_id, $bsr_date, $bsr_nr, $nr++,
		     1, $bsr_btw_acc,
		     $btw, undef, $btwtag.$bsr_desc,
		     undef, undef, undef]) if $btw;
    }

    if ( defined($total) && $tot != $total
	 && $cfg->val(qw(strategy iv_vc), 1)
       ) { # mismatch!
	#warn("=> $tot <-> $total\n");
	# Vaak het gevolg van verschil in BTW berekening per
	# boekingsregel versus per boekstuktotaal.

	while ( my($k,$v) = each(%$vat) ) {
	    # Bereken BTW over totaal van deze tariefgroep.
	    my $t = numround($v->{amt} * ($v->{prc}/BTWSCALE));
	    if ( $t != $v->{btw} ) { # Aha!
		#warn("=> [$k] $v->{btw} <-> $t\n");
		# Corrigeer het totaal, en maak een correctieboekstukregel.
		$tot -= $v->{btw} - $t;
		push(@$ret, [$bsk_date,  $bsk_dbk_id, $bsk_id, $bsk_date, undef, $nr++,
			     1, $k,
			     $t - $v->{btw}, undef, _T("BTW Afr. ").$bsk_desc,
			     undef, undef, undef]);
		warn("!".__x("BTW rek. nr. {acct}, correctie van {amt} uitgevoerd",
			     acct => $k, amt => numfmt($t-$v->{btw}))."\n");
	    }
	}
    }

    if ( $dbk_acc_id ) {
	if ( $dbkdcsplit ) {
	    push(@$ret, [$bsk_date,  $bsk_dbk_id, $bsk_id, $bsk_date, undef, $nr++,
			 0, $dbk_acc_id,
			 -$tot, -$dtot, $bsk_desc, undef, undef, undef]);
	}
	else {
	    push(@$ret, [$bsk_date,  $bsk_dbk_id, $bsk_id, $bsk_date, undef, $nr++,
			 0, $dbk_acc_id,
			 -$tot, undef, $bsk_desc, undef, undef, undef]);
	}
    }

    unshift(@$ret, [$bsk_date, $bsk_dbk_id, $bsk_id, $bsk_date, undef, 0, 0, undef,
		    undef, undef, $bsk_desc, $g_bsr_rel_code, undef, $bsk_ref]);

    $ret;
}

sub check_attachment {
    my ( $self, $att ) = @_;
    return 1 unless defined $att;

    return 1 if $att =~ m;^(\w+)://(.+);; # URI

    if ( ! ( -f $att && -r _ ) ) {
	warn("?".__x("Boekingsbijlage kan niet worden gevonden: {att}",
		     att => $att)."\n");
	return;
    }

    return 1;
}

sub add_attachment {
    my ( $self, $att, $bsk_id ) = @_;
    return unless defined $att;
    my $att_id;

    if ( $att =~ m;^(\w+)://(.+); ) { # URI
	if ( $1 eq "int" && $2 =~ m;^(\d+)/.+; ) {
	    $att_id = $1;
	}
	else {
	    $att_id = EB::Tools::Attachments->new->store_from_uri($att);
	}
    }
    else {
	# We may at some point in time decide to turn $file into
	# file://$url and treat as such.
	$att_id = EB::Tools::Attachments->new->store_from_file($att);
    }
    $dbh->sql_exec("UPDATE Boekstukken SET bsk_att = ? WHERE bsk_id = ?",
		   $att_id, $bsk_id);
}

sub find_attachment {
    my ( $self, $bsk_id ) = @_;
    $dbh->lookup( $bsk_id, qw(Boekstukken bsk_id bsk_att =) );
}

1;