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