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