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