kivitendo/SL/SEPA/XML.pm @ 77442185
| 1c603341 | Jan Büren | package SL::SEPA::XML;
|
||
use strict;
|
||||
use utf8;
|
||||
use Carp;
|
||||
use Encode;
|
||||
use List::Util qw(first sum);
|
||||
use List::MoreUtils qw(any);
|
||||
use POSIX qw(strftime);
|
||||
use XML::Writer;
|
||||
| cc042e07 | Sven Schöling | use SL::Iconv;
|
||
| 1c603341 | Jan Büren | use SL::SEPA::XML::Transaction;
|
||
sub new {
|
||||
my $class = shift;
|
||||
my $self = {};
|
||||
bless $self, $class;
|
||||
$self->_init(@_);
|
||||
return $self;
|
||||
}
|
||||
sub _init {
|
||||
my $self = shift;
|
||||
my %params = @_;
|
||||
$self->{transactions} = [];
|
||||
$self->{src_charset} = 'UTF-8';
|
||||
$self->{grouped} = 0;
|
||||
| c1716dbd | Moritz Bunkus | map { $self->{$_} = $params{$_} if (exists $params{$_}) } qw(src_charset company creditor_id message_id grouped collection);
|
||
| 1c603341 | Jan Büren | |||
| cc042e07 | Sven Schöling | $self->{iconv} = SL::Iconv->new($self->{src_charset}, "UTF-8") || croak "Unsupported source charset $self->{src_charset}.";
|
||
| 1c603341 | Jan Büren | |||
my $missing_parameter = first { !$self->{$_} } qw(company message_id);
|
||||
croak "Missing parameter: $missing_parameter" if ($missing_parameter);
|
||||
| c1716dbd | Moritz Bunkus | croak "Missing parameter: creditor_id" if !$self->{creditor_id} && $self->{collection};
|
||
| 1c603341 | Jan Büren | |||
| c1716dbd | Moritz Bunkus | map { $self->{$_} = $self->_replace_special_chars($self->{iconv}->convert($self->{$_})) } qw(company message_id creditor_id);
|
||
| 1c603341 | Jan Büren | }
|
||
sub add_transaction {
|
||||
my $self = shift;
|
||||
foreach my $transaction (@_) {
|
||||
croak "Expecting hash reference." if (ref $transaction ne 'HASH');
|
||||
push @{ $self->{transactions} }, SL::SEPA::XML::Transaction->new(%{ $transaction }, 'sepa' => $self);
|
||||
}
|
||||
return 1;
|
||||
}
|
||||
sub _replace_special_chars {
|
||||
my $self = shift;
|
||||
my $text = shift;
|
||||
my %special_chars = (
|
||||
'ä' => 'ae',
|
||||
'ö' => 'oe',
|
||||
'ü' => 'ue',
|
||||
'Ä' => 'Ae',
|
||||
'Ö' => 'Oe',
|
||||
'Ü' => 'Ue',
|
||||
'ß' => 'ss',
|
||||
'&' => '+',
|
||||
);
|
||||
map { $text =~ s/$_/$special_chars{$_}/g; } keys %special_chars;
|
||||
return $text;
|
||||
}
|
||||
sub _format_amount {
|
||||
my $self = shift;
|
||||
my $amount = shift;
|
||||
| c1716dbd | Moritz Bunkus | return sprintf '%.02f', $amount;
|
||
| 1c603341 | Jan Büren | }
|
||
sub _group_transactions {
|
||||
my $self = shift;
|
||||
my $grouped = {
|
||||
'sum_amount' => 0,
|
||||
'groups' => { },
|
||||
};
|
||||
foreach my $transaction (@{ $self->{transactions} }) {
|
||||
my $key = $self->{grouped} ? join("\t", map { $transaction->get($_) } qw(src_bic src_iban execution_date)) : 'all';
|
||||
$grouped->{groups}->{$key} ||= {
|
||||
'sum_amount' => 0,
|
||||
'transactions' => [ ],
|
||||
};
|
||||
push @{ $grouped->{groups}->{$key}->{transactions} }, $transaction;
|
||||
$grouped->{groups}->{$key}->{sum_amount} += $transaction->{amount};
|
||||
$grouped->{sum_amount} += $transaction->{amount};
|
||||
}
|
||||
return $grouped;
|
||||
}
|
||||
| 6a61183c | Moritz Bunkus | sub _restricted_identification_sepa1 {
|
||
my ($self, $string) = @_;
|
||||
$string =~ s/[^A-Za-z0-9\+\?\/\-:\(\)\.,' ]//g;
|
||||
return substr $string, 0, 35;
|
||||
}
|
||||
sub _restricted_identification_sepa2 {
|
||||
my ($self, $string) = @_;
|
||||
$string =~ s/[^A-Za-z0-9\+\?\/\-:\(\)\.,']//g;
|
||||
return substr $string, 0, 35;
|
||||
}
|
||||
| 1c603341 | Jan Büren | sub to_xml {
|
||
my $self = shift;
|
||||
croak "No transactions added yet." if (!@{ $self->{transactions} });
|
||||
my $output = '';
|
||||
my $xml = XML::Writer->new(OUTPUT => \$output,
|
||||
DATA_MODE => 1,
|
||||
DATA_INDENT => 2,
|
||||
ENCODING => 'utf-8');
|
||||
| c1716dbd | Moritz Bunkus | my @now = localtime;
|
||
my $time_zone = strftime "%z", @now;
|
||||
my $now_str = strftime('%Y-%m-%dT%H:%M:%S', @now) . substr($time_zone, 0, 3) . ':' . substr($time_zone, 3, 2);
|
||||
my $is_coll = $self->{collection};
|
||||
| 6a61183c | Moritz Bunkus | my $cd_src = $is_coll ? 'Cdtr' : 'Dbtr';
|
||
my $cd_dst = $is_coll ? 'Dbtr' : 'Cdtr';
|
||||
my $pain_id = $is_coll ? 'pain.008.002.02' : 'pain.001.002.03';
|
||||
my $pain_elmt = $is_coll ? 'CstmrDrctDbtInitn' : 'CstmrCdtTrfInitn';
|
||||
| c1716dbd | Moritz Bunkus | my @pii_base = (strftime('PII%Y%m%d%H%M%S', @now), rand(1000000000));
|
||
| 1c603341 | Jan Büren | |||
my $grouped_transactions = $self->_group_transactions();
|
||||
$xml->xmlDecl();
|
||||
| c1716dbd | Moritz Bunkus | |||
| 1c603341 | Jan Büren | $xml->startTag('Document',
|
||
| 6a61183c | Moritz Bunkus | 'xmlns' => "urn:iso:std:iso:20022:tech:xsd:${pain_id}",
|
||
| 1c603341 | Jan Büren | 'xmlns:xsi' => 'http://www.w3.org/2001/XMLSchema-instance',
|
||
| 6a61183c | Moritz Bunkus | 'xsi:schemaLocation' => "urn:iso:std:iso:20022:tech:xsd:${pain_id} ${pain_id}.xsd");
|
||
| 1c603341 | Jan Büren | |||
| c1716dbd | Moritz Bunkus | $xml->startTag($pain_elmt);
|
||
| 1c603341 | Jan Büren | |||
$xml->startTag('GrpHdr');
|
||||
| 6a61183c | Moritz Bunkus | $xml->dataElement('MsgId', encode('UTF-8', $self->_restricted_identification_sepa1($self->{message_id})));
|
||
| 1c603341 | Jan Büren | $xml->dataElement('CreDtTm', $now_str);
|
||
$xml->dataElement('NbOfTxs', scalar @{ $self->{transactions} });
|
||||
$xml->dataElement('CtrlSum', $self->_format_amount($grouped_transactions->{sum_amount}));
|
||||
$xml->startTag('InitgPty');
|
||||
$xml->dataElement('Nm', encode('UTF-8', substr($self->{company}, 0, 70)));
|
||||
$xml->endTag('InitgPty');
|
||||
$xml->endTag('GrpHdr');
|
||||
foreach my $key (keys %{ $grouped_transactions->{groups} }) {
|
||||
my $transaction_group = $grouped_transactions->{groups}->{$key};
|
||||
my $master_transaction = $transaction_group->{transactions}->[0];
|
||||
$xml->startTag('PmtInf');
|
||||
| 6a61183c | Moritz Bunkus | $xml->dataElement('PmtInfId', sprintf('%s%010d', @pii_base));
|
||
$pii_base[1]++;
|
||||
| c1716dbd | Moritz Bunkus | $xml->dataElement('PmtMtd', $is_coll ? 'DD' : 'TRF');
|
||
| 6a61183c | Moritz Bunkus | $xml->dataElement('NbOfTxs', scalar @{ $transaction_group->{transactions} });
|
||
$xml->dataElement('CtrlSum', $self->_format_amount($transaction_group->{sum_amount}));
|
||||
| 1c603341 | Jan Büren | |||
$xml->startTag('PmtTpInf');
|
||||
$xml->startTag('SvcLvl');
|
||||
$xml->dataElement('Cd', 'SEPA');
|
||||
$xml->endTag('SvcLvl');
|
||||
| c1716dbd | Moritz Bunkus | |||
if ($is_coll) {
|
||||
$xml->startTag('LclInstrm');
|
||||
$xml->dataElement('Cd', 'CORE');
|
||||
$xml->endTag('LclInstrm');
|
||||
$xml->dataElement('SeqTp', 'OOFF');
|
||||
}
|
||||
| 1c603341 | Jan Büren | $xml->endTag('PmtTpInf');
|
||
| c1716dbd | Moritz Bunkus | $xml->dataElement($is_coll ? 'ReqdColltnDt' : 'ReqdExctnDt', $master_transaction->get('execution_date'));
|
||
$xml->startTag($cd_src);
|
||||
| 1c603341 | Jan Büren | $xml->dataElement('Nm', encode('UTF-8', substr($self->{company}, 0, 70)));
|
||
| c1716dbd | Moritz Bunkus | $xml->endTag($cd_src);
|
||
| 1c603341 | Jan Büren | |||
| c1716dbd | Moritz Bunkus | $xml->startTag($cd_src . 'Acct');
|
||
| 1c603341 | Jan Büren | $xml->startTag('Id');
|
||
$xml->dataElement('IBAN', $master_transaction->get('src_iban', 34));
|
||||
$xml->endTag('Id');
|
||||
| c1716dbd | Moritz Bunkus | $xml->endTag($cd_src . 'Acct');
|
||
| 1c603341 | Jan Büren | |||
| c1716dbd | Moritz Bunkus | $xml->startTag($cd_src . 'Agt');
|
||
| 1c603341 | Jan Büren | $xml->startTag('FinInstnId');
|
||
$xml->dataElement('BIC', $master_transaction->get('src_bic', 20));
|
||||
$xml->endTag('FinInstnId');
|
||||
| c1716dbd | Moritz Bunkus | $xml->endTag($cd_src . 'Agt');
|
||
| 1c603341 | Jan Büren | |||
$xml->dataElement('ChrgBr', 'SLEV');
|
||||
foreach my $transaction (@{ $transaction_group->{transactions} }) {
|
||||
| c1716dbd | Moritz Bunkus | $xml->startTag($is_coll ? 'DrctDbtTxInf' : 'CdtTrfTxInf');
|
||
| 1c603341 | Jan Büren | |||
$xml->startTag('PmtId');
|
||||
| 6a61183c | Moritz Bunkus | $xml->dataElement('EndToEndId', $self->_restricted_identification_sepa1($transaction->get('end_to_end_id')));
|
||
| 1c603341 | Jan Büren | $xml->endTag('PmtId');
|
||
| c1716dbd | Moritz Bunkus | if ($is_coll) {
|
||
$xml->startTag('InstdAmt', 'Ccy' => 'EUR');
|
||||
$xml->characters($self->_format_amount($transaction->{amount}));
|
||||
$xml->endTag('InstdAmt');
|
||||
$xml->startTag('DrctDbtTx');
|
||||
$xml->startTag('MndtRltdInf');
|
||||
| 6a61183c | Moritz Bunkus | $xml->dataElement('MndtId', $self->_restricted_identification_sepa2($transaction->get('reference')));
|
||
| c1716dbd | Moritz Bunkus | $xml->dataElement('DtOfSgntr', $transaction->get('reference_date', 2010-12-02));
|
||
$xml->endTag('MndtRltdInf');
|
||||
$xml->startTag('CdtrSchmeId');
|
||||
$xml->startTag('Id');
|
||||
$xml->startTag('PrvtId');
|
||||
| 6a61183c | Moritz Bunkus | $xml->startTag('Othr');
|
||
| c1716dbd | Moritz Bunkus | $xml->dataElement('Id', encode('UTF-8', substr($self->{creditor_id}, 0, 35)));
|
||
| 6a61183c | Moritz Bunkus | $xml->startTag('SchmeNm');
|
||
$xml->dataElement('Prtry', 'SEPA');
|
||||
$xml->endTag('SchmeNm');
|
||||
$xml->endTag('Othr');
|
||||
| c1716dbd | Moritz Bunkus | $xml->endTag('PrvtId');
|
||
$xml->endTag('Id');
|
||||
$xml->endTag('CdtrSchmeId');
|
||||
$xml->endTag('DrctDbtTx');
|
||||
} else {
|
||||
$xml->startTag('Amt');
|
||||
$xml->startTag('InstdAmt', 'Ccy' => 'EUR');
|
||||
$xml->characters($self->_format_amount($transaction->{amount}));
|
||||
$xml->endTag('InstdAmt');
|
||||
$xml->endTag('Amt');
|
||||
}
|
||||
$xml->startTag("${cd_dst}Agt");
|
||||
| 1c603341 | Jan Büren | $xml->startTag('FinInstnId');
|
||
$xml->dataElement('BIC', $transaction->get('dst_bic', 20));
|
||||
$xml->endTag('FinInstnId');
|
||||
| c1716dbd | Moritz Bunkus | $xml->endTag("${cd_dst}Agt");
|
||
| 1c603341 | Jan Büren | |||
| c1716dbd | Moritz Bunkus | $xml->startTag("${cd_dst}");
|
||
$xml->dataElement('Nm', $transaction->get('company', 70));
|
||||
$xml->endTag("${cd_dst}");
|
||||
| 1c603341 | Jan Büren | |||
| c1716dbd | Moritz Bunkus | $xml->startTag("${cd_dst}Acct");
|
||
| 1c603341 | Jan Büren | $xml->startTag('Id');
|
||
$xml->dataElement('IBAN', $transaction->get('dst_iban', 34));
|
||||
$xml->endTag('Id');
|
||||
| c1716dbd | Moritz Bunkus | $xml->endTag("${cd_dst}Acct");
|
||
| 1c603341 | Jan Büren | |||
$xml->startTag('RmtInf');
|
||||
$xml->dataElement('Ustrd', $transaction->get('reference', 140));
|
||||
$xml->endTag('RmtInf');
|
||||
| c1716dbd | Moritz Bunkus | $xml->endTag($is_coll ? 'DrctDbtTxInf' : 'CdtTrfTxInf');
|
||
| 1c603341 | Jan Büren | }
|
||
$xml->endTag('PmtInf');
|
||||
}
|
||||
| c1716dbd | Moritz Bunkus | $xml->endTag($pain_elmt);
|
||
| 1c603341 | Jan Büren | $xml->endTag('Document');
|
||
return $output;
|
||||
}
|
||||
1;
|
||||
# Local Variables:
|
||||
# coding: utf-8
|
||||
# End:
|