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 sub split_lccn {
 909     my ($lccn) = @_;
 910     $_ = $lccn;
 911     # lccn examples: 'HE8700.7 .P6T44 1983', 'BS2545.E8 H39 1996';
 912     my (@parts) = m/
 913         ^([a-zA-Z]+)      # HE          # BS
 914         (\d+(?:\.\d)*)    # 8700.7      # 2545
 915         \s*
 916         (\.*\D+\d*)       # .P6         # .E8
 917         \s*
 918         (.*)              # T44 1983    # H39 1996   # everything else (except any bracketing spaces)
 919         \s*
 920         /x;
 921     unless (scalar @parts)  {
 922         $debug and print STDERR "split_lccn regexp failed to match string: $_\n";
 923         push @parts, $_;     # if no match, just push the whole string.
 924     }
 925     push @parts, split /\s+/, pop @parts;   # split the last piece into an arbitrary number of pieces at spaces
 926     $debug and print STDERR "split_lccn array: ", join(" | ", @parts), "\n";
 927     return @parts;
 928 }
 929
 930 our $possible_decimal = qr/\d{3,}(?:\.\d+)?/; # at least three digits for a DDCN
 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.*$/ && $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                 next if $str eq '';
1081                 my $stringwidth = prStrWidth($str, $fontname, $fontsize);
1082                 if ( $$conf_data->{'text_justify'} eq 'R' ) {
1083                     $hPos += $label_width - ($left_text_margin + $stringwidth);
1084                 } elsif($$conf_data->{'text_justify'} eq 'C') {
1085                     # some code to try and center each line on the label based on font size and string point width...
1086                     my $whitespace = ( $label_width - ( $stringwidth + (2 * $left_text_margin) ) );
1087                     $hPos += ($whitespace / 2) + $left_text_margin;
1088                     #warn "\$label_width=$label_width \$stringwidth=$stringwidth \$whitespace=$whitespace \$left_text_margin=$left_text_margin for $str\n";
1089                 } else {
1090                     $hPos += $left_text_margin;
1091                 }
1092 # utf8::encode($str);
1093 # Say $str has a diacritical like: The séance
1094 # WITOUT encode, PrintText crashes with: Wide character in syswrite at /usr/local/share/perl/5.8.8/PDF/Reuse.pm line 968
1095 # WITH   encode, PrintText prints: The seÌ•ancee
1096 # Neither is appropriate.
1097                 PrintText( $hPos, $vPos, $font, $fontsize, $str );
1098                 $vPos -= $line_spacer;
1099             }
1100         }
1101     }   #foreach field
1102 }
1103
1104 sub PrintText {
1105     my ( $hPos, $vPos, $font, $fontsize, $text ) = @_;
1106     my $str = "BT /$font $fontsize Tf $hPos $vPos Td ($text) Tj ET";
1107     prAdd($str);
1108 }
1109
1110 sub DrawPatronCardText {
1111     my ( $x_pos, $y_pos, $label_height, $label_width, $fontname, $fontsize, $left_text_margin,
1112         $text_wrap_cols, $text, $printingtype )
1113       = @_;
1114
1115     my $top_text_margin = 25;    #FIXME: This should be a template parameter and passed in...
1116
1117     my $vPos   = ( $y_pos + ( $label_height - $top_text_margin ) );
1118     my $font = prFont($fontname);
1119
1120     my $hPos = 0;
1121
1122     foreach my $line (keys %$text) {
1123         $debug and warn "Current text is \"$line\" and font size for \"$line\" is $text->{$line} points";
1124         # some code to try and center each line on the label based on font size and string point width...
1125         my $stringwidth = prStrWidth($line, $fontname, $text->{$line});
1126         my $whitespace = ( $label_width - ( $stringwidth + (2 * $left_text_margin) ) );
1127         $hPos = ( ( $whitespace  / 2 ) + $x_pos + $left_text_margin );
1128
1129         PrintText( $hPos, $vPos, $font, $text->{$line}, $line );
1130         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.).
1131         $vPos = $vPos - ($line_spacer + $text->{$line});   # Linefeed equiv: leading + font size
1132     }
1133 }
1134
1135 # Not used anywhere.
1136
1137 #sub SetFontSize {
1138 #
1139 #    my ($fontsize) = @_;
1140 #### fontsize
1141 #    my $str = "BT/F13 30 Tf288 720 Td( AAAAAAAAAA ) TjET";
1142 #    prAdd($str);
1143 #}
1144
1145 sub DrawBarcode {
1146     # x and y are from the top-left :)
1147     my ( $x_pos, $y_pos, $height, $width, $barcode, $barcodetype ) = @_;
1148     my $num_of_bars = length($barcode);
1149     my $bar_width   = $width * .8;        # %80 of length of label width
1150     my $tot_bar_length = 0;
1151     my $bar_length = 0;
1152     my $guard_length = 10;
1153     my $xsize_ratio = 0;
1154
1155     if ( $barcodetype eq 'CODE39' ) {
1156         $bar_length = '17.5';
1157         $tot_bar_length =
1158           ( $bar_length * $num_of_bars ) + ( $guard_length * 2 );
1159         $xsize_ratio = ( $bar_width / $tot_bar_length );
1160         eval {
1161             PDF::Reuse::Barcode::Code39(
1162                 x => ( $x_pos + ( $width / 10 ) ),
1163                 y => ( $y_pos + ( $height / 10 ) ),
1164                 value         => "*$barcode*",
1165                 ySize         => ( .02 * $height ),
1166                 xSize         => $xsize_ratio,
1167                 hide_asterisk => 1,
1168                 mode          => 'graphic',  # the only other option here is Type3...
1169             );
1170         };
1171     }
1172     elsif ( $barcodetype eq 'CODE39MOD' ) {
1173         # get modulo43 checksum
1174         my $c39 = CheckDigits('code_39');
1175         $barcode = $c39->complete($barcode);
1176
1177         $bar_length = '19';
1178         $tot_bar_length =
1179           ( $bar_length * $num_of_bars ) + ( $guard_length * 2 );
1180         $xsize_ratio = ( $bar_width / $tot_bar_length );
1181         eval {
1182             PDF::Reuse::Barcode::Code39(
1183                 x => ( $x_pos + ( $width / 10 ) ),
1184                 y => ( $y_pos + ( $height / 10 ) ),
1185                 value         => "*$barcode*",
1186                 ySize         => ( .02 * $height ),
1187                 xSize         => $xsize_ratio,
1188                 hide_asterisk => 1,
1189                 mode          => 'graphic',  # the only other option here is Type3...
1190             );
1191         };
1192     }
1193     elsif ( $barcodetype eq 'CODE39MOD10' ) {
1194         # get modulo43 checksum
1195         my $c39_10 = CheckDigits('visa');
1196         $barcode = $c39_10->complete($barcode);
1197
1198         $bar_length = '19';
1199         $tot_bar_length =
1200           ( $bar_length * $num_of_bars ) + ( $guard_length * 2 );
1201         $xsize_ratio = ( $bar_width / $tot_bar_length );
1202         eval {
1203             PDF::Reuse::Barcode::Code39(
1204                 x => ( $x_pos + ( $width / 10 ) ),
1205                 y => ( $y_pos + ( $height / 10 ) ),
1206                 value         => "*$barcode*",
1207                 ySize         => ( .02 * $height ),
1208                 xSize         => $xsize_ratio,
1209                 hide_asterisk => 1,
1210                 text          => 0,
1211                 mode          => 'graphic',  # the only other option here is Type3...
1212             );
1213         };
1214     }
1215     elsif ( $barcodetype eq 'COOP2OF5' ) {
1216         $bar_length = '9.43333333333333';
1217         $tot_bar_length =
1218           ( $bar_length * $num_of_bars ) + ( $guard_length * 2 );
1219         $xsize_ratio = ( $bar_width / $tot_bar_length ) * .9;
1220         eval {
1221             PDF::Reuse::Barcode::COOP2of5(
1222                 x => ( $x_pos + ( $width / 10 ) ),
1223                 y => ( $y_pos + ( $height / 10 ) ),
1224                 value => $barcode,
1225                 ySize => ( .02 * $height ),
1226                 xSize => $xsize_ratio,
1227             );
1228         };
1229     }
1230     elsif ( $barcodetype eq 'INDUSTRIAL2OF5' ) {
1231         $bar_length = '13.1333333333333';
1232         $tot_bar_length =
1233           ( $bar_length * $num_of_bars ) + ( $guard_length * 2 );
1234         $xsize_ratio = ( $bar_width / $tot_bar_length ) * .9;
1235         eval {
1236             PDF::Reuse::Barcode::Industrial2of5(
1237                 x => ( $x_pos + ( $width / 10 ) ),
1238                 y => ( $y_pos + ( $height / 10 ) ),
1239                 value => $barcode,
1240                 ySize => ( .02 * $height ),
1241                 xSize => $xsize_ratio,
1242             );
1243         };
1244     } # else {die "Unknown barcodetype '$barcodetype'";}
1245
1246     if ($@) {
1247         warn "DrawBarcode (type: $barcodetype) FAILED for value '$barcode' :$@";
1248     }
1249
1250     my $moo2 = $tot_bar_length * $xsize_ratio;
1251
1252     warn "x_pos,y_pos,barcode,barcodetype = $x_pos, $y_pos, $barcode, $barcodetype\n"
1253         . "BAR_WDTH = $bar_width, TOT.BAR.LGHT=$tot_bar_length  R*TOT.BAR =$moo2" if $debug;
1254 }
1255
1256 =head2 build_circ_barcode;
1257
1258   build_circ_barcode( $x_pos, $y_pos, $barcode, $barcodetype, \$item);
1259
1260 $item is the result of a previous call to GetLabelItems();
1261
1262 =cut
1263
1264 sub build_circ_barcode {
1265     my ( $x_pos_circ, $y_pos, $value, $barcodetype, $item ) = @_;
1266
1267     #warn Dumper \$item;
1268     #warn "Barcode (type: $barcodetype) value = $value\n";
1269     #$DB::single = 1;
1270
1271     if ( $barcodetype eq 'EAN13' ) {
1272         #testing EAN13 barcodes hack
1273         $value = $value . '000000000';
1274         $value =~ s/-//;
1275         $value = substr( $value, 0, 12 );
1276         #warn "revised value: $value";
1277         eval {
1278             PDF::Reuse::Barcode::EAN13(
1279                 x     => ( $x_pos_circ + 27 ),
1280                 y     => ( $y_pos + 15 ),
1281                 value => $value,
1282                 # prolong => 2.96,
1283                 # xSize   => 1.5,
1284                 # ySize   => 1.2,
1285 # added for xpdf compat. doesnt use type3 fonts., but increases filesize from 20k to 200k
1286 # i think its embedding extra fonts in the pdf file.
1287 #  mode => 'graphic',
1288             );
1289         };
1290     }
1291     elsif ( $barcodetype eq 'Code39' ) {
1292         eval {
1293             PDF::Reuse::Barcode::Code39(
1294                 x     => ( $x_pos_circ + 9 ),
1295                 y     => ( $y_pos + 15 ),
1296                 value => $value,
1297                 # prolong => 2.96,
1298                 xSize => .85,
1299                 ySize => 1.3,
1300                 mode            => 'graphic',  # the only other option here is Type3...
1301             );
1302         };
1303     }
1304     elsif ( $barcodetype eq 'Matrix2of5' ) {
1305         # testing MATRIX25  barcodes hack
1306         # $value = $value.'000000000';
1307         $value =~ s/-//;
1308         # $value = substr( $value, 0, 12 );
1309         #warn "revised value: $value";
1310         eval {
1311             PDF::Reuse::Barcode::Matrix2of5(
1312                 x     => ( $x_pos_circ + 27 ),
1313                 y     => ( $y_pos + 15 ),
1314                 value => $value,
1315                 # prolong => 2.96,
1316                 # xSize   => 1.5,
1317                 # ySize   => 1.2,
1318             );
1319         };
1320     }
1321     elsif ( $barcodetype eq 'EAN8' ) {
1322         #testing ean8 barcodes hack
1323         $value = $value . '000000000';
1324         $value =~ s/-//;
1325         $value = substr( $value, 0, 8 );
1326         #warn "revised value: $value";
1327         eval {
1328             PDF::Reuse::Barcode::EAN8(
1329                 x       => ( $x_pos_circ + 42 ),
1330                 y       => ( $y_pos + 15 ),
1331                 value   => $value,
1332                 prolong => 2.96,
1333                 xSize   => 1.5,
1334                 # ySize   => 1.2,
1335             );
1336         };
1337     }
1338     elsif ( $barcodetype eq 'UPC-E' ) {
1339         eval {
1340             PDF::Reuse::Barcode::UPCE(
1341                 x       => ( $x_pos_circ + 27 ),
1342                 y       => ( $y_pos + 15 ),
1343                 value   => $value,
1344                 prolong => 2.96,
1345                 xSize   => 1.5,
1346                 # ySize   => 1.2,
1347             );
1348         };
1349     }
1350     elsif ( $barcodetype eq 'NW7' ) {
1351         eval {
1352             PDF::Reuse::Barcode::NW7(
1353                 x       => ( $x_pos_circ + 27 ),
1354                 y       => ( $y_pos + 15 ),
1355                 value   => $value,
1356                 prolong => 2.96,
1357                 xSize   => 1.5,
1358                 # ySize   => 1.2,
1359             );
1360         };
1361     }
1362     elsif ( $barcodetype eq 'ITF' ) {
1363         eval {
1364             PDF::Reuse::Barcode::ITF(
1365                 x       => ( $x_pos_circ + 27 ),
1366                 y       => ( $y_pos + 15 ),
1367                 value   => $value,
1368                 prolong => 2.96,
1369                 xSize   => 1.5,
1370                 # ySize   => 1.2,
1371             );
1372         };
1373     }
1374     elsif ( $barcodetype eq 'Industrial2of5' ) {
1375         eval {
1376             PDF::Reuse::Barcode::Industrial2of5(
1377                 x       => ( $x_pos_circ + 27 ),
1378                 y       => ( $y_pos + 15 ),
1379                 value   => $value,
1380                 prolong => 2.96,
1381                 xSize   => 1.5,
1382                 # ySize   => 1.2,
1383             );
1384         };
1385     }
1386     elsif ( $barcodetype eq 'IATA2of5' ) {
1387         eval {
1388             PDF::Reuse::Barcode::IATA2of5(
1389                 x       => ( $x_pos_circ + 27 ),
1390                 y       => ( $y_pos + 15 ),
1391                 value   => $value,
1392                 prolong => 2.96,
1393                 xSize   => 1.5,
1394                 # ySize   => 1.2,
1395             );
1396         };
1397     }
1398     elsif ( $barcodetype eq 'COOP2of5' ) {
1399         eval {
1400             PDF::Reuse::Barcode::COOP2of5(
1401                 x       => ( $x_pos_circ + 27 ),
1402                 y       => ( $y_pos + 15 ),
1403                 value   => $value,
1404                 prolong => 2.96,
1405                 xSize   => 1.5,
1406                 # ySize   => 1.2,
1407             );
1408         };
1409     }
1410     elsif ( $barcodetype eq 'UPC-A' ) {
1411         eval {
1412             PDF::Reuse::Barcode::UPCA(
1413                 x       => ( $x_pos_circ + 27 ),
1414                 y       => ( $y_pos + 15 ),
1415                 value   => $value,
1416                 prolong => 2.96,
1417                 xSize   => 1.5,
1418                 # ySize   => 1.2,
1419             );
1420         };
1421     }
1422     if ($@) {
1423         $item->{'barcodeerror'} = 1;
1424         #warn "BARCODE (type: $barcodetype) FAILED:$@";
1425     }
1426 }
1427
1428 =head2 draw_boundaries
1429
1430  sub draw_boundaries ($x_pos_spine, $x_pos_circ1, $x_pos_circ2,
1431                 $y_pos, $spine_width, $label_height, $circ_width)
1432
1433 This sub draws boundary lines where the label outlines are, to aid in printer testing, and debugging.
1434
1435 =cut
1436
1437 sub draw_boundaries {
1438     my (
1439         $x_pos_spine, $x_pos_circ1,  $x_pos_circ2, $y_pos,
1440         $spine_width, $label_height, $circ_width
1441     ) = @_;
1442
1443     my $y_pos_initial = ( ( 792 - 36 ) - 90 );
1444     $y_pos            = $y_pos_initial; # FIXME - why are we ignoring the y_pos parameter by redefining it?
1445     my $i             = 1;
1446
1447     for ( $i = 1 ; $i <= 8 ; $i++ ) {
1448         &drawbox( $x_pos_spine, $y_pos, ($spine_width), ($label_height) );
1449    #warn "OLD BOXES  x=$x_pos_spine, y=$y_pos, w=$spine_width, h=$label_height";
1450         &drawbox( $x_pos_circ1, $y_pos, ($circ_width), ($label_height) );
1451         &drawbox( $x_pos_circ2, $y_pos, ($circ_width), ($label_height) );
1452         $y_pos = ( $y_pos - $label_height );
1453     }
1454 }
1455
1456 =head2 drawbox
1457
1458         sub drawbox {   $lower_left_x, $lower_left_y,
1459                         $upper_right_x, $upper_right_y )
1460
1461 this is a low level sub, that draws a pdf box, it is called by draw_boxes
1462
1463 FYI: the  $upper_right_x and $upper_right_y values are RELATIVE to  $lower_left_x and $lower_left_y
1464
1465 and $lower_left_x, $lower_left_y are ABSOLUTE, this caught me out!
1466
1467 =cut
1468
1469 sub drawbox {
1470     my ( $llx, $lly, $urx, $ury ) = @_;
1471     #    warn "llx,y= $llx,$lly  ,   urx,y=$urx,$ury \n";
1472
1473     my $str = "q\n";    # save the graphic state
1474     $str .= "0.5 w\n";              # border color red
1475     $str .= "1.0 0.0 0.0  RG\n";    # border color red
1476          #   $str .= "0.5 0.75 1.0 rg\n";           # fill color blue
1477     $str .= "1.0 1.0 1.0  rg\n";    # fill color white
1478
1479     $str .= "$llx $lly $urx $ury re\n";    # a rectangle
1480     $str .= "B\n";                         # fill (and a little more)
1481     $str .= "Q\n";                         # save the graphic state
1482
1483     prAdd($str);
1484 }
1485
1486 1;
1487 __END__
1488
1489 =head1 AUTHOR
1490
1491 Mason James <mason@katipo.co.nz>
1492
1493 =cut
1494