C4/Labels.pm

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