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