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