1661 lines
50 KiB
Perl
1661 lines
50 KiB
Perl
package C4::Labels;
|
|
|
|
# Copyright 2006 Katipo Communications.
|
|
#
|
|
# This file is part of Koha.
|
|
#
|
|
# Koha is free software; you can redistribute it and/or modify it under the
|
|
# terms of the GNU General Public License as published by the Free Software
|
|
# Foundation; either version 2 of the License, or (at your option) any later
|
|
# version.
|
|
#
|
|
# Koha is distributed in the hope that it will be useful, but WITHOUT ANY
|
|
# WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR
|
|
# A PARTICULAR PURPOSE. See the GNU General Public License for more details.
|
|
#
|
|
# You should have received a copy of the GNU General Public License along with
|
|
# Koha; if not, write to the Free Software Foundation, Inc., 59 Temple Place,
|
|
# Suite 330, Boston, MA 02111-1307 USA
|
|
|
|
use strict;
|
|
use vars qw($VERSION @ISA @EXPORT);
|
|
|
|
use PDF::Reuse;
|
|
use Text::Wrap;
|
|
use Algorithm::CheckDigits;
|
|
use C4::Members;
|
|
use C4::Branch;
|
|
use C4::Debug;
|
|
use C4::Biblio;
|
|
use Text::CSV_XS;
|
|
use Data::Dumper;
|
|
|
|
BEGIN {
|
|
$VERSION = 0.03;
|
|
require Exporter;
|
|
@ISA = qw(Exporter);
|
|
@EXPORT = qw(
|
|
&get_label_options &GetLabelItems
|
|
&build_circ_barcode &draw_boundaries
|
|
&drawbox &GetActiveLabelTemplate
|
|
&GetAllLabelTemplates &DeleteTemplate
|
|
&GetSingleLabelTemplate &SaveTemplate
|
|
&CreateTemplate &SetActiveTemplate
|
|
&SaveConf &DrawSpineText &GetTextWrapCols
|
|
&GetUnitsValue &DrawBarcode &DrawPatronCardText
|
|
&get_printingtypes &GetPatronCardItems
|
|
&get_layouts
|
|
&get_barcode_types
|
|
&get_batches &delete_batch
|
|
&add_batch &printText
|
|
&GetItemFields
|
|
&get_text_fields
|
|
get_layout &save_layout &add_layout
|
|
&set_active_layout
|
|
&build_text_dropbox
|
|
&delete_layout &get_active_layout
|
|
&get_highest_batch
|
|
&deduplicate_batch
|
|
&GetAllPrinterProfiles &GetSinglePrinterProfile
|
|
&SaveProfile &CreateProfile &DeleteProfile
|
|
&GetAssociatedProfile &SetAssociatedProfile
|
|
);
|
|
}
|
|
|
|
|
|
=head1 NAME
|
|
|
|
C4::Labels - Functions for printing spine labels and barcodes in Koha
|
|
|
|
=head1 FUNCTIONS
|
|
|
|
=head2 get_label_options;
|
|
|
|
$options = get_label_options()
|
|
|
|
Return a pointer on a hash list containing info from labels_conf table in Koha DB.
|
|
|
|
=cut
|
|
|
|
sub get_label_options {
|
|
my $query2 = " SELECT * FROM labels_conf where active = 1"; # FIXME: exact same as get_active_layout
|
|
my $sth = C4::Context->dbh->prepare($query2);
|
|
$sth->execute();
|
|
return $sth->fetchrow_hashref;
|
|
}
|
|
|
|
sub get_layouts {
|
|
my $dbh = C4::Context->dbh;
|
|
my @data;
|
|
my $query = " Select * from labels_conf";
|
|
my $sth = $dbh->prepare($query);
|
|
$sth->execute();
|
|
my @resultsloop;
|
|
while ( my $data = $sth->fetchrow_hashref ) {
|
|
|
|
$data->{'fieldlist'} = get_text_fields( $data->{'id'} );
|
|
push( @resultsloop, $data );
|
|
}
|
|
$sth->finish;
|
|
return @resultsloop;
|
|
}
|
|
|
|
sub get_layout {
|
|
my ($layout_id) = @_;
|
|
my $dbh = C4::Context->dbh;
|
|
|
|
# get the actual items to be printed.
|
|
my $query = " Select * from labels_conf where id = ?";
|
|
my $sth = $dbh->prepare($query);
|
|
$sth->execute($layout_id);
|
|
my $data = $sth->fetchrow_hashref;
|
|
$sth->finish;
|
|
return $data;
|
|
}
|
|
|
|
sub get_active_layout {
|
|
my $query = " Select * from labels_conf where active = 1"; # FIXME: exact same as get_label_options
|
|
my $sth = C4::Context->dbh->prepare($query);
|
|
$sth->execute();
|
|
return $sth->fetchrow_hashref;
|
|
}
|
|
|
|
sub delete_layout {
|
|
my ($layout_id) = @_;
|
|
my $dbh = C4::Context->dbh;
|
|
|
|
# get the actual items to be printed.
|
|
my $query = "delete from labels_conf where id = ?";
|
|
my $sth = $dbh->prepare($query);
|
|
$sth->execute($layout_id);
|
|
$sth->finish;
|
|
}
|
|
|
|
sub get_printingtypes {
|
|
my ($layout_id) = @_;
|
|
my @printtypes;
|
|
# FIXME hard coded print types
|
|
push( @printtypes, { code => 'BAR', desc => "barcode only" } );
|
|
push( @printtypes, { code => 'BIB', desc => "biblio only" } );
|
|
push( @printtypes, { code => 'BARBIB', desc => "barcode / biblio" } );
|
|
push( @printtypes, { code => 'BIBBAR', desc => "biblio / barcode" } );
|
|
push( @printtypes, { code => 'ALT', desc => "alternating labels" } );
|
|
push( @printtypes, { code => 'CSV', desc => "csv output" } );
|
|
push( @printtypes, { code => 'PATCRD', desc => "patron cards" } );
|
|
|
|
my $conf = get_layout($layout_id);
|
|
my $active_printtype = $conf->{'printingtype'};
|
|
|
|
# lop thru layout, insert selected to hash
|
|
|
|
foreach my $printtype (@printtypes) {
|
|
if ( $printtype->{'code'} eq $active_printtype ) {
|
|
$printtype->{'active'} = 1;
|
|
}
|
|
}
|
|
return @printtypes;
|
|
}
|
|
|
|
# this sub (build_text_dropbox) is deprecated and should be deleted.
|
|
# rch 2008.04.15
|
|
#
|
|
sub build_text_dropbox {
|
|
my ($order) = @_;
|
|
my $field_count = 7; # <----------- FIXME hard coded
|
|
my @lines;
|
|
!$order
|
|
? push( @lines, { num => '', selected => '1' } )
|
|
: push( @lines, { num => '' } );
|
|
for ( my $i = 1 ; $i <= $field_count ; $i++ ) {
|
|
my $line = { num => "$i" };
|
|
$line->{'selected'} = 1 if $i eq $order;
|
|
push( @lines, $line );
|
|
}
|
|
return @lines;
|
|
}
|
|
|
|
sub get_text_fields {
|
|
my ( $layout_id, $sorttype ) = @_;
|
|
my @sorted_fields;
|
|
my $error;
|
|
my $sortorder = get_layout($layout_id);
|
|
if ( $sortorder->{formatstring} ) {
|
|
if ( !$sorttype ) {
|
|
return $sortorder->{formatstring};
|
|
}
|
|
else {
|
|
my $csv = Text::CSV_XS->new( { allow_whitespace => 1 } );
|
|
my $line = $sortorder->{formatstring};
|
|
my $status = $csv->parse($line);
|
|
@sorted_fields =
|
|
map { { 'code' => $_, desc => $_ } } $csv->fields();
|
|
$error = $csv->error_input();
|
|
warn $error if $error; # TODO - do more with this.
|
|
}
|
|
}
|
|
else {
|
|
|
|
# These fields are hardcoded based on the template for label-edit-layout.pl
|
|
my @text_fields = (
|
|
{
|
|
code => 'itemtype',
|
|
desc => "Item Type",
|
|
order => $sortorder->{'itemtype'}
|
|
},
|
|
{
|
|
code => 'issn',
|
|
desc => "ISSN",
|
|
order => $sortorder->{'issn'}
|
|
},
|
|
{
|
|
code => 'isbn',
|
|
desc => "ISBN",
|
|
order => $sortorder->{'isbn'}
|
|
},
|
|
{
|
|
code => 'barcode',
|
|
desc => "Barcode",
|
|
order => $sortorder->{'barcode'}
|
|
},
|
|
{
|
|
code => 'author',
|
|
desc => "Author",
|
|
order => $sortorder->{'author'}
|
|
},
|
|
{
|
|
code => 'title',
|
|
desc => "Title",
|
|
order => $sortorder->{'title'}
|
|
},
|
|
{
|
|
code => 'itemcallnumber',
|
|
desc => "Call Number",
|
|
order => $sortorder->{'itemcallnumber'}
|
|
},
|
|
);
|
|
|
|
my @new_fields = ();
|
|
foreach my $field (@text_fields) {
|
|
push( @new_fields, $field ) if $field->{'order'} > 0;
|
|
}
|
|
|
|
@sorted_fields = sort { $$a{order} <=> $$b{order} } @new_fields;
|
|
}
|
|
|
|
# if we have a 'formatstring', then we ignore these hardcoded fields.
|
|
my $active_fields;
|
|
|
|
if ( $sorttype eq 'codes' )
|
|
{ # FIXME: This sub should really always return the array of hashrefs and let the caller take what he wants from that -fbcit
|
|
return @sorted_fields;
|
|
}
|
|
else {
|
|
foreach my $field (@sorted_fields) {
|
|
$active_fields .= "$field->{'desc'} ";
|
|
}
|
|
return $active_fields;
|
|
}
|
|
|
|
}
|
|
|
|
=head2 sub add_batch
|
|
|
|
=over 4
|
|
|
|
add_batch($batch_type,\@batch_list);
|
|
if $batch_list is supplied,
|
|
create a new batch with those items.
|
|
else, return the next available batch_id.
|
|
|
|
=back
|
|
|
|
=cut
|
|
|
|
sub add_batch ($;$) {
|
|
my $table = (@_ and 'patroncards' eq shift) ? 'patroncards' : 'labels';
|
|
my $batch_list = (@_) ? shift : undef;
|
|
my $dbh = C4::Context->dbh;
|
|
my $q ="SELECT MAX(DISTINCT batch_id) FROM $table";
|
|
my $sth = $dbh->prepare($q);
|
|
$sth->execute();
|
|
my ($batch_id) = $sth->fetchrow_array || 0;
|
|
$batch_id++;
|
|
if ($batch_list) {
|
|
if ($table eq 'patroncards') {
|
|
$sth = $dbh->prepare("INSERT INTO $table (`batch_id`,`borrowernumber`) VALUES (?,?)");
|
|
} else {
|
|
$sth = $dbh->prepare("INSERT INTO $table (`batch_id`,`itemnumber` ) VALUES (?,?)");
|
|
}
|
|
for (@$batch_list) {
|
|
$sth->execute($batch_id,$_);
|
|
}
|
|
}
|
|
return $batch_id;
|
|
}
|
|
|
|
#FIXME: Needs to be ported to receive $batch_type
|
|
# ... this looks eerily like add_batch() ...
|
|
sub get_highest_batch {
|
|
my $table = (@_ and 'patroncards' eq shift) ? 'patroncards' : 'labels';
|
|
my $q =
|
|
"select distinct batch_id from $table order by batch_id desc limit 1";
|
|
my $sth = C4::Context->dbh->prepare($q);
|
|
$sth->execute();
|
|
my $data = $sth->fetchrow_hashref or return 1;
|
|
return ($data->{'batch_id'} || 1);
|
|
}
|
|
|
|
|
|
sub get_batches (;$) {
|
|
my $table = (@_ and 'patroncards' eq shift) ? 'patroncards' : 'labels';
|
|
my $q = "SELECT batch_id, COUNT(*) AS num FROM $table GROUP BY batch_id";
|
|
my $sth = C4::Context->dbh->prepare($q);
|
|
$sth->execute();
|
|
my $batches = $sth->fetchall_arrayref({});
|
|
return @$batches;
|
|
}
|
|
|
|
sub delete_batch {
|
|
my ($batch_id, $batch_type) = @_;
|
|
warn "Deleteing batch of type $batch_type";
|
|
my $dbh = C4::Context->dbh;
|
|
my $q = "DELETE FROM $batch_type WHERE batch_id = ?";
|
|
my $sth = $dbh->prepare($q);
|
|
$sth->execute($batch_id);
|
|
$sth->finish;
|
|
}
|
|
|
|
sub get_barcode_types {
|
|
my ($layout_id) = @_;
|
|
my $layout = get_layout($layout_id);
|
|
my $barcode = $layout->{'barcodetype'};
|
|
my @array;
|
|
|
|
push( @array, { code => 'CODE39', desc => 'Code 39' } );
|
|
push( @array, { code => 'CODE39MOD', desc => 'Code39 + Modulo43' } );
|
|
push( @array, { code => 'CODE39MOD10', desc => 'Code39 + Modulo10' } );
|
|
push( @array, { code => 'ITF', desc => 'Interleaved 2 of 5' } );
|
|
|
|
foreach my $line (@array) {
|
|
if ( $line->{'code'} eq $barcode ) {
|
|
$line->{'active'} = 1;
|
|
}
|
|
|
|
}
|
|
return @array;
|
|
}
|
|
|
|
sub GetUnitsValue {
|
|
my ($units) = @_;
|
|
my $unitvalue;
|
|
|
|
$unitvalue = '1' if ( $units eq 'POINT' );
|
|
$unitvalue = '2.83464567' if ( $units eq 'MM' );
|
|
$unitvalue = '28.3464567' if ( $units eq 'CM' );
|
|
$unitvalue = 72 if ( $units eq 'INCH' );
|
|
return $unitvalue;
|
|
}
|
|
|
|
sub GetTextWrapCols {
|
|
my ( $font, $fontsize, $label_width, $left_text_margin ) = @_;
|
|
my $string = '0';
|
|
my $strwidth;
|
|
my $count = 0;
|
|
# my $textlimit = $label_width - ($left_text_margin);
|
|
my $textlimit = $label_width - ( 3 * $left_text_margin);
|
|
|
|
while ( $strwidth < $textlimit ) {
|
|
$strwidth = prStrWidth( $string, $font, $fontsize );
|
|
$string = $string . '0';
|
|
#warn "strwidth:$strwidth, textlimit:$textlimit, count:$count string:$string";
|
|
$count++;
|
|
}
|
|
return $count;
|
|
}
|
|
|
|
sub GetActiveLabelTemplate {
|
|
my $dbh = C4::Context->dbh;
|
|
my $query = " SELECT * FROM labels_templates where active = 1 limit 1";
|
|
my $sth = $dbh->prepare($query);
|
|
$sth->execute();
|
|
my $active_tmpl = $sth->fetchrow_hashref;
|
|
$sth->finish;
|
|
return $active_tmpl;
|
|
}
|
|
|
|
sub GetSingleLabelTemplate {
|
|
my ($tmpl_id) = @_;
|
|
my $dbh = C4::Context->dbh;
|
|
my $query = " SELECT * FROM labels_templates where tmpl_id = ?";
|
|
my $sth = $dbh->prepare($query);
|
|
$sth->execute($tmpl_id);
|
|
my $template = $sth->fetchrow_hashref;
|
|
$sth->finish;
|
|
return $template;
|
|
}
|
|
|
|
sub SetActiveTemplate {
|
|
|
|
my ($tmpl_id) = @_;
|
|
|
|
my $dbh = C4::Context->dbh;
|
|
my $query = " UPDATE labels_templates SET active = NULL";
|
|
my $sth = $dbh->prepare($query);
|
|
$sth->execute();
|
|
|
|
$query = "UPDATE labels_templates SET active = 1 WHERE tmpl_id = ?";
|
|
$sth = $dbh->prepare($query);
|
|
$sth->execute($tmpl_id);
|
|
$sth->finish;
|
|
}
|
|
|
|
sub set_active_layout {
|
|
|
|
my ($layout_id) = @_;
|
|
my $dbh = C4::Context->dbh;
|
|
my $query = " UPDATE labels_conf SET active = NULL";
|
|
my $sth = $dbh->prepare($query);
|
|
$sth->execute();
|
|
|
|
$query = "UPDATE labels_conf SET active = 1 WHERE id = ?";
|
|
$sth = $dbh->prepare($query);
|
|
$sth->execute($layout_id);
|
|
$sth->finish;
|
|
}
|
|
|
|
sub DeleteTemplate {
|
|
my ($tmpl_id) = @_;
|
|
my $dbh = C4::Context->dbh;
|
|
my $query = " DELETE FROM labels_templates where tmpl_id = ?";
|
|
my $sth = $dbh->prepare($query);
|
|
$sth->execute($tmpl_id);
|
|
$sth->finish;
|
|
}
|
|
|
|
sub SaveTemplate {
|
|
my (
|
|
$tmpl_id, $tmpl_code, $tmpl_desc, $page_width,
|
|
$page_height, $label_width, $label_height, $topmargin,
|
|
$leftmargin, $cols, $rows, $colgap,
|
|
$rowgap, $font, $fontsize, $units
|
|
) = @_;
|
|
$debug and warn "Passed \$font:$font";
|
|
my $dbh = C4::Context->dbh;
|
|
my $query =
|
|
" UPDATE labels_templates SET tmpl_code=?, tmpl_desc=?, page_width=?,
|
|
page_height=?, label_width=?, label_height=?, topmargin=?,
|
|
leftmargin=?, cols=?, rows=?, colgap=?, rowgap=?, font=?, fontsize=?,
|
|
units=?
|
|
WHERE tmpl_id = ?";
|
|
|
|
my $sth = $dbh->prepare($query);
|
|
$sth->execute(
|
|
$tmpl_code, $tmpl_desc, $page_width, $page_height,
|
|
$label_width, $label_height, $topmargin, $leftmargin,
|
|
$cols, $rows, $colgap, $rowgap,
|
|
$font, $fontsize, $units, $tmpl_id
|
|
);
|
|
my $dberror = $sth->errstr;
|
|
$sth->finish;
|
|
return $dberror;
|
|
}
|
|
|
|
sub CreateTemplate {
|
|
my $tmpl_id;
|
|
my (
|
|
$tmpl_code, $tmpl_desc, $page_width, $page_height,
|
|
$label_width, $label_height, $topmargin, $leftmargin,
|
|
$cols, $rows, $colgap, $rowgap,
|
|
$font, $fontsize, $units
|
|
) = @_;
|
|
|
|
my $dbh = C4::Context->dbh;
|
|
|
|
my $query = "INSERT INTO labels_templates (tmpl_code, tmpl_desc, page_width,
|
|
page_height, label_width, label_height, topmargin,
|
|
leftmargin, cols, rows, colgap, rowgap, font, fontsize, units)
|
|
VALUES(?,?,?,?,?,?,?,?,?,?,?,?,?,?,?)";
|
|
|
|
my $sth = $dbh->prepare($query);
|
|
$sth->execute(
|
|
$tmpl_code, $tmpl_desc, $page_width, $page_height,
|
|
$label_width, $label_height, $topmargin, $leftmargin,
|
|
$cols, $rows, $colgap, $rowgap,
|
|
$font, $fontsize, $units
|
|
);
|
|
my $dberror = $sth->errstr;
|
|
$sth->finish;
|
|
return $dberror;
|
|
}
|
|
|
|
sub GetAllLabelTemplates {
|
|
my $dbh = C4::Context->dbh;
|
|
|
|
# get the actual items to be printed.
|
|
my @data;
|
|
my $query = " Select * from labels_templates ";
|
|
my $sth = $dbh->prepare($query);
|
|
$sth->execute();
|
|
my @resultsloop;
|
|
while ( my $data = $sth->fetchrow_hashref ) {
|
|
push( @resultsloop, $data );
|
|
}
|
|
$sth->finish;
|
|
|
|
#warn Dumper @resultsloop;
|
|
return @resultsloop;
|
|
}
|
|
|
|
#sub SaveConf {
|
|
sub add_layout {
|
|
|
|
my (
|
|
$barcodetype, $title, $subtitle, $isbn, $issn,
|
|
$itemtype, $bcn, $text_justify, $callnum_split,
|
|
$itemcallnumber, $author, $tmpl_id,
|
|
$printingtype, $guidebox, $startlabel, $layoutname, $formatstring
|
|
) = @_;
|
|
|
|
my $dbh = C4::Context->dbh;
|
|
my $query2 = "update labels_conf set active = NULL";
|
|
my $sth2 = $dbh->prepare($query2);
|
|
$sth2->execute();
|
|
$query2 = "INSERT INTO labels_conf
|
|
( barcodetype, title, subtitle, isbn,issn, itemtype, barcode,
|
|
text_justify, callnum_split, itemcallnumber, author, printingtype,
|
|
guidebox, startlabel, layoutname, formatstring, active )
|
|
values ( ?, ?,?, ?, ?, ?, ?, ?, ?, ?, ?, ?, ?, ?,?,?, 1 )";
|
|
$sth2 = $dbh->prepare($query2);
|
|
$sth2->execute(
|
|
$barcodetype, $title, $subtitle, $isbn, $issn,
|
|
|
|
$itemtype, $bcn, $text_justify, $callnum_split,
|
|
$itemcallnumber, $author, $printingtype,
|
|
$guidebox, $startlabel, $layoutname, $formatstring
|
|
);
|
|
$sth2->finish;
|
|
|
|
SetActiveTemplate($tmpl_id);
|
|
return;
|
|
}
|
|
|
|
sub save_layout {
|
|
|
|
my (
|
|
$barcodetype, $title, $subtitle, $isbn, $issn,
|
|
$itemtype, $bcn, $text_justify, $callnum_split,
|
|
$itemcallnumber, $author, $tmpl_id,
|
|
$printingtype, $guidebox, $startlabel, $layoutname, $formatstring,
|
|
$layout_id
|
|
) = @_;
|
|
### $layoutname
|
|
### $layout_id
|
|
|
|
my $dbh = C4::Context->dbh;
|
|
my $query2 = "update labels_conf set
|
|
barcodetype=?, title=?, subtitle=?, isbn=?,issn=?,
|
|
itemtype=?, barcode=?, text_justify=?, callnum_split=?,
|
|
itemcallnumber=?, author=?, printingtype=?,
|
|
guidebox=?, startlabel=?, layoutname=?, formatstring=? where id = ?";
|
|
my $sth2 = $dbh->prepare($query2);
|
|
$sth2->execute(
|
|
$barcodetype, $title, $subtitle, $isbn, $issn,
|
|
$itemtype, $bcn, $text_justify, $callnum_split,
|
|
$itemcallnumber, $author, $printingtype,
|
|
$guidebox, $startlabel, $layoutname, $formatstring, $layout_id
|
|
);
|
|
$sth2->finish;
|
|
|
|
return;
|
|
}
|
|
|
|
=head2 GetAllPrinterProfiles;
|
|
|
|
@profiles = GetAllPrinterProfiles()
|
|
|
|
Returns an array of references-to-hash, whos keys are .....
|
|
|
|
=cut
|
|
|
|
sub GetAllPrinterProfiles {
|
|
|
|
my $dbh = C4::Context->dbh;
|
|
my @data;
|
|
my $query = "SELECT * FROM printers_profile AS pp INNER JOIN labels_templates AS lt ON pp.tmpl_id = lt.tmpl_id; ";
|
|
my $sth = $dbh->prepare($query);
|
|
$sth->execute();
|
|
my @resultsloop;
|
|
while ( my $data = $sth->fetchrow_hashref ) {
|
|
push( @resultsloop, $data );
|
|
}
|
|
$sth->finish;
|
|
|
|
return @resultsloop;
|
|
}
|
|
|
|
=head2 GetSinglePrinterProfile;
|
|
|
|
$profile = GetSinglePrinterProfile()
|
|
|
|
Returns a hashref whos keys are...
|
|
|
|
=cut
|
|
|
|
sub GetSinglePrinterProfile {
|
|
my ($prof_id) = @_;
|
|
my $dbh = C4::Context->dbh;
|
|
my $query = " SELECT * FROM printers_profile WHERE prof_id = ?; ";
|
|
my $sth = $dbh->prepare($query);
|
|
$sth->execute($prof_id);
|
|
my $template = $sth->fetchrow_hashref;
|
|
$sth->finish;
|
|
return $template;
|
|
}
|
|
|
|
=head2 SaveProfile;
|
|
|
|
SaveProfile('parameters')
|
|
|
|
When passed a set of parameters, this function updates the given profile with the new parameters.
|
|
|
|
=cut
|
|
|
|
sub SaveProfile {
|
|
my (
|
|
$prof_id, $offset_horz, $offset_vert, $creep_horz, $creep_vert, $units
|
|
) = @_;
|
|
my $dbh = C4::Context->dbh;
|
|
my $query =
|
|
" UPDATE printers_profile
|
|
SET offset_horz=?, offset_vert=?, creep_horz=?, creep_vert=?, unit=?
|
|
WHERE prof_id = ? ";
|
|
my $sth = $dbh->prepare($query);
|
|
$sth->execute(
|
|
$offset_horz, $offset_vert, $creep_horz, $creep_vert, $units, $prof_id
|
|
);
|
|
$sth->finish;
|
|
}
|
|
|
|
=head2 CreateProfile;
|
|
|
|
CreateProfile('parameters')
|
|
|
|
When passed a set of parameters, this function creates a new profile containing those parameters
|
|
and returns any errors.
|
|
|
|
=cut
|
|
|
|
sub CreateProfile {
|
|
my (
|
|
$prof_id, $printername, $paper_bin, $tmpl_id, $offset_horz,
|
|
$offset_vert, $creep_horz, $creep_vert, $units
|
|
) = @_;
|
|
my $dbh = C4::Context->dbh;
|
|
my $query =
|
|
" INSERT INTO printers_profile (prof_id, printername, paper_bin, tmpl_id,
|
|
offset_horz, offset_vert, creep_horz, creep_vert, unit)
|
|
VALUES(?,?,?,?,?,?,?,?,?) ";
|
|
my $sth = $dbh->prepare($query);
|
|
$sth->execute(
|
|
$prof_id, $printername, $paper_bin, $tmpl_id, $offset_horz,
|
|
$offset_vert, $creep_horz, $creep_vert, $units
|
|
);
|
|
my $error = $sth->errstr;
|
|
$sth->finish;
|
|
return $error;
|
|
}
|
|
|
|
=head2 DeleteProfile;
|
|
|
|
DeleteProfile(prof_id)
|
|
|
|
When passed a profile id, this function deletes that profile from the database and returns any errors.
|
|
|
|
=cut
|
|
|
|
sub DeleteProfile {
|
|
my ($prof_id) = @_;
|
|
my $dbh = C4::Context->dbh;
|
|
my $query = " DELETE FROM printers_profile WHERE prof_id = ?";
|
|
my $sth = $dbh->prepare($query);
|
|
$sth->execute($prof_id);
|
|
my $error = $sth->errstr;
|
|
$sth->finish;
|
|
return $error;
|
|
}
|
|
|
|
=head2 GetAssociatedProfile;
|
|
|
|
$assoc_prof = GetAssociatedProfile(tmpl_id)
|
|
|
|
When passed a template id, this function returns the parameters from the currently associated printer profile
|
|
in a hashref where key=fieldname and value=fieldvalue.
|
|
|
|
=cut
|
|
|
|
sub GetAssociatedProfile {
|
|
my ($tmpl_id) = @_;
|
|
my $dbh = C4::Context->dbh;
|
|
# First we find out the prof_id for the associated profile...
|
|
my $query = "SELECT * FROM labels_profile WHERE tmpl_id = ?";
|
|
my $sth = $dbh->prepare($query);
|
|
$sth->execute($tmpl_id);
|
|
my $assoc_prof = $sth->fetchrow_hashref;
|
|
$sth->finish;
|
|
# Then we retrieve that profile and return it to the caller...
|
|
$assoc_prof = GetSinglePrinterProfile($assoc_prof->{'prof_id'});
|
|
return $assoc_prof;
|
|
}
|
|
|
|
=head2 SetAssociatedProfile;
|
|
|
|
SetAssociatedProfile($prof_id, $tmpl_id)
|
|
|
|
When passed both a profile id and template id, this function establishes an association between the two. No more
|
|
than one profile may be associated with any given template at the same time.
|
|
|
|
=cut
|
|
|
|
sub SetAssociatedProfile {
|
|
|
|
my ($prof_id, $tmpl_id) = @_;
|
|
|
|
my $dbh = C4::Context->dbh;
|
|
my $query = "INSERT INTO labels_profile (prof_id, tmpl_id) VALUES (?,?) ON DUPLICATE KEY UPDATE prof_id = ?";
|
|
my $sth = $dbh->prepare($query);
|
|
$sth->execute($prof_id, $tmpl_id, $prof_id);
|
|
$sth->finish;
|
|
}
|
|
|
|
|
|
=head2 GetLabelItems;
|
|
|
|
$options = GetLabelItems()
|
|
|
|
Returns an array of references-to-hash, whos keys are the fields from the biblio, biblioitems, items and labels tables in the Koha database.
|
|
|
|
=cut
|
|
|
|
sub GetLabelItems {
|
|
my ($batch_id) = @_;
|
|
my $dbh = C4::Context->dbh;
|
|
|
|
my @resultsloop = ();
|
|
my $count;
|
|
my @data;
|
|
my $sth;
|
|
|
|
if ($batch_id) {
|
|
my $query3 = "
|
|
SELECT *
|
|
FROM labels
|
|
WHERE batch_id = ?
|
|
ORDER BY labelid";
|
|
$sth = $dbh->prepare($query3);
|
|
$sth->execute($batch_id);
|
|
}
|
|
else {
|
|
my $query3 = "
|
|
SELECT *
|
|
FROM labels";
|
|
$sth = $dbh->prepare($query3);
|
|
$sth->execute();
|
|
}
|
|
my $cnt = $sth->rows;
|
|
my $i1 = 1;
|
|
while ( my $data = $sth->fetchrow_hashref ) {
|
|
|
|
# lets get some summary info from each item
|
|
my $query1 =
|
|
# FIXME This makes for a very bulky data structure; data from tables w/duplicate col names also gets overwritten.
|
|
# Something like this, perhaps, but this also causes problems because we need more fields sometimes.
|
|
# SELECT i.barcode, i.itemcallnumber, i.itype, bi.isbn, bi.issn, b.title, b.author
|
|
"SELECT bi.*, i.*, b.*
|
|
FROM items AS i, biblioitems AS bi ,biblio AS b
|
|
WHERE itemnumber=? AND i.biblioitemnumber=bi.biblioitemnumber AND bi.biblionumber=b.biblionumber";
|
|
my $sth1 = $dbh->prepare($query1);
|
|
$sth1->execute( $data->{'itemnumber'} );
|
|
|
|
my $data1 = $sth1->fetchrow_hashref();
|
|
$data1->{'labelno'} = $i1;
|
|
$data1->{'labelid'} = $data->{'labelid'};
|
|
$data1->{'batch_id'} = $batch_id;
|
|
$data1->{'summary'} = "$data1->{'barcode'}, $data1->{'title'}, $data1->{'isbn'}";
|
|
|
|
push( @resultsloop, $data1 );
|
|
$sth1->finish;
|
|
|
|
$i1++;
|
|
}
|
|
$sth->finish;
|
|
return @resultsloop;
|
|
|
|
}
|
|
|
|
sub GetItemFields {
|
|
my @fields = qw (
|
|
barcode title
|
|
isbn issn
|
|
author itemtype
|
|
itemcallnumber
|
|
);
|
|
return @fields;
|
|
}
|
|
|
|
=head2 GetBarcodeData
|
|
|
|
=over 4
|
|
|
|
Parse labels_conf.formatstring value
|
|
(one value of the csv, which has already been split)
|
|
and return string from koha tables or MARC record.
|
|
|
|
=back
|
|
|
|
=cut
|
|
|
|
sub GetBarcodeData {
|
|
my ( $f, $item, $record ) = @_;
|
|
my $kohatables = &_descKohaTables();
|
|
my $datastring = '';
|
|
my $match_kohatable = join(
|
|
'|',
|
|
(
|
|
@{ $kohatables->{biblio} },
|
|
@{ $kohatables->{biblioitems} },
|
|
@{ $kohatables->{items} }
|
|
)
|
|
);
|
|
while ($f) {
|
|
$f =~ s/^\s?//;
|
|
if ( $f =~ /^'(.*)'.*/ ) {
|
|
# single quotes indicate a static text string.
|
|
$datastring .= $1;
|
|
$f = $';
|
|
}
|
|
elsif ( $f =~ /^($match_kohatable).*/ ) {
|
|
$datastring .= $item->{$f};
|
|
$f = $';
|
|
}
|
|
elsif ( $f =~ /^([0-9a-z]{3})(\w)(\W?).*?/ ) {
|
|
my ($field,$subf,$ws) = ($1,$2,$3);
|
|
my $subf_data;
|
|
my ($itemtag, $itemsubfieldcode) = &GetMarcFromKohaField("items.itemnumber",'');
|
|
my @marcfield = $record->field($field);
|
|
if(@marcfield) {
|
|
if($field eq $itemtag) { # item-level data, we need to get the right item.
|
|
foreach my $itemfield (@marcfield) {
|
|
if ( $itemfield->subfield($itemsubfieldcode) eq $item->{'itemnumber'} ) {
|
|
$datastring .= $itemfield->subfield($subf ) . $ws;
|
|
last;
|
|
}
|
|
}
|
|
} else { # bib-level data, we'll take the first matching tag/subfield.
|
|
$datastring .= $marcfield[0]->subfield($subf) . $ws ;
|
|
}
|
|
}
|
|
$f = $';
|
|
}
|
|
else {
|
|
warn "failed to parse label formatstring: $f";
|
|
last; # Failed to match
|
|
}
|
|
}
|
|
return $datastring;
|
|
}
|
|
|
|
=head2 descKohaTables
|
|
|
|
Return a hashref of an array of hashes,
|
|
with name,type keys.
|
|
|
|
=cut
|
|
|
|
sub _descKohaTables {
|
|
my $dbh = C4::Context->dbh();
|
|
my $kohatables;
|
|
for my $table ( 'biblio','biblioitems','items' ) {
|
|
my $sth = $dbh->column_info(undef,undef,$table,'%');
|
|
while (my $info = $sth->fetchrow_hashref()){
|
|
push @{$kohatables->{$table}} , $info->{'COLUMN_NAME'} ;
|
|
}
|
|
$sth->finish;
|
|
}
|
|
return $kohatables;
|
|
}
|
|
|
|
sub GetPatronCardItems {
|
|
|
|
my ( $batch_id ) = @_;
|
|
my @resultsloop;
|
|
|
|
my $dbh = C4::Context->dbh;
|
|
# my $query = "SELECT * FROM patroncards WHERE batch_id = ? ORDER BY borrowernumber";
|
|
my $query = "SELECT * FROM patroncards WHERE batch_id = ? ORDER BY cardid";
|
|
my $sth = $dbh->prepare($query);
|
|
$sth->execute($batch_id);
|
|
my $cardno = 1;
|
|
while ( my $data = $sth->fetchrow_hashref ) {
|
|
my $patron_data = GetMember( $data->{'borrowernumber'} );
|
|
$patron_data->{'branchname'} = GetBranchName( $patron_data->{'branchcode'} );
|
|
$patron_data->{'cardno'} = $cardno;
|
|
$patron_data->{'cardid'} = $data->{'cardid'};
|
|
$patron_data->{'batch_id'} = $batch_id;
|
|
push( @resultsloop, $patron_data );
|
|
$cardno++;
|
|
}
|
|
$sth->finish;
|
|
return @resultsloop;
|
|
|
|
}
|
|
|
|
sub deduplicate_batch {
|
|
my ( $batch_id, $batch_type ) = @_;
|
|
my $query = "
|
|
SELECT DISTINCT
|
|
batch_id," . (($batch_type eq 'labels') ? 'itemnumber' : 'borrowernumber') . ",
|
|
count(". (($batch_type eq 'labels') ? 'labelid' : 'cardid') . ") as count
|
|
FROM $batch_type
|
|
WHERE batch_id = ?
|
|
GROUP BY " . (($batch_type eq 'labels') ? 'itemnumber' : 'borrowernumber') . ",batch_id
|
|
HAVING count > 1
|
|
ORDER BY batch_id,
|
|
count DESC ";
|
|
my $sth = C4::Context->dbh->prepare($query);
|
|
$sth->execute($batch_id);
|
|
warn $sth->errstr if $sth->errstr;
|
|
$sth->rows or return undef, $sth->errstr;
|
|
|
|
my $del_query = "
|
|
DELETE
|
|
FROM $batch_type
|
|
WHERE batch_id = ?
|
|
AND " . (($batch_type eq 'labels') ? 'itemnumber' : 'borrowernumber') . " = ?
|
|
ORDER BY timestamp ASC
|
|
";
|
|
my $killed = 0;
|
|
while (my $data = $sth->fetchrow_hashref()) {
|
|
my $itemnumber = $data->{(($batch_type eq 'labels') ? 'itemnumber' : 'borrowernumber')} or next;
|
|
my $limit = $data->{count} - 1 or next;
|
|
my $sth2 = C4::Context->dbh->prepare("$del_query LIMIT $limit");
|
|
# die sprintf "$del_query LIMIT %s\n (%s, %s)", $limit, $batch_id, $itemnumber;
|
|
# $sth2->execute($batch_id, C4::Context->dbh->quote($data->{itemnumber}), $data->{count} - 1)
|
|
$sth2->execute($batch_id, $itemnumber) and
|
|
$killed += ($data->{count} - 1);
|
|
warn $sth2->errstr if $sth2->errstr;
|
|
}
|
|
return $killed, undef;
|
|
}
|
|
|
|
sub split_lccn {
|
|
my ($lccn) = @_;
|
|
my ($ll, $wnl, $dec, $cutter, $pubdate) = (0, 0, 0, 0, 0);
|
|
$_ = $lccn;
|
|
# lccn example 'HE8700.7 .P6T44 1983';
|
|
my @splits = m/
|
|
(^[a-zA-Z]+) # HE
|
|
([0-9]+\.*[0-9]*) # 8700.7
|
|
\s*
|
|
(\.*[a-zA-Z0-9]*) # P6T44
|
|
\s*
|
|
([0-9]*) # 1983
|
|
/x;
|
|
|
|
# strip something occuring spaces too
|
|
$splits[0] =~ s/\s+$//;
|
|
$splits[1] =~ s/\s+$//;
|
|
$splits[2] =~ s/\s+$//;
|
|
|
|
return @splits;
|
|
}
|
|
|
|
sub split_ddcn {
|
|
my ($ddcn) = @_;
|
|
$ddcn =~ s/\///g; # in theory we should be able to simply remove all segmentation markers and arrive at the correct call number...
|
|
$_ = $ddcn;
|
|
# ddcn example R220.3 H2793Z H32 c.2
|
|
my @splits = m/^([A-Z]{0,3}) # R (OS, REF, etc. up do three letters)
|
|
([0-9]+\.[0-9]*) # 220.3
|
|
\s? # space (not requiring anything beyond the call number)
|
|
([a-zA-Z0-9]*\.?[a-zA-Z0-9])# cutter number... maybe, but if so it is in this position (Z indicates literary criticism)
|
|
\s? # space if it exists
|
|
([a-zA-Z]*\.?[0-9]*) # other indicators such as cutter for author of literary criticism in this example if it exists
|
|
\s? # space if ie exists
|
|
([a-zA-Z]*\.?[0-9]*) # other indicators such as volume number, copy number, edition date, etc. if it exists
|
|
/x;
|
|
return @splits;
|
|
}
|
|
|
|
sub split_fcn {
|
|
my ($fcn) = @_;
|
|
my @fcn_split = ();
|
|
# Split fiction call numbers based on spaces
|
|
SPLIT_FCN:
|
|
while ($fcn) {
|
|
if ($fcn =~ m/([A-Za-z0-9]+)(\W?).*?/x) {
|
|
push (@fcn_split, $1);
|
|
$fcn = $';
|
|
}
|
|
else {
|
|
last SPLIT_FCN; # No match, break out of the loop
|
|
}
|
|
}
|
|
return @fcn_split;
|
|
}
|
|
|
|
sub DrawSpineText {
|
|
|
|
my ( $x_pos, $y_pos, $label_height, $label_width, $fontname, $fontsize, $left_text_margin,
|
|
$text_wrap_cols, $item, $conf_data, $printingtype ) = @_;
|
|
|
|
# Replaced item's itemtype with the more user-friendly description...
|
|
my $dbh = C4::Context->dbh;
|
|
my $sth = $dbh->prepare("SELECT itemtype,description FROM itemtypes");
|
|
$sth->execute();
|
|
while ( my $data = $sth->fetchrow_hashref ) {
|
|
$$item->{'itemtype'} = $data->{'description'} if ($$item->{'itemtype'} eq $data->{'itemtype'});
|
|
$$item->{'itype'} = $data->{'description'} if ($$item->{'itype'} eq $data->{'itemtype'});
|
|
}
|
|
|
|
my $str = '';
|
|
|
|
my $top_text_margin = ( $fontsize + 3 ); #FIXME: This should be a template parameter and passed in...
|
|
my $line_spacer = ( $fontsize * 1 ); # number of pixels between text rows (This is actually leading: baseline to baseline minus font size. Recommended starting point is 20% of font size.).
|
|
|
|
my $layout_id = $$conf_data->{'id'};
|
|
|
|
my $vPos = ( $y_pos + ( $label_height - $top_text_margin ) );
|
|
|
|
my @str_fields = get_text_fields($layout_id, 'codes' );
|
|
my $record = GetMarcBiblio($$item->{biblionumber});
|
|
# FIXME - returns all items, so you can't get data from an embedded holdings field.
|
|
# TODO - add a GetMarcBiblio1item(bibnum,itemnum) or a GetMarcItem(itemnum).
|
|
|
|
my $old_fontname = $fontname; # We need to keep track of the original font passed in...
|
|
|
|
# Grab the cn_source and if that is NULL, the DefaultClassificationSource syspref
|
|
my $cn_source = ($$item->{'cn_source'} ? $$item->{'cn_source'} : C4::Context->preference('DefaultClassificationSource'));
|
|
for my $field (@str_fields) {
|
|
$field->{'code'} or warn "get_text_fields($layout_id, 'codes') element missing 'code' field";
|
|
if ($field->{'code'} eq 'itemtype') {
|
|
$field->{'data'} = C4::Context->preference('item-level_itypes') ? $$item->{'itype'} : $$item->{'itemtype'};
|
|
}
|
|
elsif ($$conf_data->{'formatstring'}) {
|
|
# if labels_conf.formatstring has a value, then it overrides the hardcoded option.
|
|
$field->{'data'} = GetBarcodeData($field->{'code'},$$item,$record) ;
|
|
}
|
|
else {
|
|
$field->{data} = $$item->{$field->{'code'}} ;
|
|
}
|
|
# This allows us to print the title in italic (oblique) type... (Times Roman has a different nomenclature.)
|
|
# It seems there should be a better way to handle fonts in the label/patron card tool altogether -fbcit
|
|
($field->{code} eq 'title') ? (($old_fontname =~ /T/) ? ($fontname = 'TI') : ($fontname = ($old_fontname . 'O'))) : ($fontname = $old_fontname);
|
|
my $font = prFont($fontname);
|
|
# if the display option for this field is selected in the DB,
|
|
# and the item record has some values for this field, display it.
|
|
# Or if there is a csv list of fields to display, display them.
|
|
if ( ($$conf_data->{'formatstring'}) || ( $$conf_data->{$field->{code}} && $$item->{$field->{code}} ) ) {
|
|
# get the string
|
|
my $str = $field->{data} ;
|
|
# strip out naughty existing nl/cr's
|
|
$str =~ s/\n//g;
|
|
$str =~ s/\r//g;
|
|
my @strings;
|
|
my @callnumber_list = ('itemcallnumber', '050a', '050b', '082a', '952o'); # Fields which hold call number data ( 060? 090? 092? 099? )
|
|
if ((grep {$field->{code} =~ m/$_/} @callnumber_list) and ($printingtype eq 'BIB') and ($$conf_data->{'callnum_split'})) { # If the field contains the call number, we do some sp
|
|
if ($cn_source eq 'lcc') {
|
|
@strings = split_lccn($str);
|
|
@strings = split_fcn($str) if !@strings; # If it was not a true lccn, try it as a fiction call number
|
|
push (@strings, $str) if !@strings; # If it was not that, send it on unsplit
|
|
} elsif ($cn_source eq 'ddc') {
|
|
@strings = split_ddcn($str);
|
|
@strings = split_fcn($str) if !@strings;
|
|
push (@strings, $str) if !@strings;
|
|
} else {
|
|
# FIXME Need error trapping here; something to be informative to the user perhaps -crn
|
|
push @strings, $str;
|
|
}
|
|
} else {
|
|
$str =~ s/\/$//g; # Here we will strip out all trailing '/' in fields other than the call number...
|
|
$str =~ s/\(/\\\(/g; # Escape '(' and ')' for the postscript stream...
|
|
$str =~ s/\)/\\\)/g;
|
|
# Wrap text lines exceeding $text_wrap_cols length...
|
|
$Text::Wrap::columns = $text_wrap_cols;
|
|
my @line = split(/\n/ ,wrap('', '', $str));
|
|
# If this is a title field, limit to two lines; all others limit to one...
|
|
if ($field->{code} eq 'title' && scalar(@line) >= 2) {
|
|
while (scalar(@line) > 2) {
|
|
pop @line;
|
|
}
|
|
} else {
|
|
while (scalar(@line) > 1) {
|
|
pop @line;
|
|
}
|
|
}
|
|
push(@strings, @line);
|
|
}
|
|
# loop for each string line
|
|
foreach my $str (@strings) {
|
|
my $hPos = 0;
|
|
my $stringwidth = prStrWidth($str, $fontname, $fontsize);
|
|
if ( $$conf_data->{'text_justify'} eq 'R' ) {
|
|
$hPos = $x_pos + $label_width - ( $left_text_margin + $stringwidth );
|
|
} elsif($$conf_data->{'text_justify'} eq 'C') {
|
|
# some code to try and center each line on the label based on font size and string point width...
|
|
my $whitespace = ( $label_width - ( $stringwidth + (2 * $left_text_margin) ) );
|
|
$hPos = ( ( $whitespace / 2 ) + $x_pos + $left_text_margin );
|
|
#warn "\$label_width=$label_width \$stringwidth=$stringwidth \$whitespace=$whitespace \$left_text_margin=$left_text_margin for $str\n";
|
|
} else {
|
|
$hPos = ( $x_pos + $left_text_margin );
|
|
}
|
|
PrintText( $hPos, $vPos, $font, $fontsize, $str );
|
|
$vPos = $vPos - $line_spacer;
|
|
}
|
|
}
|
|
} #foreach field
|
|
}
|
|
|
|
sub PrintText {
|
|
my ( $hPos, $vPos, $font, $fontsize, $text ) = @_;
|
|
my $str = "BT /$font $fontsize Tf $hPos $vPos Td ($text) Tj ET";
|
|
prAdd($str);
|
|
}
|
|
|
|
sub DrawPatronCardText {
|
|
|
|
my ( $x_pos, $y_pos, $label_height, $label_width, $fontname, $fontsize, $left_text_margin,
|
|
$text_wrap_cols, $text, $printingtype )
|
|
= @_;
|
|
|
|
my $top_text_margin = 25; #FIXME: This should be a template parameter and passed in...
|
|
|
|
my $vPos = ( $y_pos + ( $label_height - $top_text_margin ) );
|
|
my $font = prFont($fontname);
|
|
|
|
my $hPos = 0;
|
|
|
|
foreach my $line (keys %$text) {
|
|
$debug and warn "Current text is \"$line\" and font size for \"$line\" is $text->{$line} points";
|
|
# some code to try and center each line on the label based on font size and string point width...
|
|
my $stringwidth = prStrWidth($line, $fontname, $text->{$line});
|
|
my $whitespace = ( $label_width - ( $stringwidth + (2 * $left_text_margin) ) );
|
|
$hPos = ( ( $whitespace / 2 ) + $x_pos + $left_text_margin );
|
|
|
|
PrintText( $hPos, $vPos, $font, $text->{$line}, $line );
|
|
my $line_spacer = ( $text->{$line} * 1 ); # number of pixels between text rows (This is actually leading: baseline to baseline minus font size. Recommended starting point is 20% (0.20) of font size.).
|
|
$vPos = $vPos - ($line_spacer + $text->{$line}); # Linefeed equiv: leading + font size
|
|
}
|
|
}
|
|
|
|
# Not used anywhere.
|
|
|
|
#sub SetFontSize {
|
|
#
|
|
# my ($fontsize) = @_;
|
|
#### fontsize
|
|
# my $str = "BT/F13 30 Tf288 720 Td( AAAAAAAAAA ) TjET";
|
|
# prAdd($str);
|
|
#}
|
|
|
|
sub DrawBarcode {
|
|
|
|
# x and y are from the top-left :)
|
|
my ( $x_pos, $y_pos, $height, $width, $barcode, $barcodetype ) = @_;
|
|
my $num_of_bars = length($barcode);
|
|
my $bar_width = $width * .8; # %80 of length of label width
|
|
my $tot_bar_length = 0;
|
|
my $bar_length = 0;
|
|
my $guard_length = 10;
|
|
my $xsize_ratio = 0;
|
|
|
|
if ( $barcodetype eq 'CODE39' ) {
|
|
$bar_length = '17.5';
|
|
$tot_bar_length =
|
|
( $bar_length * $num_of_bars ) + ( $guard_length * 2 );
|
|
$xsize_ratio = ( $bar_width / $tot_bar_length );
|
|
eval {
|
|
PDF::Reuse::Barcode::Code39(
|
|
x => ( $x_pos + ( $width / 10 ) ),
|
|
y => ( $y_pos + ( $height / 10 ) ),
|
|
value => "*$barcode*",
|
|
ySize => ( .02 * $height ),
|
|
xSize => $xsize_ratio,
|
|
hide_asterisk => 1,
|
|
);
|
|
};
|
|
if ($@) {
|
|
warn "$barcodetype, $barcode FAILED:$@";
|
|
}
|
|
}
|
|
|
|
elsif ( $barcodetype eq 'CODE39MOD' ) {
|
|
|
|
# get modulo43 checksum
|
|
my $c39 = CheckDigits('code_39');
|
|
$barcode = $c39->complete($barcode);
|
|
|
|
$bar_length = '19';
|
|
$tot_bar_length =
|
|
( $bar_length * $num_of_bars ) + ( $guard_length * 2 );
|
|
$xsize_ratio = ( $bar_width / $tot_bar_length );
|
|
eval {
|
|
PDF::Reuse::Barcode::Code39(
|
|
x => ( $x_pos + ( $width / 10 ) ),
|
|
y => ( $y_pos + ( $height / 10 ) ),
|
|
value => "*$barcode*",
|
|
ySize => ( .02 * $height ),
|
|
xSize => $xsize_ratio,
|
|
hide_asterisk => 1,
|
|
);
|
|
};
|
|
|
|
if ($@) {
|
|
warn "$barcodetype, $barcode FAILED:$@";
|
|
}
|
|
}
|
|
elsif ( $barcodetype eq 'CODE39MOD10' ) {
|
|
|
|
# get modulo43 checksum
|
|
my $c39_10 = CheckDigits('visa');
|
|
$barcode = $c39_10->complete($barcode);
|
|
|
|
$bar_length = '19';
|
|
$tot_bar_length =
|
|
( $bar_length * $num_of_bars ) + ( $guard_length * 2 );
|
|
$xsize_ratio = ( $bar_width / $tot_bar_length );
|
|
eval {
|
|
PDF::Reuse::Barcode::Code39(
|
|
x => ( $x_pos + ( $width / 10 ) ),
|
|
y => ( $y_pos + ( $height / 10 ) ),
|
|
value => "*$barcode*",
|
|
ySize => ( .02 * $height ),
|
|
xSize => $xsize_ratio,
|
|
hide_asterisk => 1,
|
|
text => 0,
|
|
);
|
|
};
|
|
|
|
if ($@) {
|
|
warn "$barcodetype, $barcode FAILED:$@";
|
|
}
|
|
}
|
|
|
|
|
|
elsif ( $barcodetype eq 'COOP2OF5' ) {
|
|
$bar_length = '9.43333333333333';
|
|
$tot_bar_length =
|
|
( $bar_length * $num_of_bars ) + ( $guard_length * 2 );
|
|
$xsize_ratio = ( $bar_width / $tot_bar_length ) * .9;
|
|
eval {
|
|
PDF::Reuse::Barcode::COOP2of5(
|
|
x => ( $x_pos + ( $width / 10 ) ),
|
|
y => ( $y_pos + ( $height / 10 ) ),
|
|
value => $barcode,
|
|
ySize => ( .02 * $height ),
|
|
xSize => $xsize_ratio,
|
|
);
|
|
};
|
|
if ($@) {
|
|
warn "$barcodetype, $barcode FAILED:$@";
|
|
}
|
|
}
|
|
|
|
elsif ( $barcodetype eq 'INDUSTRIAL2OF5' ) {
|
|
$bar_length = '13.1333333333333';
|
|
$tot_bar_length =
|
|
( $bar_length * $num_of_bars ) + ( $guard_length * 2 );
|
|
$xsize_ratio = ( $bar_width / $tot_bar_length ) * .9;
|
|
eval {
|
|
PDF::Reuse::Barcode::Industrial2of5(
|
|
x => ( $x_pos + ( $width / 10 ) ),
|
|
y => ( $y_pos + ( $height / 10 ) ),
|
|
value => $barcode,
|
|
ySize => ( .02 * $height ),
|
|
xSize => $xsize_ratio,
|
|
);
|
|
};
|
|
if ($@) {
|
|
warn "$barcodetype, $barcode FAILED:$@";
|
|
}
|
|
}
|
|
|
|
my $moo2 = $tot_bar_length * $xsize_ratio;
|
|
|
|
warn "$x_pos, $y_pos, $barcode, $barcodetype" if $debug;
|
|
warn "BAR_WDTH = $bar_width, TOT.BAR.LGHT=$tot_bar_length R*TOT.BAR =$moo2" if $debug;
|
|
}
|
|
|
|
=head2 build_circ_barcode;
|
|
|
|
build_circ_barcode( $x_pos, $y_pos, $barcode,
|
|
$barcodetype, \$item);
|
|
|
|
$item is the result of a previous call to GetLabelItems();
|
|
|
|
=cut
|
|
|
|
#'
|
|
sub build_circ_barcode {
|
|
my ( $x_pos_circ, $y_pos, $value, $barcodetype, $item ) = @_;
|
|
|
|
#warn Dumper \$item;
|
|
|
|
#warn "value = $value\n";
|
|
|
|
#$DB::single = 1;
|
|
|
|
if ( $barcodetype eq 'EAN13' ) {
|
|
|
|
#testing EAN13 barcodes hack
|
|
$value = $value . '000000000';
|
|
$value =~ s/-//;
|
|
$value = substr( $value, 0, 12 );
|
|
|
|
#warn $value;
|
|
eval {
|
|
PDF::Reuse::Barcode::EAN13(
|
|
x => ( $x_pos_circ + 27 ),
|
|
y => ( $y_pos + 15 ),
|
|
value => $value,
|
|
|
|
# prolong => 2.96,
|
|
# xSize => 1.5,
|
|
|
|
# ySize => 1.2,
|
|
|
|
# added for xpdf compat. doesnt use type3 fonts., but increases filesize from 20k to 200k
|
|
# i think its embedding extra fonts in the pdf file.
|
|
# mode => 'graphic',
|
|
);
|
|
};
|
|
if ($@) {
|
|
$item->{'barcodeerror'} = 1;
|
|
|
|
#warn "EAN13BARCODE FAILED:$@";
|
|
}
|
|
|
|
#warn $barcodetype;
|
|
|
|
}
|
|
elsif ( $barcodetype eq 'Code39' ) {
|
|
|
|
eval {
|
|
PDF::Reuse::Barcode::Code39(
|
|
x => ( $x_pos_circ + 9 ),
|
|
y => ( $y_pos + 15 ),
|
|
value => $value,
|
|
|
|
# prolong => 2.96,
|
|
xSize => .85,
|
|
|
|
ySize => 1.3,
|
|
);
|
|
};
|
|
if ($@) {
|
|
$item->{'barcodeerror'} = 1;
|
|
|
|
#warn "CODE39BARCODE $value FAILED:$@";
|
|
}
|
|
|
|
#warn $barcodetype;
|
|
|
|
}
|
|
|
|
elsif ( $barcodetype eq 'Matrix2of5' ) {
|
|
|
|
#warn "MATRIX ELSE:";
|
|
|
|
#testing MATRIX25 barcodes hack
|
|
# $value = $value.'000000000';
|
|
$value =~ s/-//;
|
|
|
|
# $value = substr( $value, 0, 12 );
|
|
#warn $value;
|
|
|
|
eval {
|
|
PDF::Reuse::Barcode::Matrix2of5(
|
|
x => ( $x_pos_circ + 27 ),
|
|
y => ( $y_pos + 15 ),
|
|
value => $value,
|
|
|
|
# prolong => 2.96,
|
|
# xSize => 1.5,
|
|
|
|
# ySize => 1.2,
|
|
);
|
|
};
|
|
if ($@) {
|
|
$item->{'barcodeerror'} = 1;
|
|
|
|
#warn "BARCODE FAILED:$@";
|
|
}
|
|
|
|
#warn $barcodetype;
|
|
|
|
}
|
|
|
|
elsif ( $barcodetype eq 'EAN8' ) {
|
|
|
|
#testing ean8 barcodes hack
|
|
$value = $value . '000000000';
|
|
$value =~ s/-//;
|
|
$value = substr( $value, 0, 8 );
|
|
|
|
#warn $value;
|
|
|
|
#warn "EAN8 ELSEIF";
|
|
eval {
|
|
PDF::Reuse::Barcode::EAN8(
|
|
x => ( $x_pos_circ + 42 ),
|
|
y => ( $y_pos + 15 ),
|
|
value => $value,
|
|
prolong => 2.96,
|
|
xSize => 1.5,
|
|
|
|
# ySize => 1.2,
|
|
);
|
|
};
|
|
|
|
if ($@) {
|
|
$item->{'barcodeerror'} = 1;
|
|
|
|
#warn "BARCODE FAILED:$@";
|
|
}
|
|
|
|
#warn $barcodetype;
|
|
|
|
}
|
|
|
|
elsif ( $barcodetype eq 'UPC-E' ) {
|
|
eval {
|
|
PDF::Reuse::Barcode::UPCE(
|
|
x => ( $x_pos_circ + 27 ),
|
|
y => ( $y_pos + 15 ),
|
|
value => $value,
|
|
prolong => 2.96,
|
|
xSize => 1.5,
|
|
|
|
# ySize => 1.2,
|
|
);
|
|
};
|
|
|
|
if ($@) {
|
|
$item->{'barcodeerror'} = 1;
|
|
|
|
#warn "BARCODE FAILED:$@";
|
|
}
|
|
|
|
#warn $barcodetype;
|
|
|
|
}
|
|
elsif ( $barcodetype eq 'NW7' ) {
|
|
eval {
|
|
PDF::Reuse::Barcode::NW7(
|
|
x => ( $x_pos_circ + 27 ),
|
|
y => ( $y_pos + 15 ),
|
|
value => $value,
|
|
prolong => 2.96,
|
|
xSize => 1.5,
|
|
|
|
# ySize => 1.2,
|
|
);
|
|
};
|
|
|
|
if ($@) {
|
|
$item->{'barcodeerror'} = 1;
|
|
|
|
#warn "BARCODE FAILED:$@";
|
|
}
|
|
|
|
#warn $barcodetype;
|
|
|
|
}
|
|
elsif ( $barcodetype eq 'ITF' ) {
|
|
eval {
|
|
PDF::Reuse::Barcode::ITF(
|
|
x => ( $x_pos_circ + 27 ),
|
|
y => ( $y_pos + 15 ),
|
|
value => $value,
|
|
prolong => 2.96,
|
|
xSize => 1.5,
|
|
|
|
# ySize => 1.2,
|
|
);
|
|
};
|
|
|
|
if ($@) {
|
|
$item->{'barcodeerror'} = 1;
|
|
|
|
#warn "BARCODE FAILED:$@";
|
|
}
|
|
|
|
#warn $barcodetype;
|
|
|
|
}
|
|
elsif ( $barcodetype eq 'Industrial2of5' ) {
|
|
eval {
|
|
PDF::Reuse::Barcode::Industrial2of5(
|
|
x => ( $x_pos_circ + 27 ),
|
|
y => ( $y_pos + 15 ),
|
|
value => $value,
|
|
prolong => 2.96,
|
|
xSize => 1.5,
|
|
|
|
# ySize => 1.2,
|
|
);
|
|
};
|
|
if ($@) {
|
|
$item->{'barcodeerror'} = 1;
|
|
|
|
#warn "BARCODE FAILED:$@";
|
|
}
|
|
|
|
#warn $barcodetype;
|
|
|
|
}
|
|
elsif ( $barcodetype eq 'IATA2of5' ) {
|
|
eval {
|
|
PDF::Reuse::Barcode::IATA2of5(
|
|
x => ( $x_pos_circ + 27 ),
|
|
y => ( $y_pos + 15 ),
|
|
value => $value,
|
|
prolong => 2.96,
|
|
xSize => 1.5,
|
|
|
|
# ySize => 1.2,
|
|
);
|
|
};
|
|
if ($@) {
|
|
$item->{'barcodeerror'} = 1;
|
|
|
|
#warn "BARCODE FAILED:$@";
|
|
}
|
|
|
|
#warn $barcodetype;
|
|
|
|
}
|
|
|
|
elsif ( $barcodetype eq 'COOP2of5' ) {
|
|
eval {
|
|
PDF::Reuse::Barcode::COOP2of5(
|
|
x => ( $x_pos_circ + 27 ),
|
|
y => ( $y_pos + 15 ),
|
|
value => $value,
|
|
prolong => 2.96,
|
|
xSize => 1.5,
|
|
|
|
# ySize => 1.2,
|
|
);
|
|
};
|
|
if ($@) {
|
|
$item->{'barcodeerror'} = 1;
|
|
|
|
#warn "BARCODE FAILED:$@";
|
|
}
|
|
|
|
#warn $barcodetype;
|
|
|
|
}
|
|
elsif ( $barcodetype eq 'UPC-A' ) {
|
|
|
|
eval {
|
|
PDF::Reuse::Barcode::UPCA(
|
|
x => ( $x_pos_circ + 27 ),
|
|
y => ( $y_pos + 15 ),
|
|
value => $value,
|
|
prolong => 2.96,
|
|
xSize => 1.5,
|
|
|
|
# ySize => 1.2,
|
|
);
|
|
};
|
|
if ($@) {
|
|
$item->{'barcodeerror'} = 1;
|
|
|
|
#warn "BARCODE FAILED:$@";
|
|
}
|
|
|
|
#warn $barcodetype;
|
|
|
|
}
|
|
|
|
}
|
|
|
|
=head2 draw_boundaries
|
|
|
|
sub draw_boundaries ($x_pos_spine, $x_pos_circ1, $x_pos_circ2,
|
|
$y_pos, $spine_width, $label_height, $circ_width)
|
|
|
|
This sub draws boundary lines where the label outlines are, to aid in printer testing, and debugging.
|
|
|
|
=cut
|
|
|
|
#'
|
|
sub draw_boundaries {
|
|
|
|
my (
|
|
$x_pos_spine, $x_pos_circ1, $x_pos_circ2, $y_pos,
|
|
$spine_width, $label_height, $circ_width
|
|
) = @_;
|
|
|
|
my $y_pos_initial = ( ( 792 - 36 ) - 90 );
|
|
$y_pos = $y_pos_initial; # FIXME - why are we ignoring the y_pos parameter by redefining it?
|
|
my $i = 1;
|
|
|
|
for ( $i = 1 ; $i <= 8 ; $i++ ) {
|
|
|
|
&drawbox( $x_pos_spine, $y_pos, ($spine_width), ($label_height) );
|
|
|
|
#warn "OLD BOXES x=$x_pos_spine, y=$y_pos, w=$spine_width, h=$label_height";
|
|
&drawbox( $x_pos_circ1, $y_pos, ($circ_width), ($label_height) );
|
|
&drawbox( $x_pos_circ2, $y_pos, ($circ_width), ($label_height) );
|
|
|
|
$y_pos = ( $y_pos - $label_height );
|
|
|
|
}
|
|
}
|
|
|
|
=head2 drawbox
|
|
|
|
sub drawbox { $lower_left_x, $lower_left_y,
|
|
$upper_right_x, $upper_right_y )
|
|
|
|
this is a low level sub, that draws a pdf box, it is called by draw_boxes
|
|
|
|
FYI: the $upper_right_x and $upper_right_y values are RELATIVE to $lower_left_x and $lower_left_y
|
|
|
|
and $lower_left_x, $lower_left_y are ABSOLUTE, this caught me out!
|
|
|
|
=cut
|
|
|
|
#'
|
|
sub drawbox {
|
|
my ( $llx, $lly, $urx, $ury ) = @_;
|
|
|
|
# warn "llx,y= $llx,$lly , urx,y=$urx,$ury \n";
|
|
|
|
my $str = "q\n"; # save the graphic state
|
|
$str .= "0.5 w\n"; # border color red
|
|
$str .= "1.0 0.0 0.0 RG\n"; # border color red
|
|
# $str .= "0.5 0.75 1.0 rg\n"; # fill color blue
|
|
$str .= "1.0 1.0 1.0 rg\n"; # fill color white
|
|
|
|
$str .= "$llx $lly $urx $ury re\n"; # a rectangle
|
|
$str .= "B\n"; # fill (and a little more)
|
|
$str .= "Q\n"; # save the graphic state
|
|
|
|
prAdd($str);
|
|
|
|
}
|
|
|
|
END { } # module clean-up code here (global destructor)
|
|
|
|
1;
|
|
__END__
|
|
|
|
=head1 AUTHOR
|
|
|
|
Mason James <mason@katipo.co.nz>
|
|
|
|
=cut
|
|
|