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