eekboek 2.00.03-1 / usr / share / perl5 / EB / Booking / Decode.pm

#! perl

package main;

our $dbh;
our $config;

package EB::Booking::Decode;

# RCS Id          : $Id: Decode.pm,v 1.25 2008/02/07 12:12:39 jv Exp $
# Author          : Johan Vromans
# Created On      : Tue Sep 20 15:16:31 2005
# Last Modified By: Johan Vromans
# Last Modified On: Thu Feb  7 13:12:37 2008
# Update Count    : 172
# Status          : Unknown, Use with caution!

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

use strict;
use warnings;

our $VERSION = sprintf "%d.%03d", q$Revision: 1.25 $ =~ /(\d+)/g;

use EB;
use EB::Format;
use EB::Booking;		# for norm_btw()

sub new {
    return bless {};
}

my @bsr_types =
  ([],
   [ "Standaard", ("") x 8, "Open post vorige periode" ],
   [ "Standaard", ("") x 8, "Open post vorige periode" ],
   [ "Standaard", "Betaling van debiteur", "Betaling aan crediteur" ],
   [ "Standaard", "Betaling van debiteur", "Betaling aan crediteur" ],
   [ "Standaard", "Betaling van debiteur", "Betaling aan crediteur" ],
   [],
  );

sub decode {
    my ($self, $bsk, $opts) = @_;

    my $trail	   = $opts->{trail};
    my $single	   = $opts->{single};
    my $ex_btw	   = $opts->{btw};
    my $ex_bsknr   = $opts->{bsknr};
    my $ex_bky     = $opts->{bky};
    my $ex_debcrd  = $opts->{debcrd};
    my $ex_tot     = $opts->{totaal} || $opts->{total};
    my $no_ivbskdesc = $opts->{noivbskdesc};

    my $dbver = sprintf("%03d%03d%03d", $dbh->adm("scm_majversion"),
			$dbh->adm("scm_minversion")||0, $dbh->adm("scm_revision"));

    $bsk = $dbh->bskid($bsk);

    my $rr = $dbh->do("SELECT bsk_id, bsk_nr, bsk_ref, bsk_desc, ".
		      "bsk_dbk_id, bsk_date, bsk_amount, bsk_saldo, bsk_isaldo, bsk_bky ".
		      ($dbver lt "001000002" ? ", bsk_paid" : ", bsk_open").
		      " FROM Boekstukken".
		      " WHERE bsk_id = ?", $bsk);

    unless ( $rr ) {
	warn("?".__x("Onbekend boekstuk: {bsk}", bsk => $bsk)."\n");
	return;
    }

    my ($bsk_id, $bsk_nr, $bsk_ref, $bsk_desc, $bsk_dbk_id,
	$bsk_date, $bsk_amount, $bsk_saldo, $bsk_isaldo, $bsk_bky, $bsk_open) = @$rr;

    my $tot = 0;
    my ($dbktype, $acct, $dbk_desc) = @{$dbh->do("SELECT dbk_type, dbk_acc_id, dbk_desc".
						 " FROM Dagboeken".
						 " WHERE dbk_id = ?", $bsk_dbk_id)};
    my $cmd = "";

    my $setup = sub {
	my ($rel_code) = @_;
	if ( $trail ) {
	    $cmd = lc($dbk_desc);
	    $cmd =~ s/[^[:alnum:]]/_/g;
	    $cmd .= ":$bsk_bky" if $ex_bky;
	    $cmd .= ":$bsk_nr" if $ex_bsknr;
	    $cmd .= " --ref=" . _quote($bsk_ref) if defined $bsk_ref;
	    $cmd .= " ".datefmt_full($bsk_date)." ";
	    if ( $dbktype == DBKTYPE_INKOOP || $dbktype == DBKTYPE_VERKOOP ) {
		$cmd .= $no_ivbskdesc ? _quote($rel_code) : _quote($bsk_desc, $rel_code);
	    }
	    if ($dbktype == DBKTYPE_BANK || $dbktype == DBKTYPE_KAS || $dbktype == DBKTYPE_MEMORIAAL) {
		$cmd .= _quote($bsk_desc);
	    }
	    else {
		$cmd .= " --totaal=" . numfmt_plain($dbktype == DBKTYPE_INKOOP ? 0-$bsk_amount : $bsk_amount)
		  if $ex_tot && $acct;
	    }
	    $cmd .= " --beginsaldo=" . numfmt_plain($bsk_isaldo) if $ex_tot && defined $bsk_isaldo;
	    $cmd .= " --saldo=" . numfmt_plain($bsk_saldo) if $ex_tot && defined $bsk_saldo;
	}
	else {
	    $cmd = "Boekstuk $bsk_id, nr $bsk_nr, dagboek " .
	      $dbh->lookup($bsk_dbk_id, qw(Dagboeken dbk_id dbk_desc =)).
		"($bsk_dbk_id)".
		  ", ".datefmt_full(datum $bsk_date).
		    ", ";
	    if ( $dbktype == DBKTYPE_INKOOP || $dbktype == DBKTYPE_VERKOOP ) {
		my ($rd, $rt) = @{$dbh->do("SELECT rel_desc,rel_debcrd".
					   " FROM Relaties".
					   " WHERE rel_code = ?",
					   $rel_code)};
		$cmd .= $rt ? "deb " : "crd ";
		$cmd .= "$rel_code ($rd), ";
	    }
	    $cmd .= _quote($bsk_desc);
	    if ( $dbver lt "001000002" ) {
		$cmd .= $bsk_open ? ", *$bsk_open" : ", open"
	    }
	    elsif ( defined $bsk_open ) {
		$cmd .= $bsk_open ? ", @{[numfmt_plain(abs($bsk_open))]} open" : ", voldaan"
	    }
	    $cmd .= "\n";
	}
    };

    my $sth = $dbh->sql_exec("SELECT bsr_nr, bsr_date, ".
			     "bsr_desc, bsr_amount, bsr_btw_id, bsr_btw_class, ".
			     "bsr_type, bsr_acc_id, bsr_rel_code, bsr_paid ".
			     " FROM Boekstukregels".
			     " WHERE bsr_bsk_id = ?".
			     " ORDER BY bsr_nr", $bsk);

    $rr = $sth->fetchrow_arrayref;
    unless ( $rr ) {
	# Special case for boekstuk zonder boekstukregels.
	$setup->(undef);
	return $cmd;
    }

    while ( $rr ) {
	my ($bsr_nr, $bsr_date, $bsr_desc, $bsr_amount, $bsr_btw_id,
	    $bsr_btw_class, $bsr_type, $bsr_acc_id, $bsr_rel_code, $bsr_paid) = @$rr;
	if ( $bsr_nr == 1) {
	    $setup->($bsr_rel_code);
	}

	my ($rd, $rt, $acc_balres, $acc_kstomz) = $bsr_acc_id ?
	  @{$dbh->do("SELECT acc_desc,acc_debcrd,acc_balres,acc_kstomz".
		       " FROM Accounts".
		       " WHERE acc_id = ?",
		       $bsr_acc_id)}
	    : ("[Open posten vorige periode]", 1);

	my $dc = $bsr_amount >= 0 ? "debet" : "credit";
	$dc = uc($dc) unless (($bsr_amount < 0) xor $rt);
	$cmd .= join("",
		     " Boekstukregel, nr $bsr_nr, datum $bsr_date, ",
		     _quote($bsr_desc),
		     ", type $bsr_type (", $bsr_types[$dbktype][$bsr_type], ")\n",
		     "  ",
		     "bedrag ", numfmt_plain(abs($bsr_amount)), " ", $dc,
		     defined($bsr_btw_id) ?
		     (", BTW code $bsr_btw_id (",
		      $dbh->lookup($bsr_btw_id, qw(BTWTabel btw_id btw_desc)),
		      ")") : (),
		     defined($bsr_acc_id) ? (", rek $bsr_acc_id (", $rt ? "D/" : "C/", $rd, ")",) : (),
		     "\n") unless $trail;

	croak("INTERNAL ERROR: BTW/N id = $bsr_btw_id")
	  if !($bsr_btw_class & BTWKLASSE_BTW_BIT) && $bsr_btw_id;

	my $a = EB::Booking::->norm_btw($bsr_amount, $bsr_btw_id);
	$tot += $a->[0];

	next unless $trail;

	$bsr_acc_id ||= "";
	my $btw = "";

	# Refactor later.
	if ( $bsr_btw_class & BTWKLASSE_BTW_BIT ) {
	    my $ko = $bsr_btw_class & BTWKLASSE_KO_BIT ? 1 : 0;
	    if ( $ex_btw ) {
		$btw = $bsr_btw_id . qw(O K)[$ko];
	    }
	    else {
		$btw .= $bsr_btw_id
		  if btw_code($bsr_acc_id) != $bsr_btw_id
		    || ($bsr_type == 0 && $dbktype == DBKTYPE_MEMORIAAL);
		$btw .= qw(O K)[$ko]
		  if (!defined($acc_kstomz) || ($acc_kstomz xor $ko));
	    }
	}
	elsif ( $dbh->does_btw ) {
	    if ( $ex_btw ) {
		$btw = 'N';
	    }
	    else {
		$btw = 'N'
		  if defined($acc_kstomz);
	    }
	}

	$btw = '@' . $btw unless $btw eq "";

	if ( $dbktype == DBKTYPE_INKOOP || $dbktype == DBKTYPE_VERKOOP ) {
	    $bsr_amount = -$bsr_amount if $dbktype == DBKTYPE_VERKOOP;
	    $cmd .= $single ? " " : " \\\n\t";
	    $cmd .= _quote($bsr_desc) . " " .
	      numfmt_plain($bsr_amount) . $btw . " " .
		$bsr_acc_id;
	}
	elsif ( $dbktype == DBKTYPE_BANK || $dbktype == DBKTYPE_KAS
		|| $dbktype == DBKTYPE_MEMORIAAL ) {
	    $bsr_amount = -$bsr_amount;
	    my $dd = "";
	    $dd = " ".datefmt_full($bsr_date) unless $bsr_date eq $bsk_date;
	    if ( $bsr_type == 0 ) {
		$cmd .= $single ? " " : " \\\n\t";
		$cmd .= "std$dd " . _quote($bsr_desc) . " " .
		  numfmt_plain($bsr_amount) . $btw . " " .
		    $bsr_acc_id;
	    }
	    elsif ( $bsr_type == 1 || $bsr_type == 2 ) {
		my $type = $bsr_type == 1 ? "deb" : "crd";
		$cmd .= $single ? " " : " \\\n\t";

		# Check for a full payment.
		my $sth = $dbh->sql_exec("SELECT bsk_amount, dbk_desc, bsk_nr, bsk_ref, bsr_rel_code, bsk_bky".
					 " FROM Boekstukken, Boekstukregels, Dagboeken".
					 " WHERE bsk_dbk_id = dbk_id".
					 " AND bsr_bsk_id = bsk_id".
					 " AND bsk_id = ?", $bsr_paid);
		my ($paid, $dbk, $nr, $ref, $rel, $bky) = @{$sth->fetchrow_arrayref};
		$sth->finish;
		if ( $paid == $bsr_amount ) {
		    # Matches -> Full payment
		    $cmd .= "$type$dd " . _quote($bsr_rel_code) . " " .
		      numfmt_plain($bsr_amount);
		}
		else {
		    # Partial payment. Use boekstuknummer.
		    $dbk = lc($dbk);
		    $dbk =~ s/[^[:alnum:]]/_/g;
		    my $t;
		    if ( defined $ref ) {
			$t = $rel;
			$t .= ":$bky" if ($opts->{boekjaar}||$opts->{d_boekjaar}) ne $bky;
			$t .= ":$ref";
		    }
		    else {
			$t = $dbk;
			$t .= ":$bky" if ($opts->{boekjaar}||$opts->{d_boekjaar}) ne $bky;
			$t .= ":$nr";
		    }
		    $cmd .= join(" ", $type.$dd, _quote($t), numfmt_plain($bsr_amount));
		}
	    }
	}
	$rr = $sth->fetchrow_arrayref;
    }
    return ($cmd, $tot, $bsk_amount, $acct)
      if wantarray;
    $cmd;
}

################ Subroutines ################

# Escape " quotes and \ so lines can be read in by parsewords. Note
# that multiple arguments will be concatenated quoted, not quoted
# concatenated.
sub _quote {
    my @res;
    foreach my $t ( @_ ) {
	$t =~ s/(["\\])/\\$1/g;
	push(@res, "\"$t\"");
    }
    "@res";
}

my %btw_code;
sub btw_code {
    my($acct) = @_;
    return $btw_code{$acct} if defined $btw_code{$acct};
    _lku($acct);
    $btw_code{$acct};
}

sub _lku {
    my ($acct) = @_;
    Carp::confess("acct is null") unless $acct;
    my $rr = $dbh->do("SELECT acc_btw".
		      " FROM Accounts".
		      " WHERE acc_id = ?", $acct);
    die("?".__x("Onbekend rekeningnummer: {acct}", acct => $acct)."\n")
      unless $rr;
    $btw_code{$acct} = $rr->[0];
}

1;