/usr/share/perl5/EB/Relation.pm is in eekboek 2.00.03-1.
This file is owned by root:root, with mode 0o644.
The actual contents of the file can be viewed below.
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 | #! perl
package main;
our $dbh;
package EB::Relation;
use strict;
use warnings;
our $VERSION = sprintf "%d.%03d", q$Revision: 1.19 $ =~ /(\d+)/g;
use EB;
sub new {
my $class = shift;
$class = ref($class) || $class;
my $self = {};
bless $self => $class;
$self->add(@_) if @_;
$self;
}
sub add {
my ($self, $code, $desc, $acct, $opts) = @_;
my $bstate = $opts->{btw};
my $dbk = $opts->{dagboek};
if ( defined($bstate) ) {
$bstate = lc($bstate);
if ( $bstate =~ /^\d+$/ && $bstate >= 0 && $bstate < @{&BTWTYPES} ) {
# Ok.
}
elsif ( $bstate eq lc(BTWTYPES->[BTWTYPE_NORMAAL]) ) { $bstate = BTWTYPE_NORMAAL }
elsif ( $bstate eq lc(BTWTYPES->[BTWTYPE_VERLEGD]) ) { $bstate = BTWTYPE_VERLEGD }
elsif ( $bstate eq lc(BTWTYPES->[BTWTYPE_INTRA] ) ) { $bstate = BTWTYPE_INTRA }
elsif ( $bstate eq lc(BTWTYPES->[BTWTYPE_EXTRA] ) ) { $bstate = BTWTYPE_EXTRA }
else {
warn("?".__x("Ongeldige waarde voor BTW status: {btw}", btw => $bstate)."\n");
return;
}
if ( $bstate == BTWTYPE_VERLEGD ) { #### TODO
warn("?"._T("Relaties met verlegde BTW worden nog niet ondersteund")."\n");
return;
}
if ( $bstate == BTWTYPE_INTRA ) { #### TODO
warn("!"._T("Relaties met intra-communautaire BTW worden nog niet volledig ondersteund")."\n");
}
}
my $debiteur;
my $ddesc;
if ( $dbk ) {
my $rr = $dbh->do("SELECT dbk_id, dbk_type, dbk_desc".
" FROM Dagboeken".
" WHERE dbk_desc ILIKE ?",
$dbk);
unless ( $rr ) {
warn("?".__x("Onbekend dagboek: {dbk}", dbk => $dbk)."\n");
return;
}
my ($id, $type, $desc) = @$rr;
if ( $type == DBKTYPE_INKOOP ) {
$debiteur = 0;
}
elsif ( $type == DBKTYPE_VERKOOP ) {
$debiteur = 1;
}
else {
warn("?".__x("Ongeldig dagboek voor relatie: {dbk}", dbk => $dbk)."\n");
return;
}
$dbk = $id;
$ddesc = $desc;
}
# Invoeren nieuwe relatie.
# Koppeling debiteur/crediteur op basis van debcrd van de
# bijbehorende grootboekrekening.
# Koppeling met dagboek op basis van het laagstgenummerde
# inkoop/verkoop dagboek (tenzij meegegeven).
my $dbcd = "acc_debcrd";
if ( $acct =~ /^(\d+)([DC]$)/i) {
$acct = $1;
$dbcd = uc($2) eq 'D' ? 1 : 0; # Note: D -> Crediteur
if ( defined($debiteur) && $dbcd == $debiteur ) {
warn("?".__x("Dagboek {dbk} implicieert {typ1} maar {acct} impliceert {typ2}",
dbk => $ddesc,
typ1 => lc($debiteur ? _T("Debiteur") : _T("Crediteur")),
acct => $acct.$2,
typ2 => lc($dbcd ? _T("Crediteur") : _T("Debiteur")))."\n");
return;
}
}
my $rr = $dbh->do("SELECT acc_desc,acc_balres,$dbcd".
" FROM Accounts".
" WHERE acc_id = ?", $acct);
unless ( $rr ) {
warn("?".__x("Onbekende grootboekrekening: {acct}", acct => $acct). "\n");
return;
}
my ($adesc, $balres, $debcrd) = @$rr;
if ( $balres ) {
warn("!".__x("Grootboekrekening {acct} ({desc}) is een balansrekening",
acct => $acct, desc => $adesc)."\n");
return;
}
$debcrd = defined($debiteur) ? $debiteur : 1 - $debcrd;
unless ( $dbk ) {
my $sth = $dbh->sql_exec("SELECT dbk_id, dbk_desc".
" FROM Dagboeken".
" WHERE dbk_type = ?".
" ORDER BY dbk_id",
$debcrd ? DBKTYPE_VERKOOP : DBKTYPE_INKOOP);
$rr = $sth->fetchrow_arrayref;
$sth->finish;
($dbk, $ddesc) = @$rr;
}
$rr = $dbh->do("SELECT COUNT(*)".
" FROM Relaties".
" WHERE upper(rel_code) = ? AND rel_ledger = ?",
uc($code), $dbk);
if ( $rr->[0]) {
warn("?".__x("Relatiecode {code} is niet uniek in dagboek {dbk}",
code => uc($code), dbk => $ddesc)."\n");
return;
}
$dbh->begin_work;
$dbh->sql_insert("Relaties",
[qw(rel_code rel_desc rel_debcrd rel_btw_status rel_ledger rel_acc_id)],
$code, $desc, $debcrd, $bstate || 0, $dbk, $acct);
$dbh->commit;
($debcrd ? _T("Debiteur") : _T("Crediteur")) . " " . $code .
" -> $acct ($adesc), dagboek $ddesc";
}
1;
|