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