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                 $str =~ s/\(/\\\(/g;    # Escape '(' and ')' for the postscript stream...
1004                 $str =~ s/\)/\\\)/g;
1005                 # Wrap text lines exceeding $text_wrap_cols length...
1006                 $Text::Wrap::columns = $text_wrap_cols;
1007                 my @line = split(/\n/ ,wrap('', '', $str));
1008                 # If this is a title field, limit to two lines; all others limit to one...
1009                 if ($field->{code} eq 'title' && scalar(@line) >= 2) {
1010                     while (scalar(@line) > 2) {
1011                         pop @line;
1012                     }
1013                 } else {
1014                     while (scalar(@line) > 1) {
1015                         pop @line;
1016                     }
1017                 }
1018                 push(@strings, @line);
1019             }
1020             # loop for each string line
1021             foreach my $str (@strings) {
1022                 my $hPos;
1023                 if ( $printingtype eq 'BIB' ) { #FIXME: This is a hack and needs to be implimented as a text justification option in the template...
1024                     # some code to try and center each line on the label based on font size and string point width...
1025                     my $stringwidth = prStrWidth($str, $fontname, $fontsize);
1026                     my $whitespace = ( $label_width - ( $stringwidth + (2 * $left_text_margin) ) );
1027                     $hPos = ( ( $whitespace  / 2 ) + $x_pos + $left_text_margin );
1028                     #warn "\$label_width=$label_width \$stringwidth=$stringwidth \$whitespace=$whitespace \$left_text_margin=$left_text_margin for $str\n";
1029                 } else {
1030                     $hPos = ( $x_pos + $left_text_margin );
1031                 }
1032                 PrintText( $hPos, $vPos, $font, $fontsize, $str );
1033                 $vPos = $vPos - $line_spacer;
1034             }
1035         }
1036         }       #foreach field
1037 }
1038
1039 sub PrintText {
1040     my ( $hPos, $vPos, $font, $fontsize, $text ) = @_;
1041     my $str = "BT /$font $fontsize Tf $hPos $vPos Td ($text) Tj ET";
1042     prAdd($str);
1043 }
1044
1045 sub DrawPatronCardText {
1046
1047     my ( $x_pos, $y_pos, $label_height, $label_width, $fontname, $fontsize, $left_text_margin,
1048         $text_wrap_cols, $text, $printingtype )
1049       = @_;
1050
1051     my $top_text_margin = 25;    #FIXME: This should be a template parameter and passed in...
1052
1053     my $vPos   = ( $y_pos + ( $label_height - $top_text_margin ) );
1054     my $font = prFont($fontname);
1055
1056     my $hPos;
1057
1058     foreach my $line (keys %$text) {
1059         $debug and warn "Current text is \"$line\" and font size for \"$line\" is $text->{$line} points";
1060         # some code to try and center each line on the label based on font size and string point width...
1061         my $stringwidth = prStrWidth($line, $fontname, $text->{$line});
1062         my $whitespace = ( $label_width - ( $stringwidth + (2 * $left_text_margin) ) );
1063         $hPos = ( ( $whitespace  / 2 ) + $x_pos + $left_text_margin );
1064
1065         PrintText( $hPos, $vPos, $font, $text->{$line}, $line );
1066         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.).
1067         $vPos = $vPos - ($line_spacer + $text->{$line});   # Linefeed equiv: leading + font size
1068     }
1069 }
1070
1071 # Not used anywhere.
1072
1073 #sub SetFontSize {
1074 #
1075 #    my ($fontsize) = @_;
1076 #### fontsize
1077 #    my $str = "BT/F13 30 Tf288 720 Td( AAAAAAAAAA ) TjET";
1078 #    prAdd($str);
1079 #}
1080
1081 sub DrawBarcode {
1082
1083     # x and y are from the top-left :)
1084     my ( $x_pos, $y_pos, $height, $width, $barcode, $barcodetype ) = @_;
1085     my $num_of_bars = length($barcode);
1086     my $bar_width   = $width * .8;        # %80 of length of label width
1087     my $tot_bar_length;
1088     my $bar_length;
1089     my $guard_length = 10;
1090     my $xsize_ratio;
1091
1092     if ( $barcodetype eq 'CODE39' ) {
1093         $bar_length = '17.5';
1094         $tot_bar_length =
1095           ( $bar_length * $num_of_bars ) + ( $guard_length * 2 );
1096         $xsize_ratio = ( $bar_width / $tot_bar_length );
1097         eval {
1098             PDF::Reuse::Barcode::Code39(
1099                 x => ( $x_pos + ( $width / 10 ) ),
1100                 y => ( $y_pos + ( $height / 10 ) ),
1101                 value         => "*$barcode*",
1102                 ySize         => ( .02 * $height ),
1103                 xSize         => $xsize_ratio,
1104                 hide_asterisk => 1,
1105             );
1106         };
1107         if ($@) {
1108             warn "$barcodetype, $barcode FAILED:$@";
1109         }
1110     }
1111
1112     elsif ( $barcodetype eq 'CODE39MOD' ) {
1113
1114         # get modulo43 checksum
1115         my $c39 = CheckDigits('code_39');
1116         $barcode = $c39->complete($barcode);
1117
1118         $bar_length = '19';
1119         $tot_bar_length =
1120           ( $bar_length * $num_of_bars ) + ( $guard_length * 2 );
1121         $xsize_ratio = ( $bar_width / $tot_bar_length );
1122         eval {
1123             PDF::Reuse::Barcode::Code39(
1124                 x => ( $x_pos + ( $width / 10 ) ),
1125                 y => ( $y_pos + ( $height / 10 ) ),
1126                 value         => "*$barcode*",
1127                 ySize         => ( .02 * $height ),
1128                 xSize         => $xsize_ratio,
1129                 hide_asterisk => 1,
1130             );
1131         };
1132
1133         if ($@) {
1134             warn "$barcodetype, $barcode FAILED:$@";
1135         }
1136     }
1137     elsif ( $barcodetype eq 'CODE39MOD10' ) {
1138
1139         # get modulo43 checksum
1140         my $c39_10 = CheckDigits('visa');
1141         $barcode = $c39_10->complete($barcode);
1142
1143         $bar_length = '19';
1144         $tot_bar_length =
1145           ( $bar_length * $num_of_bars ) + ( $guard_length * 2 );
1146         $xsize_ratio = ( $bar_width / $tot_bar_length );
1147         eval {
1148             PDF::Reuse::Barcode::Code39(
1149                 x => ( $x_pos + ( $width / 10 ) ),
1150                 y => ( $y_pos + ( $height / 10 ) ),
1151                 value         => "*$barcode*",
1152                 ySize         => ( .02 * $height ),
1153                 xSize         => $xsize_ratio,
1154                 hide_asterisk => 1,
1155                                 text         => 0,
1156             );
1157         };
1158
1159         if ($@) {
1160             warn "$barcodetype, $barcode FAILED:$@";
1161         }
1162     }
1163
1164
1165     elsif ( $barcodetype eq 'COOP2OF5' ) {
1166         $bar_length = '9.43333333333333';
1167         $tot_bar_length =
1168           ( $bar_length * $num_of_bars ) + ( $guard_length * 2 );
1169         $xsize_ratio = ( $bar_width / $tot_bar_length ) * .9;
1170         eval {
1171             PDF::Reuse::Barcode::COOP2of5(
1172                 x => ( $x_pos + ( $width / 10 ) ),
1173                 y => ( $y_pos + ( $height / 10 ) ),
1174                 value => $barcode,
1175                 ySize => ( .02 * $height ),
1176                 xSize => $xsize_ratio,
1177             );
1178         };
1179         if ($@) {
1180             warn "$barcodetype, $barcode FAILED:$@";
1181         }
1182     }
1183
1184     elsif ( $barcodetype eq 'INDUSTRIAL2OF5' ) {
1185         $bar_length = '13.1333333333333';
1186         $tot_bar_length =
1187           ( $bar_length * $num_of_bars ) + ( $guard_length * 2 );
1188         $xsize_ratio = ( $bar_width / $tot_bar_length ) * .9;
1189         eval {
1190             PDF::Reuse::Barcode::Industrial2of5(
1191                 x => ( $x_pos + ( $width / 10 ) ),
1192                 y => ( $y_pos + ( $height / 10 ) ),
1193                 value => $barcode,
1194                 ySize => ( .02 * $height ),
1195                 xSize => $xsize_ratio,
1196             );
1197         };
1198         if ($@) {
1199             warn "$barcodetype, $barcode FAILED:$@";
1200         }
1201     }
1202
1203     my $moo2 = $tot_bar_length * $xsize_ratio;
1204
1205     warn "$x_pos, $y_pos, $barcode, $barcodetype" if $debug;
1206     warn "BAR_WDTH = $bar_width, TOT.BAR.LGHT=$tot_bar_length  R*TOT.BAR =$moo2" if $debug;
1207 }
1208
1209 =item build_circ_barcode;
1210
1211   build_circ_barcode( $x_pos, $y_pos, $barcode,
1212                 $barcodetype, \$item);
1213
1214 $item is the result of a previous call to GetLabelItems();
1215
1216 =cut
1217
1218 #'
1219 sub build_circ_barcode {
1220     my ( $x_pos_circ, $y_pos, $value, $barcodetype, $item ) = @_;
1221
1222     #warn Dumper \$item;
1223
1224     #warn "value = $value\n";
1225
1226     #$DB::single = 1;
1227
1228     if ( $barcodetype eq 'EAN13' ) {
1229
1230         #testing EAN13 barcodes hack
1231         $value = $value . '000000000';
1232         $value =~ s/-//;
1233         $value = substr( $value, 0, 12 );
1234
1235         #warn $value;
1236         eval {
1237             PDF::Reuse::Barcode::EAN13(
1238                 x     => ( $x_pos_circ + 27 ),
1239                 y     => ( $y_pos + 15 ),
1240                 value => $value,
1241
1242                 #            prolong => 2.96,
1243                 #            xSize   => 1.5,
1244
1245                 # ySize   => 1.2,
1246
1247 # added for xpdf compat. doesnt use type3 fonts., but increases filesize from 20k to 200k
1248 # i think its embedding extra fonts in the pdf file.
1249 #  mode => 'graphic',
1250             );
1251         };
1252         if ($@) {
1253             $item->{'barcodeerror'} = 1;
1254
1255             #warn "EAN13BARCODE FAILED:$@";
1256         }
1257
1258         #warn $barcodetype;
1259
1260     }
1261     elsif ( $barcodetype eq 'Code39' ) {
1262
1263         eval {
1264             PDF::Reuse::Barcode::Code39(
1265                 x     => ( $x_pos_circ + 9 ),
1266                 y     => ( $y_pos + 15 ),
1267                 value => $value,
1268
1269                 #           prolong => 2.96,
1270                 xSize => .85,
1271
1272                 ySize => 1.3,
1273             );
1274         };
1275         if ($@) {
1276             $item->{'barcodeerror'} = 1;
1277
1278             #warn "CODE39BARCODE $value FAILED:$@";
1279         }
1280
1281         #warn $barcodetype;
1282
1283     }
1284
1285     elsif ( $barcodetype eq 'Matrix2of5' ) {
1286
1287         #warn "MATRIX ELSE:";
1288
1289         #testing MATRIX25  barcodes hack
1290         #    $value = $value.'000000000';
1291         $value =~ s/-//;
1292
1293         #    $value = substr( $value, 0, 12 );
1294         #warn $value;
1295
1296         eval {
1297             PDF::Reuse::Barcode::Matrix2of5(
1298                 x     => ( $x_pos_circ + 27 ),
1299                 y     => ( $y_pos + 15 ),
1300                 value => $value,
1301
1302                 #        prolong => 2.96,
1303                 #       xSize   => 1.5,
1304
1305                 # ySize   => 1.2,
1306             );
1307         };
1308         if ($@) {
1309             $item->{'barcodeerror'} = 1;
1310
1311             #warn "BARCODE FAILED:$@";
1312         }
1313
1314         #warn $barcodetype;
1315
1316     }
1317
1318     elsif ( $barcodetype eq 'EAN8' ) {
1319
1320         #testing ean8 barcodes hack
1321         $value = $value . '000000000';
1322         $value =~ s/-//;
1323         $value = substr( $value, 0, 8 );
1324
1325         #warn $value;
1326
1327         #warn "EAN8 ELSEIF";
1328         eval {
1329             PDF::Reuse::Barcode::EAN8(
1330                 x       => ( $x_pos_circ + 42 ),
1331                 y       => ( $y_pos + 15 ),
1332                 value   => $value,
1333                 prolong => 2.96,
1334                 xSize   => 1.5,
1335
1336                 # ySize   => 1.2,
1337             );
1338         };
1339
1340         if ($@) {
1341             $item->{'barcodeerror'} = 1;
1342
1343             #warn "BARCODE FAILED:$@";
1344         }
1345
1346         #warn $barcodetype;
1347
1348     }
1349
1350     elsif ( $barcodetype eq 'UPC-E' ) {
1351         eval {
1352             PDF::Reuse::Barcode::UPCE(
1353                 x       => ( $x_pos_circ + 27 ),
1354                 y       => ( $y_pos + 15 ),
1355                 value   => $value,
1356                 prolong => 2.96,
1357                 xSize   => 1.5,
1358
1359                 # ySize   => 1.2,
1360             );
1361         };
1362
1363         if ($@) {
1364             $item->{'barcodeerror'} = 1;
1365
1366             #warn "BARCODE FAILED:$@";
1367         }
1368
1369         #warn $barcodetype;
1370
1371     }
1372     elsif ( $barcodetype eq 'NW7' ) {
1373         eval {
1374             PDF::Reuse::Barcode::NW7(
1375                 x       => ( $x_pos_circ + 27 ),
1376                 y       => ( $y_pos + 15 ),
1377                 value   => $value,
1378                 prolong => 2.96,
1379                 xSize   => 1.5,
1380
1381                 # ySize   => 1.2,
1382             );
1383         };
1384
1385         if ($@) {
1386             $item->{'barcodeerror'} = 1;
1387
1388             #warn "BARCODE FAILED:$@";
1389         }
1390
1391         #warn $barcodetype;
1392
1393     }
1394     elsif ( $barcodetype eq 'ITF' ) {
1395         eval {
1396             PDF::Reuse::Barcode::ITF(
1397                 x       => ( $x_pos_circ + 27 ),
1398                 y       => ( $y_pos + 15 ),
1399                 value   => $value,
1400                 prolong => 2.96,
1401                 xSize   => 1.5,
1402
1403                 # ySize   => 1.2,
1404             );
1405         };
1406
1407         if ($@) {
1408             $item->{'barcodeerror'} = 1;
1409
1410             #warn "BARCODE FAILED:$@";
1411         }
1412
1413         #warn $barcodetype;
1414
1415     }
1416     elsif ( $barcodetype eq 'Industrial2of5' ) {
1417         eval {
1418             PDF::Reuse::Barcode::Industrial2of5(
1419                 x       => ( $x_pos_circ + 27 ),
1420                 y       => ( $y_pos + 15 ),
1421                 value   => $value,
1422                 prolong => 2.96,
1423                 xSize   => 1.5,
1424
1425                 # ySize   => 1.2,
1426             );
1427         };
1428         if ($@) {
1429             $item->{'barcodeerror'} = 1;
1430
1431             #warn "BARCODE FAILED:$@";
1432         }
1433
1434         #warn $barcodetype;
1435
1436     }
1437     elsif ( $barcodetype eq 'IATA2of5' ) {
1438         eval {
1439             PDF::Reuse::Barcode::IATA2of5(
1440                 x       => ( $x_pos_circ + 27 ),
1441                 y       => ( $y_pos + 15 ),
1442                 value   => $value,
1443                 prolong => 2.96,
1444                 xSize   => 1.5,
1445
1446                 # ySize   => 1.2,
1447             );
1448         };
1449         if ($@) {
1450             $item->{'barcodeerror'} = 1;
1451
1452             #warn "BARCODE FAILED:$@";
1453         }
1454
1455         #warn $barcodetype;
1456
1457     }
1458
1459     elsif ( $barcodetype eq 'COOP2of5' ) {
1460         eval {
1461             PDF::Reuse::Barcode::COOP2of5(
1462                 x       => ( $x_pos_circ + 27 ),
1463                 y       => ( $y_pos + 15 ),
1464                 value   => $value,
1465                 prolong => 2.96,
1466                 xSize   => 1.5,
1467
1468                 # ySize   => 1.2,
1469             );
1470         };
1471         if ($@) {
1472             $item->{'barcodeerror'} = 1;
1473
1474             #warn "BARCODE FAILED:$@";
1475         }
1476
1477         #warn $barcodetype;
1478
1479     }
1480     elsif ( $barcodetype eq 'UPC-A' ) {
1481
1482         eval {
1483             PDF::Reuse::Barcode::UPCA(
1484                 x       => ( $x_pos_circ + 27 ),
1485                 y       => ( $y_pos + 15 ),
1486                 value   => $value,
1487                 prolong => 2.96,
1488                 xSize   => 1.5,
1489
1490                 # ySize   => 1.2,
1491             );
1492         };
1493         if ($@) {
1494             $item->{'barcodeerror'} = 1;
1495
1496             #warn "BARCODE FAILED:$@";
1497         }
1498
1499         #warn $barcodetype;
1500
1501     }
1502
1503 }
1504
1505 =item draw_boundaries
1506
1507  sub draw_boundaries ($x_pos_spine, $x_pos_circ1, $x_pos_circ2,
1508                 $y_pos, $spine_width, $label_height, $circ_width)
1509
1510 This sub draws boundary lines where the label outlines are, to aid in printer testing, and debugging.
1511
1512 =cut
1513
1514 #'
1515 sub draw_boundaries {
1516
1517     my (
1518         $x_pos_spine, $x_pos_circ1,  $x_pos_circ2, $y_pos,
1519         $spine_width, $label_height, $circ_width
1520     ) = @_;
1521
1522     my $y_pos_initial = ( ( 792 - 36 ) - 90 );
1523     $y_pos            = $y_pos_initial; # FIXME - why are we ignoring the y_pos parameter by redefining it?
1524     my $i             = 1;
1525
1526     for ( $i = 1 ; $i <= 8 ; $i++ ) {
1527
1528         &drawbox( $x_pos_spine, $y_pos, ($spine_width), ($label_height) );
1529
1530    #warn "OLD BOXES  x=$x_pos_spine, y=$y_pos, w=$spine_width, h=$label_height";
1531         &drawbox( $x_pos_circ1, $y_pos, ($circ_width), ($label_height) );
1532         &drawbox( $x_pos_circ2, $y_pos, ($circ_width), ($label_height) );
1533
1534         $y_pos = ( $y_pos - $label_height );
1535
1536     }
1537 }
1538
1539 =item drawbox
1540
1541         sub drawbox {   $lower_left_x, $lower_left_y,
1542                         $upper_right_x, $upper_right_y )
1543
1544 this is a low level sub, that draws a pdf box, it is called by draw_boxes
1545
1546 FYI: the  $upper_right_x and $upper_right_y values are RELATIVE to  $lower_left_x and $lower_left_y
1547
1548 and $lower_left_x, $lower_left_y are ABSOLUTE, this caught me out!
1549
1550 =cut
1551
1552 #'
1553 sub drawbox {
1554     my ( $llx, $lly, $urx, $ury ) = @_;
1555
1556     #    warn "llx,y= $llx,$lly  ,   urx,y=$urx,$ury \n";
1557
1558     my $str = "q\n";    # save the graphic state
1559     $str .= "0.5 w\n";              # border color red
1560     $str .= "1.0 0.0 0.0  RG\n";    # border color red
1561          #   $str .= "0.5 0.75 1.0 rg\n";           # fill color blue
1562     $str .= "1.0 1.0 1.0  rg\n";    # fill color white
1563
1564     $str .= "$llx $lly $urx $ury re\n";    # a rectangle
1565     $str .= "B\n";                         # fill (and a little more)
1566     $str .= "Q\n";                         # save the graphic state
1567
1568     prAdd($str);
1569
1570 }
1571
1572 END { }    # module clean-up code here (global destructor)
1573
1574 1;
1575 __END__
1576
1577 =back
1578
1579 =head1 AUTHOR
1580
1581 Mason James <mason@katipo.co.nz>
1582
1583 =cut
1584