C4/Labels.pm

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