From 8326cedca10878329ad4d5bf6405f977e14a541c Mon Sep 17 00:00:00 2001 From: Steven Schubiger Date: Thu, 28 Jan 2021 14:35:09 +0100 Subject: [PATCH] Swiss QR-Bill: QrBill.pm Modul Rebase von 38 Commits. --- SL/Helper/QrBill.pm | 329 ++++++++++++++++++++++++++++++++++++++++ SL/InstallationCheck.pm | 2 + 2 files changed, 331 insertions(+) create mode 100644 SL/Helper/QrBill.pm diff --git a/SL/Helper/QrBill.pm b/SL/Helper/QrBill.pm new file mode 100644 index 000000000..3628056bb --- /dev/null +++ b/SL/Helper/QrBill.pm @@ -0,0 +1,329 @@ +package SL::Helper::QrBill; + +use strict; +use warnings; + +use Imager; +use Imager::QRCode; + +my %Config = ( + cross_file => 'image/CH-Kreuz_7mm.png', + out_file => 'out.png', +); + +sub new { + my $class = shift; + + my $self = bless {}, $class; + + $self->_init_check(@_); + $self->_init(@_); + + return $self; +} + +sub _init { + my $self = shift; + my ($biller_information, $biller_data, $payment_information, $invoice_recipient_data, $ref_nr_data) = @_; + + $self->{data}{header} = [ + 'SPC', # QRType + '0200', # Version + 1, # Coding Type + ]; + $self->{data}{biller_information} = [ + $biller_information->{iban}, + ]; + $self->{data}{biller_data} = [ + $biller_data->{address_type}, + $biller_data->{company}, + $biller_data->{address_row1}, + $biller_data->{address_row2}, + '', + '', + $biller_data->{countrycode}, + ]; + $self->{data}{payment_information} = [ + $payment_information->{amount}, + $payment_information->{currency}, + ]; + $self->{data}{invoice_recipient_data} = [ + $invoice_recipient_data->{address_type}, + $invoice_recipient_data->{name}, + $invoice_recipient_data->{address_row1}, + $invoice_recipient_data->{address_row2}, + '', + '', + $invoice_recipient_data->{countrycode}, + ]; + $self->{data}{ref_nr_data} = [ + $ref_nr_data->{type}, + $ref_nr_data->{ref_number}, + ]; + $self->{data}{additional_information} = [ + '', + 'EPD', # End Payment Data + ]; +} + +sub _init_check { + my $self = shift; + my ($biller_information, $biller_data, $payment_information, $invoice_recipient_data, $ref_nr_data) = @_; + + my $check_re = sub { + my ($href, $elem, $regex) = @_; + defined $href->{$elem} && $href->{$elem} =~ $regex + or die "parameter '$elem' not valid", "\n"; + }; + + $check_re->($biller_information, 'iban', qr{^(?:CH|LI)[0-9a-zA-Z]{19}$}); + + $check_re->($biller_data, 'address_type', qr{^[KS]$}); + $check_re->($biller_data, 'company', qr{^.{1,70}$}); + $check_re->($biller_data, 'address_row1', qr{^.{0,70}$}); + $check_re->($biller_data, 'address_row2', qr{^.{0,70}$}); + $check_re->($biller_data, 'countrycode', qr{^[A-Z]{2}$}); + + $check_re->($payment_information, 'amount', qr{^(?:(?:0|[1-9][0-9]{0,8})\.[0-9]{2})?$}); + $check_re->($payment_information, 'currency', qr{^(?:CHF|EUR)$}); + + $check_re->($invoice_recipient_data, 'address_type', qr{^[KS]$}); + $check_re->($invoice_recipient_data, 'name', qr{^.{1,70}$}); + $check_re->($invoice_recipient_data, 'address_row1', qr{^.{0,70}$}); + $check_re->($invoice_recipient_data, 'address_row2', qr{^.{0,70}$}); + $check_re->($invoice_recipient_data, 'countrycode', qr{^[A-Z]{2}$}); + + $check_re->($ref_nr_data, 'type', qr{^(?:QRR|SCOR|NON)$}); + $check_re->($ref_nr_data, 'ref_number', qr{^\d{27}$}); +} + +sub generate { + my $self = shift; + my $out_file = defined $_[0] ? $_[0] : $Config{out_file}; + + $self->{qrcode} = $self->_qrcode(); + $self->{cross} = $self->_cross(); + $self->{img} = $self->_plot(); + + $self->_paste(); + $self->_write($out_file); +} + +sub _qrcode { + my $self = shift; + + return Imager::QRCode->new( + size => 3, + margin => 1, + level => 'M', + ); +} + +sub _cross { + my $self = shift; + + my $cross = Imager->new(); + $cross->read(file => $Config{cross_file}) or die $cross->errstr, "\n"; + + return $cross->scale(xpixels => 27, ypixels => 27, qtype => 'mixing'); +} + +sub _plot { + my $self = shift; + + my @data = ( + @{$self->{data}{header}}, + @{$self->{data}{biller_information}}, + @{$self->{data}{biller_data}}, + ('') x 7, # for future use + @{$self->{data}{payment_information}}, + @{$self->{data}{invoice_recipient_data}}, + @{$self->{data}{ref_nr_data}}, + @{$self->{data}{additional_information}}, + ); + + foreach (@data) { + s/[\r\n]/ /g; + s/ {2,}/ /g; + s/^\s+//; + s/\s+$//; + } + # CR + LF + my $text = join "\015\012", @data; + + return $self->{qrcode}->plot($text); +} + +sub _paste { + my $self = shift; + + $self->{img}->paste( + src => $self->{cross}, + left => ($self->{img}->getwidth / 2) - ($self->{cross}->getwidth / 2), + top => ($self->{img}->getheight / 2) - ($self->{cross}->getheight / 2), + ); +} + +sub _write { + my $self = shift; + my ($out_file) = @_; + + $self->{img}->write(file => $out_file) or die $self->{img}->errstr, "\n"; +} + +1; + +__END__ + +=encoding utf-8 + +=head1 NAME + +SL::Helper::QrBill - Helper methods for generating Swiss QR-Code + +=head1 SYNOPSIS + + use SL::Helper::QrBill; + + eval { + my $qr_image = SL::Helper::QrBill->new( + \%biller_information, + \%biller_data, + \%payment_information, + \%invoice_recipient_data, + \%ref_nr_data, + ); + $qr_image->generate($outfile); + } or do { + local $_ = $@; chomp; my $error = $_; + $::form->error($::locale->text('QR-Image generation failed: ' . $error)); + }; + +=head1 DESCRIPTION + +This module generates the Swiss QR-Code with data provided to the constructor. + +=head1 METHODS + +=head2 C + +Creates a new object. Expects five references to hashes as arguments. + +The hashes are structured as follows: + +=over 4 + +=item C<%biller_information> + +Fields: iban. + +=over 4 + +=item C + +Fixed length; 21 alphanumerical characters, only IBANs with CH- or LI- +country code. + +=back + +=item C<%biller_data> + +Fields: address_type, company, address_row1, address_row2 and countrycode. + +=over 4 + +=item C + +Fixed length; 1-digit, alphanumerical. 'K' implemented only. + +=item C + +Maximum of 70 characters, name (surname allowable) or company. + +=item C + +Maximum of 70 characters, street/nr. + +=item C + +Maximum of 70 characters, postal code/place. + +=item C + +2-digit country code according to ISO 3166-1. + +=back + +=item C<%payment_information> + +Fields: amount and currency. + +=over 4 + +=item C + +Decimal, no leading zeroes, maximum of 12 digits (inclusive decimal +separator and places). Only dot as decimal separator is permitted. + +=item C + +CHF/EUR. + +=back + +=item C<%invoice_recipient_data> + +Fields: address_type, name, address_row1, address_row2 and countrycode. + +=over 4 + +=item C + +Fixed length; 1-digit, alphanumerical. 'K' implemented only. + +=item C + +Maximum of 70 characters, name (surname allowable) or company. + +=item C + +Maximum of 70 characters, street/nr. + +=item C + +Maximum of 70 characters, postal code/place. + +=item C + +2-digit country code according to ISO 3166-1. + +=back + +=item C<%ref_nr_data> + +Fields: type and ref_number. + +=over 4 + +=item C + +Maximum of 4 characters, alphanumerical. QRR/SCOR/NON. + +=item C + +27 characters, numerical. QR-Reference. + +=back + +=back + +=head2 C + +Generates the QR-Code image. Accepts filename of image as argument. +Defaults to C. + +=head1 AUTHOR + +Steven Schubiger Estsc@refcnt.orgE + +=cut diff --git a/SL/InstallationCheck.pm b/SL/InstallationCheck.pm index a3d22d994..7712d090a 100644 --- a/SL/InstallationCheck.pm +++ b/SL/InstallationCheck.pm @@ -43,6 +43,8 @@ BEGIN { { name => 'HTML::Parser', url => 'http://search.cpan.org/~gaas/', debian => 'libhtml-parser-perl', }, { name => 'HTML::Restrict', url => 'http://search.cpan.org/~oalders/', debian => 'libhtml-restrict-perl'}, { name => "Image::Info", url => "http://search.cpan.org/~srezic/", debian => 'libimage-info-perl' }, + { name => "Imager", url => "http://search.cpan.org/~tonyc/", debian => 'libimager-perl' }, + { name => "Imager::QRCode", url => "http://search.cpan.org/~kurihara/", debian => 'libimager-qrcode-perl' }, { name => "JSON", url => "http://search.cpan.org/~makamaka", debian => 'libjson-perl' }, { name => "List::MoreUtils", version => '0.30', url => "http://search.cpan.org/~vparseval/", debian => 'liblist-moreutils-perl' }, { name => "List::UtilsBy", version => '0.09', url => "http://search.cpan.org/~pevans/", debian => 'liblist-utilsby-perl' }, -- 2.20.1