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