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