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