koha-dev.rot13.org Git - koha_gimpoz/blob - C4/Labels.pm

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