This file is indexed.

/usr/share/perl5/EB/Relation.pm is in eekboek 2.02.05+dfsg-2.

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
146
147
148
149
150
151
152
153
154
155
#! perl

# Relation.pm -- 
# Author          : Johan Vromans
# Created On      : Thu Jul 14 12:54:08 2005
# Last Modified By: Johan Vromans
# Last Modified On: Thu Jan 26 11:04:05 2012
# Update Count    : 118
# Status          : Unknown, Use with caution!

package main;

our $dbh;

package EB::Relation;

use strict;
use warnings;

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) {
	warn("!"._T("Waarschuwing: De toevoeging 'D' of 'C' aan het grootboeknummer wordt afgeraden! Gebruik de --dagboek optie indien nodig.")."\n");
	$acct = $1;
	$dbcd = uc($2) eq 'D' ? 0 : 1; # 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 : 0+!!$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
      ? __x("Debiteur {code} -> {acct} ({desc}), dagboek {dbk}",
	    code => $code, acct => $acct, desc => $adesc, dbk => $ddesc)
      : __x("Crediteur {code} -> {acct} ({desc}), dagboek {dbk}",
	    code => $code, acct => $acct, desc => $adesc, dbk => $ddesc);
}

1;