C4/Labels.pm

   1 package C4::Labels;
   2
   3 # Copyright 2006 Katipo Communications.
   4 #
   5 # This file is part of Koha.
   6 #
   7 # Koha is free software; you can redistribute it and/or modify it under the
   8 # terms of the GNU General Public License as published by the Free Software
   9 # Foundation; either version 2 of the License, or (at your option) any later
  10 # version.
  11 #
  12 # Koha is distributed in the hope that it will be useful, but WITHOUT ANY
  13 # WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR
  14 # A PARTICULAR PURPOSE.  See the GNU General Public License for more details.
  15 #
  16 # You should have received a copy of the GNU General Public License along with
  17 # Koha; if not, write to the Free Software Foundation, Inc., 59 Temple Place,
  18 # Suite 330, Boston, MA  02111-1307 USA
  19
  20 use strict;
  21 use vars qw($VERSION @ISA @EXPORT);
  22
  23 use PDF::Reuse;
  24 use Text::Wrap;
  25 use Algorithm::CheckDigits;
  26 use C4::Members;
  27 use C4::Branch;
  28 # use Data::Dumper;
  29 # use Smart::Comments;
  30
  31 BEGIN {
  32         $VERSION = 0.03;
  33         require Exporter;
  34         @ISA    = qw(Exporter);
  35         @EXPORT = qw(
  36                 &get_label_options &GetLabelItems
  37                 &build_circ_barcode &draw_boundaries
  38                 &drawbox &GetActiveLabelTemplate
  39                 &GetAllLabelTemplates &DeleteTemplate
  40                 &GetSingleLabelTemplate &SaveTemplate
  41                 &CreateTemplate &SetActiveTemplate
  42                 &SaveConf &DrawSpineText &GetTextWrapCols
  43                 &GetUnitsValue &DrawBarcode &DrawPatronCardText
  44                 &get_printingtypes &GetPatronCardItems
  45                 &get_layouts
  46                 &get_barcode_types
  47                 &get_batches &delete_batch
  48                 &add_batch &printText
  49                 &GetItemFields
  50                 &get_text_fields
  51                 get_layout &save_layout &add_layout
  52                 &set_active_layout &by_order
  53                 &build_text_dropbox
  54                 &delete_layout &get_active_layout
  55                 &get_highest_batch
  56                 &deduplicate_batch
  57                 &GetAllPrinterProfiles &GetSinglePrinterProfile
  58                 &SaveProfile &CreateProfile &DeleteProfile
  59                 &GetAssociatedProfile &SetAssociatedProfile
  60         );
  61 }
  62
  63 my $DEBUG = 0;
  64
  65 =head1 NAME
  66
  67 C4::Labels - Functions for printing spine labels and barcodes in Koha
  68
  69 =head1 FUNCTIONS
  70
  71 =over 2
  72
  73 =item get_label_options;
  74
  75         $options = get_label_options()
  76
  77 Return a pointer on a hash list containing info from labels_conf table in Koha DB.
  78
  79 =cut
  80
  81 #'
  82 sub get_label_options {
  83     my $dbh    = C4::Context->dbh;
  84     my $query2 = " SELECT * FROM labels_conf where active = 1";
  85     my $sth    = $dbh->prepare($query2);
  86     $sth->execute();
  87     my $conf_data = $sth->fetchrow_hashref;
  88     $sth->finish;
  89     return $conf_data;
  90 }
  91
  92 sub get_layouts {
  93
  94 ## FIXME: this if/else could be compacted...
  95     my $dbh = C4::Context->dbh;
  96     my @data;
  97     my $query = " Select * from labels_conf";
  98     my $sth   = $dbh->prepare($query);
  99     $sth->execute();
 100     my @resultsloop;
 101     while ( my $data = $sth->fetchrow_hashref ) {
 102
 103         $data->{'fieldlist'} = get_text_fields( $data->{'id'} );
 104         push( @resultsloop, $data );
 105     }
 106     $sth->finish;
 107
 108     # @resultsloop
 109
 110     return @resultsloop;
 111 }
 112
 113 sub get_layout {
 114     my ($layout_id) = @_;
 115     my $dbh = C4::Context->dbh;
 116
 117     # get the actual items to be printed.
 118     my $query = " Select * from labels_conf where id = ?";
 119     my $sth   = $dbh->prepare($query);
 120     $sth->execute($layout_id);
 121     my $data = $sth->fetchrow_hashref;
 122     $sth->finish;
 123     return $data;
 124 }
 125
 126 sub get_active_layout {
 127     my ($layout_id) = @_;
 128     my $dbh = C4::Context->dbh;
 129
 130     # get the actual items to be printed.
 131     my $query = " Select * from labels_conf where active = 1";
 132     my $sth   = $dbh->prepare($query);
 133     $sth->execute();
 134     my $data = $sth->fetchrow_hashref;
 135     $sth->finish;
 136     return $data;
 137 }
 138
 139 sub delete_layout {
 140     my ($layout_id) = @_;
 141     my $dbh = C4::Context->dbh;
 142
 143     # get the actual items to be printed.
 144     my $query = "delete from  labels_conf where id = ?";
 145     my $sth   = $dbh->prepare($query);
 146     $sth->execute($layout_id);
 147     $sth->finish;
 148 }
 149
 150 sub get_printingtypes {
 151     my ($layout_id) = @_;
 152     my @printtypes;
 153 # FIXME: hard coded print types
 154     push( @printtypes, { code => 'BAR',    desc => "barcode" } );
 155     push( @printtypes, { code => 'BIB',    desc => "biblio" } );
 156     push( @printtypes, { code => 'BARBIB', desc => "barcode / biblio" } );
 157     push( @printtypes, { code => 'BIBBAR', desc => "biblio / barcode" } );
 158     push( @printtypes, { code => 'ALT',    desc => "alternating labels" } );
 159     push( @printtypes, { code => 'PATCRD', desc => "patron cards" } );
 160
 161     my $conf             = get_layout($layout_id);
 162     my $active_printtype = $conf->{'printingtype'};
 163
 164     # lop thru layout, insert selected to hash
 165
 166     foreach my $printtype (@printtypes) {
 167         if ( $printtype->{'code'} eq $active_printtype ) {
 168             $printtype->{'active'} = 'MOO';
 169         }
 170     }
 171     return @printtypes;
 172 }
 173
 174 sub build_text_dropbox {
 175     my ($order) = @_;
 176
 177     #  my @fields      = get_text_fields();
 178     #    my $field_count = scalar @fields;
 179     my $field_count = 10;    # <-----------       FIXME hard coded
 180
 181     my @lines;
 182     !$order
 183       ? push( @lines, { num => '', selected => '1' } )
 184       : push( @lines, { num => '' } );
 185     for ( my $i = 1 ; $i <= $field_count ; $i++ ) {
 186         my $line = { num => "$i" };
 187         $line->{'selected'} = 1 if $i eq $order;
 188         push( @lines, $line );
 189     }
 190
 191     # add a blank row too
 192
 193     return @lines;
 194 }
 195
 196 sub get_text_fields {
 197     my ($layout_id, $sorttype) = @_;
 198
 199     my ( $a, $b, $c, $d, $e, $f, $g, $h, $i ,$j, $k );
 200
 201     my $sortorder = get_layout($layout_id);
 202
 203     # $sortorder
 204
 205     $a = {
 206         code  => 'itemtype',
 207         desc  => "Item Type",
 208         order => $sortorder->{'itemtype'}
 209     };
 210     $b = {
 211         code  => 'dewey',
 212         desc  => "Dewey",
 213         order => $sortorder->{'dewey'}
 214     };
 215     $c = { code => 'issn', desc => "ISSN",
 216         order => $sortorder->{'issn'} };
 217     $d = { code => 'isbn', desc => "ISBN",
 218             order => $sortorder->{'isbn'} };
 219     $e = {
 220         code  => 'class',
 221         desc  => "Classification",
 222         order => $sortorder->{'class'}
 223     };
 224     $f = {
 225         code  => 'subclass',
 226         desc  => "Sub-Class",
 227         order => $sortorder->{'subclass'}
 228     };
 229     $g = {
 230         code  => 'barcode',
 231         desc  => "Barcode",
 232         order => $sortorder->{'barcode'}
 233     };
 234     $h =
 235       { code => 'author', desc => "Author", order => $sortorder->{'author'} };
 236     $i = { code => 'title', desc => "Title", order => $sortorder->{'title'} };
 237     $j = { code => 'itemcallnumber', desc => "Call Number", order => $sortorder->{'itemcallnumber'} };
 238         $k = { code => 'subtitle', desc => "Subtitle", order => $sortorder->{'subtitle'} };
 239
 240         my @text_fields = ( $a, $b, $c, $d, $e, $f, $g, $h, $i ,$j, $k );
 241
 242     my @new_fields;
 243     foreach my $field (@text_fields) {
 244         push( @new_fields, $field ) if $field->{'order'} > 0;
 245     }
 246
 247     my @sorted_fields = sort by_order @new_fields;
 248     my $active_fields;
 249     foreach my $field (@sorted_fields) {
 250      $sorttype eq 'codes' ?   $active_fields .= "$field->{'code'} " :
 251           $active_fields .= "$field->{'desc'} ";
 252     }
 253     return $active_fields;
 254
 255 }
 256
 257 sub by_order {
 258     $$a{order} <=> $$b{order};
 259 }
 260
 261 =head2 sub add_batch
 262 =over 4
 263  add_batch($batch_type,\@batch_list);
 264  if $batch_list is supplied,
 265    create a new batch with those items.
 266  else, return the next available batch_id.
 267 =return
 268 =cut
 269 sub add_batch {
 270     my ( $batch_type,$batch_list ) = @_;
 271     my $new_batch;
 272     my $dbh = C4::Context->dbh;
 273     my $q ="SELECT MAX(DISTINCT batch_id) FROM $batch_type";
 274     my $sth = $dbh->prepare($q);
 275     $sth->execute();
 276     my ($batch_id) = $sth->fetchrow_array;
 277     $sth->finish;
 278         if($batch_id) {
 279                 $batch_id++;
 280         } else {
 281                 $batch_id = 1;
 282         }
 283         # TODO: let this block use $batch_type
 284         if(ref($batch_list) && ($batch_type eq 'labels') ) {
 285                 my $sth = $dbh->prepare("INSERT INTO labels (`batch_id`,`itemnumber`) VALUES (?,?)");
 286                 for my $item (@$batch_list) {
 287                         $sth->execute($batch_id,$item);
 288                 }
 289         }
 290         return $batch_id;
 291 }
 292
 293 #FIXME: Needs to be ported to receive $batch_type
 294 # ... this looks eerily like add_batch() ...
 295 sub get_highest_batch {
 296     my $new_batch;
 297     my $dbh = C4::Context->dbh;
 298     my $q =
 299       "select distinct batch_id from labels order by batch_id desc limit 1";
 300     my $sth = $dbh->prepare($q);
 301     $sth->execute();
 302     my $data = $sth->fetchrow_hashref;
 303     $sth->finish;
 304
 305     if ( !$data->{'batch_id'} ) {
 306         $new_batch = 1;
 307     }
 308     else {
 309         $new_batch =  $data->{'batch_id'};
 310     }
 311
 312     return $new_batch;
 313 }
 314
 315
 316 sub get_batches {
 317     my ( $batch_type ) = @_;
 318     my $dbh = C4::Context->dbh;
 319     my $q   = "SELECT batch_id, COUNT(*) AS num FROM $batch_type GROUP BY batch_id";
 320     my $sth = $dbh->prepare($q);
 321     $sth->execute();
 322     my @resultsloop;
 323     while ( my $data = $sth->fetchrow_hashref ) {
 324         push( @resultsloop, $data );
 325     }
 326     $sth->finish;
 327
 328 # Not sure why we are doing this rather than simply telling the user that no batches are currently defined.
 329 # So I'm commenting this out and modifying label-manager.tmpl to properly inform the user as stated. -fbcit
 330     # adding a dummy batch=1 value , if none exists in the db
 331 #    if ( !scalar(@resultsloop) ) {
 332 #        push( @resultsloop, { batch_id => '1' , num => '0' } );
 333 #    }
 334     return @resultsloop;
 335 }
 336
 337 sub delete_batch {
 338     my ($batch_id, $batch_type) = @_;
 339     warn "Deleteing batch of type $batch_type";
 340     my $dbh        = C4::Context->dbh;
 341     my $q          = "DELETE FROM $batch_type WHERE batch_id  = ?";
 342     my $sth        = $dbh->prepare($q);
 343     $sth->execute($batch_id);
 344     $sth->finish;
 345 }
 346
 347 sub get_barcode_types {
 348     my ($layout_id) = @_;
 349     my $layout      = get_layout($layout_id);
 350     my $barcode     = $layout->{'barcodetype'};
 351     my @array;
 352
 353     push( @array, { code => 'CODE39',      desc => 'Code 39' } );
 354     push( @array, { code => 'CODE39MOD',   desc => 'Code39 + Modulo43' } );
 355     push( @array, { code => 'CODE39MOD10', desc => 'Code39 + Modulo10' } );
 356     push( @array, { code => 'ITF',         desc => 'Interleaved 2 of 5' } );
 357
 358     foreach my $line (@array) {
 359         if ( $line->{'code'} eq $barcode ) {
 360             $line->{'active'} = 1;
 361         }
 362
 363     }
 364     return @array;
 365 }
 366
 367 sub GetUnitsValue {
 368     my ($units) = @_;
 369     my $unitvalue;
 370
 371     $unitvalue = '1'          if ( $units eq 'POINT' );
 372     $unitvalue = '2.83464567' if ( $units eq 'MM' );
 373     $unitvalue = '28.3464567' if ( $units eq 'CM' );
 374     $unitvalue = 72           if ( $units eq 'INCH' );
 375     return $unitvalue;
 376 }
 377
 378 sub GetTextWrapCols {
 379     my ( $font, $fontsize, $label_width, $left_text_margin ) = @_;
 380     my $string = '0';
 381     my $strwidth;
 382     my $count = 0;
 383 #    my $textlimit = $label_width - ($left_text_margin);
 384     my $textlimit = $label_width - ( 2* $left_text_margin);
 385
 386     while ( $strwidth < $textlimit ) {
 387         $strwidth = prStrWidth( $string, $font, $fontsize );
 388         $string = $string . '0';
 389         #warn "strwidth:$strwidth, textlimit:$textlimit, count:$count string:$string";
 390         $count++;
 391     }
 392     return $count;
 393 }
 394
 395 sub GetActiveLabelTemplate {
 396     my $dbh   = C4::Context->dbh;
 397     my $query = " SELECT * FROM labels_templates where active = 1 limit 1";
 398     my $sth   = $dbh->prepare($query);
 399     $sth->execute();
 400     my $active_tmpl = $sth->fetchrow_hashref;
 401     $sth->finish;
 402     return $active_tmpl;
 403 }
 404
 405 sub GetSingleLabelTemplate {
 406     my ($tmpl_id) = @_;
 407     my $dbh       = C4::Context->dbh;
 408     my $query     = " SELECT * FROM labels_templates where tmpl_id = ?";
 409     my $sth       = $dbh->prepare($query);
 410     $sth->execute($tmpl_id);
 411     my $template = $sth->fetchrow_hashref;
 412     $sth->finish;
 413     return $template;
 414 }
 415
 416 sub SetActiveTemplate {
 417
 418     my ($tmpl_id) = @_;
 419
 420     my $dbh   = C4::Context->dbh;
 421     my $query = " UPDATE labels_templates SET active = NULL";
 422     my $sth   = $dbh->prepare($query);
 423     $sth->execute();
 424
 425     $query = "UPDATE labels_templates SET active = 1 WHERE tmpl_id = ?";
 426     $sth   = $dbh->prepare($query);
 427     $sth->execute($tmpl_id);
 428     $sth->finish;
 429 }
 430
 431 sub set_active_layout {
 432
 433     my ($layout_id) = @_;
 434     my $dbh         = C4::Context->dbh;
 435     my $query       = " UPDATE labels_conf SET active = NULL";
 436     my $sth         = $dbh->prepare($query);
 437     $sth->execute();
 438
 439     $query = "UPDATE labels_conf SET active = 1 WHERE id = ?";
 440     $sth   = $dbh->prepare($query);
 441     $sth->execute($layout_id);
 442     $sth->finish;
 443 }
 444
 445 sub DeleteTemplate {
 446     my ($tmpl_id) = @_;
 447     my $dbh       = C4::Context->dbh;
 448     my $query     = " DELETE  FROM labels_templates where tmpl_id = ?";
 449     my $sth       = $dbh->prepare($query);
 450     $sth->execute($tmpl_id);
 451     $sth->finish;
 452 }
 453
 454 sub SaveTemplate {
 455     my (
 456         $tmpl_id,     $tmpl_code,   $tmpl_desc,    $page_width,
 457         $page_height, $label_width, $label_height, $topmargin,
 458         $leftmargin,  $cols,        $rows,         $colgap,
 459         $rowgap,      $font,        $fontsize,     $units
 460     ) = @_;
 461     warn "Passed \$font:$font";
 462     my $dbh = C4::Context->dbh;
 463     my $query =
 464       " UPDATE labels_templates SET tmpl_code=?, tmpl_desc=?, page_width=?,
 465                page_height=?, label_width=?, label_height=?, topmargin=?,
 466                leftmargin=?, cols=?, rows=?, colgap=?, rowgap=?, font=?, fontsize=?,
 467                            units=?
 468                   WHERE tmpl_id = ?";
 469
 470     my $sth = $dbh->prepare($query);
 471     $sth->execute(
 472         $tmpl_code,   $tmpl_desc,    $page_width, $page_height,
 473         $label_width, $label_height, $topmargin,  $leftmargin,
 474         $cols,        $rows,         $colgap,     $rowgap,
 475         $font,        $fontsize,     $units,      $tmpl_id
 476     );
 477     my $dberror = $sth->errstr;
 478     $sth->finish;
 479     return $dberror;
 480 }
 481
 482 sub CreateTemplate {
 483     my $tmpl_id;
 484     my (
 485         $tmpl_code,   $tmpl_desc,    $page_width, $page_height,
 486         $label_width, $label_height, $topmargin,  $leftmargin,
 487         $cols,        $rows,         $colgap,     $rowgap,
 488         $font,        $fontsize,     $units
 489     ) = @_;
 490
 491     my $dbh = C4::Context->dbh;
 492
 493     my $query = "INSERT INTO labels_templates (tmpl_code, tmpl_desc, page_width,
 494                          page_height, label_width, label_height, topmargin,
 495                          leftmargin, cols, rows, colgap, rowgap, font, fontsize, units)
 496                          VALUES(?,?,?,?,?,?,?,?,?,?,?,?,?,?,?)";
 497
 498     my $sth = $dbh->prepare($query);
 499     $sth->execute(
 500         $tmpl_code,   $tmpl_desc,    $page_width, $page_height,
 501         $label_width, $label_height, $topmargin,  $leftmargin,
 502         $cols,        $rows,         $colgap,     $rowgap,
 503         $font,        $fontsize,    $units
 504     );
 505     my $dberror = $sth->errstr;
 506     $sth->finish;
 507     return $dberror;
 508 }
 509
 510 sub GetAllLabelTemplates {
 511     my $dbh = C4::Context->dbh;
 512
 513     # get the actual items to be printed.
 514     my @data;
 515     my $query = " Select * from labels_templates ";
 516     my $sth   = $dbh->prepare($query);
 517     $sth->execute();
 518     my @resultsloop;
 519     while ( my $data = $sth->fetchrow_hashref ) {
 520         push( @resultsloop, $data );
 521     }
 522     $sth->finish;
 523
 524     #warn Dumper @resultsloop;
 525     return @resultsloop;
 526 }
 527
 528 #sub SaveConf {
 529 sub add_layout {
 530
 531     my (
 532         $barcodetype,  $title,          $subtitle,      $isbn,       $issn,
 533         $itemtype,     $bcn,            $dcn,        $classif,
 534         $subclass,     $itemcallnumber, $author,     $tmpl_id,
 535         $printingtype, $guidebox,       $startlabel, $layoutname
 536     ) = @_;
 537
 538     my $dbh    = C4::Context->dbh;
 539     my $query2 = "update labels_conf set active = NULL";
 540     my $sth2   = $dbh->prepare($query2);
 541     $sth2->execute();
 542     $query2 = "INSERT INTO labels_conf
 543             ( barcodetype, title, subtitle, isbn,issn, itemtype, barcode,
 544               dewey, class, subclass, itemcallnumber, author, printingtype,
 545                 guidebox, startlabel, layoutname, active )
 546                values ( ?, ?, ?, ?, ?, ?, ?,  ?,?, ?, ?, ?, ?, ?,?,?, 1 )";
 547     $sth2 = $dbh->prepare($query2);
 548     $sth2->execute(
 549         $barcodetype, $title, $subtitle, $isbn, $issn,
 550
 551         $itemtype, $bcn,            $dcn,    $classif,
 552         $subclass, $itemcallnumber, $author, $printingtype,
 553         $guidebox, $startlabel,     $layoutname
 554     );
 555     $sth2->finish;
 556
 557     SetActiveTemplate($tmpl_id);
 558     return;
 559 }
 560
 561 sub save_layout {
 562
 563     my (
 564         $barcodetype,  $title,          $subtitle,      $isbn,       $issn,
 565         $itemtype,     $bcn,            $dcn,        $classif,
 566         $subclass,     $itemcallnumber, $author,     $tmpl_id,
 567         $printingtype, $guidebox,       $startlabel, $layoutname,
 568         $layout_id
 569     ) = @_;
 570 ### $layoutname
 571 ### $layout_id
 572
 573     my $dbh    = C4::Context->dbh;
 574     my $query2 = "update labels_conf set
 575              barcodetype=?, title=?, subtitle=?, isbn=?,issn=?,
 576             itemtype=?, barcode=?,    dewey=?, class=?,
 577              subclass=?, itemcallnumber=?, author=?,  printingtype=?,
 578                guidebox=?, startlabel=?, layoutname=? where id = ?";
 579     my $sth2 = $dbh->prepare($query2);
 580     $sth2->execute(
 581         $barcodetype, $title,          $subtitle,       $isbn,       $issn,
 582         $itemtype,    $bcn,            $dcn,        $classif,
 583         $subclass,    $itemcallnumber, $author,     $printingtype,
 584         $guidebox,    $startlabel,     $layoutname, $layout_id
 585     );
 586     $sth2->finish;
 587
 588     return;
 589 }
 590
 591 =item GetAllPrinterProfiles;
 592
 593     @profiles = GetAllPrinterProfiles()
 594
 595 Returns an array of references-to-hash, whos keys are .....
 596
 597 =cut
 598
 599 sub GetAllPrinterProfiles {
 600
 601     my $dbh = C4::Context->dbh;
 602     my @data;
 603     my $query = "SELECT * FROM printers_profile AS pp INNER JOIN labels_templates AS lt ON pp.tmpl_id = lt.tmpl_id; ";
 604     my $sth = $dbh->prepare($query);
 605     $sth->execute();
 606     my @resultsloop;
 607     while ( my $data = $sth->fetchrow_hashref ) {
 608         push( @resultsloop, $data );
 609     }
 610     $sth->finish;
 611
 612     return @resultsloop;
 613 }
 614
 615 =item GetSinglePrinterProfile;
 616
 617     $profile = GetSinglePrinterProfile()
 618
 619 Returns a hashref whos keys are...
 620
 621 =cut
 622
 623 sub GetSinglePrinterProfile {
 624     my ($prof_id) = @_;
 625     my $dbh       = C4::Context->dbh;
 626     my $query     = " SELECT * FROM printers_profile WHERE prof_id = ?; ";
 627     my $sth       = $dbh->prepare($query);
 628     $sth->execute($prof_id);
 629     my $template = $sth->fetchrow_hashref;
 630     $sth->finish;
 631     return $template;
 632 }
 633
 634 =item SaveProfile;
 635
 636     SaveProfile('parameters')
 637
 638 When passed a set of parameters, this function updates the given profile with the new parameters.
 639
 640 =cut
 641
 642 sub SaveProfile {
 643     my (
 644         $prof_id,       $offset_horz,   $offset_vert,   $creep_horz,    $creep_vert,    $units
 645     ) = @_;
 646     my $dbh = C4::Context->dbh;
 647     my $query =
 648       " UPDATE printers_profile
 649         SET offset_horz=?, offset_vert=?, creep_horz=?, creep_vert=?, unit=?
 650         WHERE prof_id = ? ";
 651     my $sth = $dbh->prepare($query);
 652     $sth->execute(
 653         $offset_horz,   $offset_vert,   $creep_horz,    $creep_vert,    $units,         $prof_id
 654     );
 655     $sth->finish;
 656 }
 657
 658 =item CreateProfile;
 659
 660     CreateProfile('parameters')
 661
 662 When passed a set of parameters, this function creates a new profile containing those parameters
 663 and returns any errors.
 664
 665 =cut
 666
 667 sub CreateProfile {
 668     my (
 669         $prof_id,       $printername,   $paper_bin,     $tmpl_id,     $offset_horz,
 670         $offset_vert,   $creep_horz,    $creep_vert,    $units
 671     ) = @_;
 672     my $dbh = C4::Context->dbh;
 673     my $query =
 674         " INSERT INTO printers_profile (prof_id, printername, paper_bin, tmpl_id,
 675                                         offset_horz, offset_vert, creep_horz, creep_vert, unit)
 676           VALUES(?,?,?,?,?,?,?,?,?) ";
 677     my $sth = $dbh->prepare($query);
 678     $sth->execute(
 679         $prof_id,       $printername,   $paper_bin,     $tmpl_id,     $offset_horz,
 680         $offset_vert,   $creep_horz,    $creep_vert,    $units
 681     );
 682     my $error =  $sth->errstr;
 683     $sth->finish;
 684     return $error;
 685 }
 686
 687 =item DeleteProfile;
 688
 689     DeleteProfile(prof_id)
 690
 691 When passed a profile id, this function deletes that profile from the database and returns any errors.
 692
 693 =cut
 694
 695 sub DeleteProfile {
 696     my ($prof_id) = @_;
 697     my $dbh       = C4::Context->dbh;
 698     my $query     = " DELETE FROM printers_profile WHERE prof_id = ?";
 699     my $sth       = $dbh->prepare($query);
 700     $sth->execute($prof_id);
 701     my $error = $sth->errstr;
 702     $sth->finish;
 703     return $error;
 704 }
 705
 706 =item GetAssociatedProfile;
 707
 708     $assoc_prof = GetAssociatedProfile(tmpl_id)
 709
 710 When passed a template id, this function returns the parameters from the currently associated printer profile
 711 in a hashref where key=fieldname and value=fieldvalue.
 712
 713 =cut
 714
 715 sub GetAssociatedProfile {
 716     my ($tmpl_id) = @_;
 717     my $dbh   = C4::Context->dbh;
 718     # First we find out the prof_id for the associated profile...
 719     my $query = "SELECT * FROM labels_profile WHERE tmpl_id = ?";
 720     my $sth   = $dbh->prepare($query);
 721     $sth->execute($tmpl_id);
 722     my $assoc_prof = $sth->fetchrow_hashref;
 723     $sth->finish;
 724     # Then we retrieve that profile and return it to the caller...
 725     $assoc_prof = GetSinglePrinterProfile($assoc_prof->{'prof_id'});
 726     return $assoc_prof;
 727 }
 728
 729 =item SetAssociatedProfile;
 730
 731     SetAssociatedProfile($prof_id, $tmpl_id)
 732
 733 When passed both a profile id and template id, this function establishes an association between the two. No more
 734 than one profile may be associated with any given template at the same time.
 735
 736 =cut
 737
 738 sub SetAssociatedProfile {
 739
 740     my ($prof_id, $tmpl_id) = @_;
 741
 742     my $dbh = C4::Context->dbh;
 743     my $query = "INSERT INTO labels_profile (prof_id, tmpl_id) VALUES (?,?) ON DUPLICATE KEY UPDATE prof_id = ?";
 744     my $sth = $dbh->prepare($query);
 745     $sth->execute($prof_id, $tmpl_id, $prof_id);
 746     $sth->finish;
 747 }
 748
 749 =item GetLabelItems;
 750
 751         $options = GetLabelItems()
 752
 753 Returns an array of references-to-hash, whos keys are the field from the biblio, biblioitems, items and labels tables in the Koha database.
 754
 755 =cut
 756
 757 #'
 758 sub GetLabelItems {
 759     my ($batch_id) = @_;
 760     my $dbh = C4::Context->dbh;
 761
 762     my @resultsloop = ();
 763     my $count;
 764     my @data;
 765     my $sth;
 766
 767     if ($batch_id) {
 768         my $query3 = "Select * from labels where batch_id = ? order by labelid ";
 769         $sth = $dbh->prepare($query3);
 770         $sth->execute($batch_id);
 771
 772     }
 773     else {
 774
 775         my $query3 = "Select * from labels";
 776         $sth = $dbh->prepare($query3);
 777         $sth->execute();
 778     }
 779     my $cnt = $sth->rows;
 780     my $i1  = 1;
 781     while ( my $data = $sth->fetchrow_hashref ) {
 782
 783         # lets get some summary info from each item
 784         my $query1 = "
 785          select i.*, bi.*, b.*  from items i,biblioitems bi,biblio b
 786                 where itemnumber=? and  i.biblioitemnumber=bi.biblioitemnumber and
 787                 bi.biblionumber=b.biblionumber";
 788
 789                 my $sth1 = $dbh->prepare($query1);
 790         $sth1->execute( $data->{'itemnumber'} );
 791
 792         my $data1 = $sth1->fetchrow_hashref();
 793         $data1->{'labelno'}  = $i1;
 794         $data1->{'labelid'}  = $data->{'labelid'};
 795         $data1->{'batch_id'} = $batch_id;
 796         $data1->{'summary'} =
 797           "$data1->{'barcode'}, $data1->{'title'}, $data1->{'isbn'}";
 798
 799         push( @resultsloop, $data1 );
 800         $sth1->finish;
 801
 802         $i1++;
 803     }
 804     $sth->finish;
 805     return @resultsloop;
 806
 807 }
 808
 809 sub GetItemFields {
 810     my @fields = qw (
 811       barcode title subtitle
 812       dewey isbn issn author class
 813       itemtype subclass itemcallnumber
 814
 815     );
 816     return @fields;
 817 }
 818
 819 sub GetPatronCardItems {
 820
 821     my ( $batch_id ) = @_;
 822     my @resultsloop;
 823
 824     my $dbh = C4::Context->dbh;
 825 #    my $query = "SELECT * FROM patroncards WHERE batch_id = ? ORDER BY borrowernumber";
 826     my $query = "SELECT * FROM patroncards WHERE batch_id = ? ORDER BY cardid";
 827     my $sth = $dbh->prepare($query);
 828     $sth->execute($batch_id);
 829     my $cardno = 1;
 830     while ( my $data = $sth->fetchrow_hashref ) {
 831         my $patron_data = GetMember( $data->{'borrowernumber'} );
 832         $patron_data->{'branchname'} = GetBranchName( $patron_data->{'branchcode'} );
 833         $patron_data->{'cardno'} = $cardno;
 834         $patron_data->{'cardid'} = $data->{'cardid'};
 835         $patron_data->{'batch_id'} = $batch_id;
 836         push( @resultsloop, $patron_data );
 837         $cardno++;
 838     }
 839     $sth->finish;
 840     return @resultsloop;
 841
 842 }
 843
 844 sub deduplicate_batch {
 845         my ( $batch_id, $batch_type ) = @_;
 846         my $query = "
 847         SELECT DISTINCT
 848                         batch_id," . (($batch_type eq 'labels') ? 'itemnumber' : 'borrowernumber') . ",
 849                         count(". (($batch_type eq 'labels') ? 'labelid' : 'cardid') . ") as count
 850         FROM $batch_type
 851         WHERE batch_id = ?
 852         GROUP BY " . (($batch_type eq 'labels') ? 'itemnumber' : 'borrowernumber') . ",batch_id
 853         HAVING count > 1
 854         ORDER BY batch_id,
 855         count DESC  ";
 856         my $sth = C4::Context->dbh->prepare($query);
 857         $sth->execute($batch_id);
 858         warn $sth->errstr if $sth->errstr;
 859         $sth->rows or return undef, $sth->errstr;
 860
 861         my $del_query = "
 862         DELETE
 863         FROM     $batch_type
 864         WHERE    batch_id = ?
 865         AND      " . (($batch_type eq 'labels') ? 'itemnumber' : 'borrowernumber') . " = ?
 866         ORDER BY timestamp ASC
 867         ";
 868         my $killed = 0;
 869         while (my $data = $sth->fetchrow_hashref()) {
 870                 my $itemnumber = $data->{(($batch_type eq 'labels') ? 'itemnumber' : 'borrowernumber')} or next;
 871                 my $limit      = $data->{count} - 1  or next;
 872                 my $sth2 = C4::Context->dbh->prepare("$del_query  LIMIT $limit");
 873                 # die sprintf "$del_query LIMIT %s\n (%s, %s)", $limit, $batch_id, $itemnumber;
 874                 # $sth2->execute($batch_id, C4::Context->dbh->quote($data->{itemnumber}), $data->{count} - 1)
 875                 $sth2->execute($batch_id, $itemnumber) and
 876                         $killed += ($data->{count} - 1);
 877                 warn $sth2->errstr if $sth2->errstr;
 878         }
 879         return $killed, undef;
 880 }
 881
 882 sub DrawSpineText {
 883
 884     my ( $x_pos, $y_pos, $label_height, $label_width, $fontname, $fontsize, $left_text_margin,
 885         $text_wrap_cols, $item, $conf_data, $printingtype )
 886       = @_;
 887 # hack to fix column name mismatch betwen labels_conf.class, and bibitems.classification
 888         $$item->{'class'} = $$item->{'classification'};
 889
 890     $Text::Wrap::columns   = $text_wrap_cols;
 891     $Text::Wrap::separator = "\n";
 892
 893     my $str;
 894
 895     my $top_text_margin = ( $fontsize + 3 );    #FIXME: This should be a template parameter and passed in...
 896     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.).
 897
 898     # add your printable fields manually in here
 899
 900     my $layout_id = $$conf_data->{'id'};
 901
 902 #    my @fields = GetItemFields();
 903
 904     my $str_fields = get_text_fields($layout_id, 'codes' );
 905     my @fields = split(/ /, $str_fields);
 906     #warn Dumper(@fields);
 907
 908     my $vPos   = ( $y_pos + ( $label_height - $top_text_margin ) );
 909     my $font = prFont($fontname);
 910
 911     # warn Dumper $conf_data;
 912     #warn Dumper $item;
 913
 914     foreach my $field (@fields) {
 915
 916         # testing hack
 917 #     $$item->{"$field"} = $field . ": " . $$item->{"$field"};
 918
 919         # if the display option for this field is selected in the DB,
 920         # and the item record has some values for this field, display it.
 921         if ( $$conf_data->{"$field"} && $$item->{"$field"} ) {
 922
 923             #            warn "CONF_TYPE = $field";
 924
 925             # get the string
 926             $str = $$item->{"$field"};
 927             # strip out naughty existing nl/cr's
 928             $str =~ s/\n//g;
 929             $str =~ s/\r//g;
 930             # wrap lines based on call number dividers '/'
 931             my @strings;
 932
 933             while ( $str =~ /\// ) {
 934                 $str =~ /^(.*)\/(.*)$/;
 935
 936                 #warn "\$2=$2";
 937                 unshift @strings, $2;
 938                 $str = $1;
 939             }
 940
 941             unshift @strings, $str;
 942
 943             # strip out division slashes
 944             #$str =~ s/\///g;
 945             #warn "\$str after striping division marks: $str";
 946             # chop the string up into _upto_ 12 chunks
 947             # and seperate the chunks with newlines
 948
 949             #$str = wrap( "", "", "$str" );
 950             #$str = wrap( "", "", "$str" );
 951
 952             # split the chunks between newline's, into an array
 953             #my @strings = split /\n/, $str;
 954
 955             # then loop for each string line
 956             foreach my $str (@strings) {
 957                 my $hPos;
 958                 if ( $printingtype eq 'BIB' ) { #FIXME: This is a hack and needs to be implimented as a text justification option in the template...
 959                     # some code to try and center each line on the label based on font size and string point width...
 960                     my $stringwidth = prStrWidth($str, $fontname, $fontsize);
 961                     my $whitespace = ( $label_width - ( $stringwidth + (2 * $left_text_margin) ) );
 962                     $hPos = ( ( $whitespace  / 2 ) + $x_pos + $left_text_margin );
 963                     #warn "\$label_width=$label_width \$stringwidth=$stringwidth \$whitespace=$whitespace \$left_text_margin=$left_text_margin for $str\n";
 964                 } else {
 965                     $hPos = ( $x_pos + $left_text_margin );
 966                 }
 967                 PrintText( $hPos, $vPos, $font, $fontsize, $str );
 968                 $vPos = $vPos - $line_spacer;
 969
 970             }
 971         }    # if field is
 972     }    #foreach feild
 973 }
 974
 975 sub PrintText {
 976     my ( $hPos, $vPos, $font, $fontsize, $text ) = @_;
 977     my $str = "BT /$font $fontsize Tf $hPos $vPos Td ($text) Tj ET";
 978     warn $str;
 979     prAdd($str);
 980 }
 981
 982 sub DrawPatronCardText {
 983
 984     my ( $x_pos, $y_pos, $label_height, $label_width, $fontname, $fontsize, $left_text_margin,
 985         $text_wrap_cols, $text, $printingtype )
 986       = @_;
 987
 988     my $top_text_margin = 25;    #FIXME: This should be a template parameter and passed in...
 989
 990     my $vPos   = ( $y_pos + ( $label_height - $top_text_margin ) );
 991     my $font = prFont($fontname);
 992
 993     my $hPos;
 994
 995     foreach my $line (keys %$text) {
 996         warn "Current text is \"$line\" and font size for \"$line\" is $text->{$line} points";
 997         # some code to try and center each line on the label based on font size and string point width...
 998         my $stringwidth = prStrWidth($line, $fontname, $text->{$line});
 999         my $whitespace = ( $label_width - ( $stringwidth + (2 * $left_text_margin) ) );
1000         $hPos = ( ( $whitespace  / 2 ) + $x_pos + $left_text_margin );
1001
1002         PrintText( $hPos, $vPos, $font, $text->{$line}, $line );
1003         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.).
1004         $vPos = $vPos - ($line_spacer + $text->{$line});   # Linefeed equiv: leading + font size
1005     }
1006 }
1007
1008 # Not used anywhere.
1009
1010 #sub SetFontSize {
1011 #
1012 #    my ($fontsize) = @_;
1013 #### fontsize
1014 #    my $str = "BT/F13 30 Tf288 720 Td( AAAAAAAAAA ) TjET";
1015 #    prAdd($str);
1016 #}
1017
1018 sub DrawBarcode {
1019
1020     # x and y are from the top-left :)
1021     my ( $x_pos, $y_pos, $height, $width, $barcode, $barcodetype ) = @_;
1022     my $num_of_bars = length($barcode);
1023     my $bar_width   = $width * .8;        # %80 of length of label width
1024     my $tot_bar_length;
1025     my $bar_length;
1026     my $guard_length = 10;
1027     my $xsize_ratio;
1028
1029     if ( $barcodetype eq 'CODE39' ) {
1030         $bar_length = '17.5';
1031         $tot_bar_length =
1032           ( $bar_length * $num_of_bars ) + ( $guard_length * 2 );
1033         $xsize_ratio = ( $bar_width / $tot_bar_length );
1034         eval {
1035             PDF::Reuse::Barcode::Code39(
1036                 x => ( $x_pos + ( $width / 10 ) ),
1037                 y => ( $y_pos + ( $height / 10 ) ),
1038                 value         => "*$barcode*",
1039                 ySize         => ( .02 * $height ),
1040                 xSize         => $xsize_ratio,
1041                 hide_asterisk => 1,
1042             );
1043         };
1044         if ($@) {
1045             warn "$barcodetype, $barcode FAILED:$@";
1046         }
1047     }
1048
1049     elsif ( $barcodetype eq 'CODE39MOD' ) {
1050
1051         # get modulo43 checksum
1052         my $c39 = CheckDigits('code_39');
1053         $barcode = $c39->complete($barcode);
1054
1055         $bar_length = '19';
1056         $tot_bar_length =
1057           ( $bar_length * $num_of_bars ) + ( $guard_length * 2 );
1058         $xsize_ratio = ( $bar_width / $tot_bar_length );
1059         eval {
1060             PDF::Reuse::Barcode::Code39(
1061                 x => ( $x_pos + ( $width / 10 ) ),
1062                 y => ( $y_pos + ( $height / 10 ) ),
1063                 value         => "*$barcode*",
1064                 ySize         => ( .02 * $height ),
1065                 xSize         => $xsize_ratio,
1066                 hide_asterisk => 1,
1067             );
1068         };
1069
1070         if ($@) {
1071             warn "$barcodetype, $barcode FAILED:$@";
1072         }
1073     }
1074     elsif ( $barcodetype eq 'CODE39MOD10' ) {
1075
1076         # get modulo43 checksum
1077         my $c39_10 = CheckDigits('visa');
1078         $barcode = $c39_10->complete($barcode);
1079
1080         $bar_length = '19';
1081         $tot_bar_length =
1082           ( $bar_length * $num_of_bars ) + ( $guard_length * 2 );
1083         $xsize_ratio = ( $bar_width / $tot_bar_length );
1084         eval {
1085             PDF::Reuse::Barcode::Code39(
1086                 x => ( $x_pos + ( $width / 10 ) ),
1087                 y => ( $y_pos + ( $height / 10 ) ),
1088                 value         => "*$barcode*",
1089                 ySize         => ( .02 * $height ),
1090                 xSize         => $xsize_ratio,
1091                 hide_asterisk => 1,
1092                                 text         => 0,
1093             );
1094         };
1095
1096         if ($@) {
1097             warn "$barcodetype, $barcode FAILED:$@";
1098         }
1099     }
1100
1101
1102     elsif ( $barcodetype eq 'COOP2OF5' ) {
1103         $bar_length = '9.43333333333333';
1104         $tot_bar_length =
1105           ( $bar_length * $num_of_bars ) + ( $guard_length * 2 );
1106         $xsize_ratio = ( $bar_width / $tot_bar_length ) * .9;
1107         eval {
1108             PDF::Reuse::Barcode::COOP2of5(
1109                 x => ( $x_pos + ( $width / 10 ) ),
1110                 y => ( $y_pos + ( $height / 10 ) ),
1111                 value => $barcode,
1112                 ySize => ( .02 * $height ),
1113                 xSize => $xsize_ratio,
1114             );
1115         };
1116         if ($@) {
1117             warn "$barcodetype, $barcode FAILED:$@";
1118         }
1119     }
1120
1121     elsif ( $barcodetype eq 'INDUSTRIAL2OF5' ) {
1122         $bar_length = '13.1333333333333';
1123         $tot_bar_length =
1124           ( $bar_length * $num_of_bars ) + ( $guard_length * 2 );
1125         $xsize_ratio = ( $bar_width / $tot_bar_length ) * .9;
1126         eval {
1127             PDF::Reuse::Barcode::Industrial2of5(
1128                 x => ( $x_pos + ( $width / 10 ) ),
1129                 y => ( $y_pos + ( $height / 10 ) ),
1130                 value => $barcode,
1131                 ySize => ( .02 * $height ),
1132                 xSize => $xsize_ratio,
1133             );
1134         };
1135         if ($@) {
1136             warn "$barcodetype, $barcode FAILED:$@";
1137         }
1138     }
1139
1140     my $moo2 = $tot_bar_length * $xsize_ratio;
1141
1142     warn "$x_pos, $y_pos, $barcode, $barcodetype" if $DEBUG;
1143     warn "BAR_WDTH = $bar_width, TOT.BAR.LGHT=$tot_bar_length  R*TOT.BAR =$moo2" if $DEBUG;
1144 }
1145
1146 =item build_circ_barcode;
1147
1148   build_circ_barcode( $x_pos, $y_pos, $barcode,
1149                 $barcodetype, \$item);
1150
1151 $item is the result of a previous call to GetLabelItems();
1152
1153 =cut
1154
1155 #'
1156 sub build_circ_barcode {
1157     my ( $x_pos_circ, $y_pos, $value, $barcodetype, $item ) = @_;
1158
1159     #warn Dumper \$item;
1160
1161     #warn "value = $value\n";
1162
1163     #$DB::single = 1;
1164
1165     if ( $barcodetype eq 'EAN13' ) {
1166
1167         #testing EAN13 barcodes hack
1168         $value = $value . '000000000';
1169         $value =~ s/-//;
1170         $value = substr( $value, 0, 12 );
1171
1172         #warn $value;
1173         eval {
1174             PDF::Reuse::Barcode::EAN13(
1175                 x     => ( $x_pos_circ + 27 ),
1176                 y     => ( $y_pos + 15 ),
1177                 value => $value,
1178
1179                 #            prolong => 2.96,
1180                 #            xSize   => 1.5,
1181
1182                 # ySize   => 1.2,
1183
1184 # added for xpdf compat. doesnt use type3 fonts., but increases filesize from 20k to 200k
1185 # i think its embedding extra fonts in the pdf file.
1186 #  mode => 'graphic',
1187             );
1188         };
1189         if ($@) {
1190             $item->{'barcodeerror'} = 1;
1191
1192             #warn "EAN13BARCODE FAILED:$@";
1193         }
1194
1195         #warn $barcodetype;
1196
1197     }
1198     elsif ( $barcodetype eq 'Code39' ) {
1199
1200         eval {
1201             PDF::Reuse::Barcode::Code39(
1202                 x     => ( $x_pos_circ + 9 ),
1203                 y     => ( $y_pos + 15 ),
1204                 value => $value,
1205
1206                 #           prolong => 2.96,
1207                 xSize => .85,
1208
1209                 ySize => 1.3,
1210             );
1211         };
1212         if ($@) {
1213             $item->{'barcodeerror'} = 1;
1214
1215             #warn "CODE39BARCODE $value FAILED:$@";
1216         }
1217
1218         #warn $barcodetype;
1219
1220     }
1221
1222     elsif ( $barcodetype eq 'Matrix2of5' ) {
1223
1224         #warn "MATRIX ELSE:";
1225
1226         #testing MATRIX25  barcodes hack
1227         #    $value = $value.'000000000';
1228         $value =~ s/-//;
1229
1230         #    $value = substr( $value, 0, 12 );
1231         #warn $value;
1232
1233         eval {
1234             PDF::Reuse::Barcode::Matrix2of5(
1235                 x     => ( $x_pos_circ + 27 ),
1236                 y     => ( $y_pos + 15 ),
1237                 value => $value,
1238
1239                 #        prolong => 2.96,
1240                 #       xSize   => 1.5,
1241
1242                 # ySize   => 1.2,
1243             );
1244         };
1245         if ($@) {
1246             $item->{'barcodeerror'} = 1;
1247
1248             #warn "BARCODE FAILED:$@";
1249         }
1250
1251         #warn $barcodetype;
1252
1253     }
1254
1255     elsif ( $barcodetype eq 'EAN8' ) {
1256
1257         #testing ean8 barcodes hack
1258         $value = $value . '000000000';
1259         $value =~ s/-//;
1260         $value = substr( $value, 0, 8 );
1261
1262         #warn $value;
1263
1264         #warn "EAN8 ELSEIF";
1265         eval {
1266             PDF::Reuse::Barcode::EAN8(
1267                 x       => ( $x_pos_circ + 42 ),
1268                 y       => ( $y_pos + 15 ),
1269                 value   => $value,
1270                 prolong => 2.96,
1271                 xSize   => 1.5,
1272
1273                 # ySize   => 1.2,
1274             );
1275         };
1276
1277         if ($@) {
1278             $item->{'barcodeerror'} = 1;
1279
1280             #warn "BARCODE FAILED:$@";
1281         }
1282
1283         #warn $barcodetype;
1284
1285     }
1286
1287     elsif ( $barcodetype eq 'UPC-E' ) {
1288         eval {
1289             PDF::Reuse::Barcode::UPCE(
1290                 x       => ( $x_pos_circ + 27 ),
1291                 y       => ( $y_pos + 15 ),
1292                 value   => $value,
1293                 prolong => 2.96,
1294                 xSize   => 1.5,
1295
1296                 # ySize   => 1.2,
1297             );
1298         };
1299
1300         if ($@) {
1301             $item->{'barcodeerror'} = 1;
1302
1303             #warn "BARCODE FAILED:$@";
1304         }
1305
1306         #warn $barcodetype;
1307
1308     }
1309     elsif ( $barcodetype eq 'NW7' ) {
1310         eval {
1311             PDF::Reuse::Barcode::NW7(
1312                 x       => ( $x_pos_circ + 27 ),
1313                 y       => ( $y_pos + 15 ),
1314                 value   => $value,
1315                 prolong => 2.96,
1316                 xSize   => 1.5,
1317
1318                 # ySize   => 1.2,
1319             );
1320         };
1321
1322         if ($@) {
1323             $item->{'barcodeerror'} = 1;
1324
1325             #warn "BARCODE FAILED:$@";
1326         }
1327
1328         #warn $barcodetype;
1329
1330     }
1331     elsif ( $barcodetype eq 'ITF' ) {
1332         eval {
1333             PDF::Reuse::Barcode::ITF(
1334                 x       => ( $x_pos_circ + 27 ),
1335                 y       => ( $y_pos + 15 ),
1336                 value   => $value,
1337                 prolong => 2.96,
1338                 xSize   => 1.5,
1339
1340                 # ySize   => 1.2,
1341             );
1342         };
1343
1344         if ($@) {
1345             $item->{'barcodeerror'} = 1;
1346
1347             #warn "BARCODE FAILED:$@";
1348         }
1349
1350         #warn $barcodetype;
1351
1352     }
1353     elsif ( $barcodetype eq 'Industrial2of5' ) {
1354         eval {
1355             PDF::Reuse::Barcode::Industrial2of5(
1356                 x       => ( $x_pos_circ + 27 ),
1357                 y       => ( $y_pos + 15 ),
1358                 value   => $value,
1359                 prolong => 2.96,
1360                 xSize   => 1.5,
1361
1362                 # ySize   => 1.2,
1363             );
1364         };
1365         if ($@) {
1366             $item->{'barcodeerror'} = 1;
1367
1368             #warn "BARCODE FAILED:$@";
1369         }
1370
1371         #warn $barcodetype;
1372
1373     }
1374     elsif ( $barcodetype eq 'IATA2of5' ) {
1375         eval {
1376             PDF::Reuse::Barcode::IATA2of5(
1377                 x       => ( $x_pos_circ + 27 ),
1378                 y       => ( $y_pos + 15 ),
1379                 value   => $value,
1380                 prolong => 2.96,
1381                 xSize   => 1.5,
1382
1383                 # ySize   => 1.2,
1384             );
1385         };
1386         if ($@) {
1387             $item->{'barcodeerror'} = 1;
1388
1389             #warn "BARCODE FAILED:$@";
1390         }
1391
1392         #warn $barcodetype;
1393
1394     }
1395
1396     elsif ( $barcodetype eq 'COOP2of5' ) {
1397         eval {
1398             PDF::Reuse::Barcode::COOP2of5(
1399                 x       => ( $x_pos_circ + 27 ),
1400                 y       => ( $y_pos + 15 ),
1401                 value   => $value,
1402                 prolong => 2.96,
1403                 xSize   => 1.5,
1404
1405                 # ySize   => 1.2,
1406             );
1407         };
1408         if ($@) {
1409             $item->{'barcodeerror'} = 1;
1410
1411             #warn "BARCODE FAILED:$@";
1412         }
1413
1414         #warn $barcodetype;
1415
1416     }
1417     elsif ( $barcodetype eq 'UPC-A' ) {
1418
1419         eval {
1420             PDF::Reuse::Barcode::UPCA(
1421                 x       => ( $x_pos_circ + 27 ),
1422                 y       => ( $y_pos + 15 ),
1423                 value   => $value,
1424                 prolong => 2.96,
1425                 xSize   => 1.5,
1426
1427                 # ySize   => 1.2,
1428             );
1429         };
1430         if ($@) {
1431             $item->{'barcodeerror'} = 1;
1432
1433             #warn "BARCODE FAILED:$@";
1434         }
1435
1436         #warn $barcodetype;
1437
1438     }
1439
1440 }
1441
1442 =item draw_boundaries
1443
1444  sub draw_boundaries ($x_pos_spine, $x_pos_circ1, $x_pos_circ2,
1445                 $y_pos, $spine_width, $label_height, $circ_width)
1446
1447 This sub draws boundary lines where the label outlines are, to aid in printer testing, and debugging.
1448
1449 =cut
1450
1451 #'
1452 sub draw_boundaries {
1453
1454     my (
1455         $x_pos_spine, $x_pos_circ1,  $x_pos_circ2, $y_pos,
1456         $spine_width, $label_height, $circ_width
1457     ) = @_;
1458
1459     my $y_pos_initial = ( ( 792 - 36 ) - 90 );
1460     $y_pos            = $y_pos_initial; # FIXME - why are we ignoring the y_pos parameter by redefining it?
1461     my $i             = 1;
1462
1463     for ( $i = 1 ; $i <= 8 ; $i++ ) {
1464
1465         &drawbox( $x_pos_spine, $y_pos, ($spine_width), ($label_height) );
1466
1467    #warn "OLD BOXES  x=$x_pos_spine, y=$y_pos, w=$spine_width, h=$label_height";
1468         &drawbox( $x_pos_circ1, $y_pos, ($circ_width), ($label_height) );
1469         &drawbox( $x_pos_circ2, $y_pos, ($circ_width), ($label_height) );
1470
1471         $y_pos = ( $y_pos - $label_height );
1472
1473     }
1474 }
1475
1476 =item drawbox
1477
1478         sub drawbox {   $lower_left_x, $lower_left_y,
1479                         $upper_right_x, $upper_right_y )
1480
1481 this is a low level sub, that draws a pdf box, it is called by draw_boxes
1482
1483 FYI: the  $upper_right_x and $upper_right_y values are RELATIVE to  $lower_left_x and $lower_left_y
1484
1485 and $lower_left_x, $lower_left_y are ABSOLUTE, this caught me out!
1486
1487 =cut
1488
1489 #'
1490 sub drawbox {
1491     my ( $llx, $lly, $urx, $ury ) = @_;
1492
1493     #    warn "llx,y= $llx,$lly  ,   urx,y=$urx,$ury \n";
1494
1495     my $str = "q\n";    # save the graphic state
1496     $str .= "0.5 w\n";              # border color red
1497     $str .= "1.0 0.0 0.0  RG\n";    # border color red
1498          #   $str .= "0.5 0.75 1.0 rg\n";           # fill color blue
1499     $str .= "1.0 1.0 1.0  rg\n";    # fill color white
1500
1501     $str .= "$llx $lly $urx $ury re\n";    # a rectangle
1502     $str .= "B\n";                         # fill (and a little more)
1503     $str .= "Q\n";                         # save the graphic state
1504
1505     prAdd($str);
1506
1507 }
1508
1509 END { }    # module clean-up code here (global destructor)
1510
1511 1;
1512 __END__
1513
1514 =back
1515
1516 =head1 AUTHOR
1517
1518 Mason James <mason@katipo.co.nz>
1519
1520 =cut
1521