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