Swiss QR-Bill: QrBill.pm Modul

Rebase von 38 Commits.

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<new>
+
+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<iban>
+
+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<address_type>
+
+Fixed length; 1-digit, alphanumerical. 'K' implemented only.
+
+=item C<company>
+
+Maximum of 70 characters, name (surname allowable) or company.
+
+=item C<address_row1>
+
+Maximum of 70 characters, street/nr.
+
+=item C<address_row2>
+
+Maximum of 70 characters, postal code/place.
+
+=item C<countrycode>
+
+2-digit country code according to ISO 3166-1.
+
+=back
+
+=item C<%payment_information>
+
+Fields: amount and currency.
+
+=over 4
+
+=item C<amount>
+
+Decimal, no leading zeroes, maximum of 12 digits (inclusive decimal
+separator and places). Only dot as decimal separator is permitted.
+
+=item C<currency>
+
+CHF/EUR.
+
+=back
+
+=item C<%invoice_recipient_data>
+
+Fields: address_type, name, address_row1, address_row2 and countrycode.
+
+=over 4
+
+=item C<address_type>
+
+Fixed length; 1-digit, alphanumerical. 'K' implemented only.
+
+=item C<name>
+
+Maximum of 70 characters, name (surname allowable) or company.
+
+=item C<address_row1>
+
+Maximum of 70 characters, street/nr.
+
+=item C<address_row2>
+
+Maximum of 70 characters, postal code/place.
+
+=item C<countrycode>
+
+2-digit country code according to ISO 3166-1.
+
+=back
+
+=item C<%ref_nr_data>
+
+Fields: type and ref_number.
+
+=over 4
+
+=item C<type>
+
+Maximum of 4 characters, alphanumerical. QRR/SCOR/NON.
+
+=item C<ref_number>
+
+27 characters, numerical. QR-Reference.
+
+=back
+
+=back
+
+=head2 C<generate>
+
+Generates the QR-Code image. Accepts filename of image as argument.
+Defaults to C<out.png>.
+
+=head1 AUTHOR
+
+Steven Schubiger E<lt>stsc@refcnt.orgE<gt>
+
+=cut

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' },