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     my ($ll, $wnl, $dec, $cutter, $pubdate) = (0, 0, 0, 0, 0);
 911     $_ = $lccn;
 912     # lccn example 'HE8700.7 .P6T44 1983';
 913     my    @splits   = m/
 914         (^[a-zA-Z]+)            # HE
 915         ([0-9]+\.*[0-9]*)             # 8700.7
 916         \s*
 917         (\.*[a-zA-Z0-9]*)       # P6T44
 918         \s*
 919         ([0-9]*)                # 1983
 920         /x;
 921
 922     # strip something occuring spaces too
 923     $splits[0] =~ s/\s+$//;
 924     $splits[1] =~ s/\s+$//;
 925     $splits[2] =~ s/\s+$//;
 926
 927     return @splits;
 928 }
 929
 930 sub split_ddcn {
 931     my ($ddcn) = @_;
 932     $ddcn =~ s/\///g;   # in theory we should be able to simply remove all segmentation markers and arrive at the correct call number...
 933     $_ = $ddcn;
 934     # ddcn example R220.3 H2793Z H32 c.2
 935     my @splits = m/^([A-Z]{0,3})                # R (OS, REF, etc. up do three letters)
 936                     ([0-9]+\.[0-9]*)            # 220.3
 937                     \s?                         # space (not requiring anything beyond the call number)
 938                     ([a-zA-Z0-9]*\.?[a-zA-Z0-9])# cutter number... maybe, but if so it is in this position (Z indicates literary criticism)
 939                     \s?                         # space if it exists
 940                     ([a-zA-Z]*\.?[0-9]*)        # other indicators such as cutter for author of literary criticism in this example if it exists
 941                     \s?                         # space if ie exists
 942                     ([a-zA-Z]*\.?[0-9]*)        # other indicators such as volume number, copy number, edition date, etc. if it exists
 943                     /x;
 944     return @splits;
 945 }
 946
 947 sub split_fcn {
 948     my ($fcn) = @_;
 949     my @fcn_split = ();
 950     # Split fiction call numbers based on spaces
 951     SPLIT_FCN:
 952     while ($fcn) {
 953         if ($fcn =~ m/([A-Za-z0-9]+)(\W?).*?/x) {
 954             push (@fcn_split, $1);
 955             $fcn = $';
 956         }
 957         else {
 958             last SPLIT_FCN;     # No match, break out of the loop
 959         }
 960     }
 961     return @fcn_split;
 962 }
 963
 964 my %itemtypemap;
 965 # Class variable to avoid querying itemtypes for every DrawSpineText call!!
 966 sub get_itemtype_descriptions () {
 967     unless (scalar keys %itemtypemap) {
 968         my $sth = C4::Context->dbh->prepare("SELECT itemtype,description FROM itemtypes");
 969         $sth->execute();
 970         while (my $data = $sth->fetchrow_hashref) {
 971             $itemtypemap{$data->{itemtype}} = $data->{description};
 972         }
 973     }
 974     return \%itemtypemap;
 975 }
 976
 977 sub DrawSpineText {
 978     my ( $x_pos, $y_pos, $label_height, $label_width, $fontname, $fontsize, $left_text_margin,
 979         $text_wrap_cols, $item, $conf_data, $printingtype ) = @_;
 980
 981     # Replace item's itemtype with the more user-friendly description...
 982     my $descriptions = get_itemtype_descriptions();
 983     foreach (qw(itemtype itype)) {
 984         my $description = $descriptions->{$$item->{$_}} or next;
 985         $$item->{$_} = $description;
 986     }
 987     my $str = '';
 988
 989     my $top_text_margin = ( $fontsize + 3 );    #FIXME: This should be a template parameter and passed in...
 990     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.).
 991
 992     my $layout_id = $$conf_data->{'id'};
 993
 994     my $vPos = ( $y_pos + ( $label_height - $top_text_margin ) );
 995
 996     my @str_fields = get_text_fields($layout_id, 'codes' );
 997     my $record = GetMarcBiblio($$item->{biblionumber});
 998     # FIXME - returns all items, so you can't get data from an embedded holdings field.
 999     # TODO - add a GetMarcBiblio1item(bibnum,itemnum) or a GetMarcItem(itemnum).
1000
1001     my $old_fontname = $fontname; # We need to keep track of the original font passed in...
1002
1003     # Grab the cn_source and if that is NULL, the DefaultClassificationSource syspref
1004     my $cn_source = ($$item->{'cn_source'} ? $$item->{'cn_source'} : C4::Context->preference('DefaultClassificationSource'));
1005     for my $field (@str_fields) {
1006         $field->{'code'} or warn "get_text_fields($layout_id, 'codes') element missing 'code' field";
1007         if ($field->{'code'} eq 'itemtype') {
1008             $field->{'data'} = C4::Context->preference('item-level_itypes') ? $$item->{'itype'} : $$item->{'itemtype'};
1009         }
1010         elsif ($$conf_data->{'formatstring'}) {
1011             # if labels_conf.formatstring has a value, then it overrides the  hardcoded option.
1012             $field->{'data'} = GetBarcodeData($field->{'code'},$$item,$record) ;
1013         }
1014         else {
1015             $field->{'data'} = $$item->{$field->{'code'}};
1016         }
1017         # This allows us to print the title in italic (oblique) type... (Times Roman has a different nomenclature.)
1018         # It seems there should be a better way to handle fonts in the label/patron card tool altogether -fbcit
1019         ($field->{code} eq 'title') ? (($old_fontname =~ /T/) ? ($fontname = 'TI') : ($fontname = ($old_fontname . 'O'))) : ($fontname = $old_fontname);
1020         my $font = prFont($fontname);
1021         # if the display option for this field is selected in the DB,
1022         # and the item record has some values for this field, display it.
1023         # Or if there is a csv list of fields to display, display them.
1024         if ( ($$conf_data->{'formatstring'}) || ( $$conf_data->{$field->{code}} && $$item->{$field->{code}} ) ) {
1025             # get the string
1026             my $str = $field->{data} ;
1027             # strip out naughty existing nl/cr's
1028             $str =~ s/\n//g;
1029             $str =~ s/\r//g;
1030             my @strings;
1031             my @callnumber_list = ('itemcallnumber', '050a', '050b', '082a', '952o'); # Fields which hold call number data  ( 060? 090? 092? 099? )
1032             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
1033                 if ($cn_source eq 'lcc') {
1034                     @strings = split_lccn($str);
1035                     @strings = split_fcn($str) if !@strings;    # If it was not a true lccn, try it as a fiction call number
1036                     push (@strings, $str) if !@strings;         # If it was not that, send it on unsplit
1037                 } elsif ($cn_source eq 'ddc') {
1038                     @strings = split_ddcn($str);
1039                     @strings = split_fcn($str) if !@strings;
1040                     push (@strings, $str) if !@strings;
1041                 } else {
1042                     # FIXME Need error trapping here; something to be informative to the user perhaps -crn
1043                     push @strings, $str;
1044                 }
1045             } else {
1046                 $str =~ s/\/$//g;       # Here we will strip out all trailing '/' in fields other than the call number...
1047                 $str =~ s/\(/\\\(/g;    # Escape '(' and ')' for the postscript stream...
1048                 $str =~ s/\)/\\\)/g;
1049                 # Wrap text lines exceeding $text_wrap_cols length...
1050                 $Text::Wrap::columns = $text_wrap_cols;
1051                 my @line = split(/\n/ ,wrap('', '', $str));
1052                 # If this is a title field, limit to two lines; all others limit to one...
1053                 my $limit = ($field->{code} eq 'title') ? 2 : 1;
1054                 while (scalar(@line) > $limit) {
1055                     pop @line;
1056                 }
1057                 push(@strings, @line);
1058             }
1059             # loop for each string line
1060             foreach my $str (@strings) {
1061                 my $hPos = $x_pos;
1062                 my $stringwidth = prStrWidth($str, $fontname, $fontsize);
1063                 if ( $$conf_data->{'text_justify'} eq 'R' ) {
1064                     $hPos += $label_width - ($left_text_margin + $stringwidth);
1065                 } elsif($$conf_data->{'text_justify'} eq 'C') {
1066                     # some code to try and center each line on the label based on font size and string point width...
1067                     my $whitespace = ( $label_width - ( $stringwidth + (2 * $left_text_margin) ) );
1068                     $hPos += ($whitespace / 2) + $left_text_margin;
1069                     #warn "\$label_width=$label_width \$stringwidth=$stringwidth \$whitespace=$whitespace \$left_text_margin=$left_text_margin for $str\n";
1070                 } else {
1071                     $hPos += $left_text_margin;
1072                 }
1073 # utf8::encode($str);
1074 # Say $str has a diacritical like: The séance
1075 # WITOUT encode, PrintText crashes with: Wide character in syswrite at /usr/local/share/perl/5.8.8/PDF/Reuse.pm line 968
1076 # WITH   encode, PrintText prints: The seÌ•ancee
1077 # Neither is appropriate.
1078                 PrintText( $hPos, $vPos, $font, $fontsize, $str );
1079                 $vPos -= $line_spacer;
1080             }
1081         }
1082     }   #foreach field
1083 }
1084
1085 sub PrintText {
1086     my ( $hPos, $vPos, $font, $fontsize, $text ) = @_;
1087     my $str = "BT /$font $fontsize Tf $hPos $vPos Td ($text) Tj ET";
1088     prAdd($str);
1089 }
1090
1091 sub DrawPatronCardText {
1092     my ( $x_pos, $y_pos, $label_height, $label_width, $fontname, $fontsize, $left_text_margin,
1093         $text_wrap_cols, $text, $printingtype )
1094       = @_;
1095
1096     my $top_text_margin = 25;    #FIXME: This should be a template parameter and passed in...
1097
1098     my $vPos   = ( $y_pos + ( $label_height - $top_text_margin ) );
1099     my $font = prFont($fontname);
1100
1101     my $hPos = 0;
1102
1103     foreach my $line (keys %$text) {
1104         $debug and warn "Current text is \"$line\" and font size for \"$line\" is $text->{$line} points";
1105         # some code to try and center each line on the label based on font size and string point width...
1106         my $stringwidth = prStrWidth($line, $fontname, $text->{$line});
1107         my $whitespace = ( $label_width - ( $stringwidth + (2 * $left_text_margin) ) );
1108         $hPos = ( ( $whitespace  / 2 ) + $x_pos + $left_text_margin );
1109
1110         PrintText( $hPos, $vPos, $font, $text->{$line}, $line );
1111         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.).
1112         $vPos = $vPos - ($line_spacer + $text->{$line});   # Linefeed equiv: leading + font size
1113     }
1114 }
1115
1116 # Not used anywhere.
1117
1118 #sub SetFontSize {
1119 #
1120 #    my ($fontsize) = @_;
1121 #### fontsize
1122 #    my $str = "BT/F13 30 Tf288 720 Td( AAAAAAAAAA ) TjET";
1123 #    prAdd($str);
1124 #}
1125
1126 sub DrawBarcode {
1127     # x and y are from the top-left :)
1128     my ( $x_pos, $y_pos, $height, $width, $barcode, $barcodetype ) = @_;
1129     my $num_of_bars = length($barcode);
1130     my $bar_width   = $width * .8;        # %80 of length of label width
1131     my $tot_bar_length = 0;
1132     my $bar_length = 0;
1133     my $guard_length = 10;
1134     my $xsize_ratio = 0;
1135
1136     if ( $barcodetype eq 'CODE39' ) {
1137         $bar_length = '17.5';
1138         $tot_bar_length =
1139           ( $bar_length * $num_of_bars ) + ( $guard_length * 2 );
1140         $xsize_ratio = ( $bar_width / $tot_bar_length );
1141         eval {
1142             PDF::Reuse::Barcode::Code39(
1143                 x => ( $x_pos + ( $width / 10 ) ),
1144                 y => ( $y_pos + ( $height / 10 ) ),
1145                 value         => "*$barcode*",
1146                 ySize         => ( .02 * $height ),
1147                 xSize         => $xsize_ratio,
1148                 hide_asterisk => 1,
1149             );
1150         };
1151     }
1152     elsif ( $barcodetype eq 'CODE39MOD' ) {
1153         # get modulo43 checksum
1154         my $c39 = CheckDigits('code_39');
1155         $barcode = $c39->complete($barcode);
1156
1157         $bar_length = '19';
1158         $tot_bar_length =
1159           ( $bar_length * $num_of_bars ) + ( $guard_length * 2 );
1160         $xsize_ratio = ( $bar_width / $tot_bar_length );
1161         eval {
1162             PDF::Reuse::Barcode::Code39(
1163                 x => ( $x_pos + ( $width / 10 ) ),
1164                 y => ( $y_pos + ( $height / 10 ) ),
1165                 value         => "*$barcode*",
1166                 ySize         => ( .02 * $height ),
1167                 xSize         => $xsize_ratio,
1168                 hide_asterisk => 1,
1169             );
1170         };
1171     }
1172     elsif ( $barcodetype eq 'CODE39MOD10' ) {
1173         # get modulo43 checksum
1174         my $c39_10 = CheckDigits('visa');
1175         $barcode = $c39_10->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                                 text          => 0,
1190             );
1191         };
1192     }
1193     elsif ( $barcodetype eq 'COOP2OF5' ) {
1194         $bar_length = '9.43333333333333';
1195         $tot_bar_length =
1196           ( $bar_length * $num_of_bars ) + ( $guard_length * 2 );
1197         $xsize_ratio = ( $bar_width / $tot_bar_length ) * .9;
1198         eval {
1199             PDF::Reuse::Barcode::COOP2of5(
1200                 x => ( $x_pos + ( $width / 10 ) ),
1201                 y => ( $y_pos + ( $height / 10 ) ),
1202                 value => $barcode,
1203                 ySize => ( .02 * $height ),
1204                 xSize => $xsize_ratio,
1205             );
1206         };
1207     }
1208     elsif ( $barcodetype eq 'INDUSTRIAL2OF5' ) {
1209         $bar_length = '13.1333333333333';
1210         $tot_bar_length =
1211           ( $bar_length * $num_of_bars ) + ( $guard_length * 2 );
1212         $xsize_ratio = ( $bar_width / $tot_bar_length ) * .9;
1213         eval {
1214             PDF::Reuse::Barcode::Industrial2of5(
1215                 x => ( $x_pos + ( $width / 10 ) ),
1216                 y => ( $y_pos + ( $height / 10 ) ),
1217                 value => $barcode,
1218                 ySize => ( .02 * $height ),
1219                 xSize => $xsize_ratio,
1220             );
1221         };
1222     } # else {die "Unknown barcodetype '$barcodetype'";}
1223
1224     if ($@) {
1225         warn "DrawBarcode (type: $barcodetype) FAILED for value '$barcode' :$@";
1226     }
1227
1228     my $moo2 = $tot_bar_length * $xsize_ratio;
1229
1230     warn "x_pos,y_pos,barcode,barcodetype = $x_pos, $y_pos, $barcode, $barcodetype\n"
1231         . "BAR_WDTH = $bar_width, TOT.BAR.LGHT=$tot_bar_length  R*TOT.BAR =$moo2" if $debug;
1232 }
1233
1234 =head2 build_circ_barcode;
1235
1236   build_circ_barcode( $x_pos, $y_pos, $barcode, $barcodetype, \$item);
1237
1238 $item is the result of a previous call to GetLabelItems();
1239
1240 =cut
1241
1242 sub build_circ_barcode {
1243     my ( $x_pos_circ, $y_pos, $value, $barcodetype, $item ) = @_;
1244
1245     #warn Dumper \$item;
1246     #warn "Barcode (type: $barcodetype) value = $value\n";
1247     #$DB::single = 1;
1248
1249     if ( $barcodetype eq 'EAN13' ) {
1250         #testing EAN13 barcodes hack
1251         $value = $value . '000000000';
1252         $value =~ s/-//;
1253         $value = substr( $value, 0, 12 );
1254         #warn "revised value: $value";
1255         eval {
1256             PDF::Reuse::Barcode::EAN13(
1257                 x     => ( $x_pos_circ + 27 ),
1258                 y     => ( $y_pos + 15 ),
1259                 value => $value,
1260                 # prolong => 2.96,
1261                 # xSize   => 1.5,
1262                 # ySize   => 1.2,
1263 # added for xpdf compat. doesnt use type3 fonts., but increases filesize from 20k to 200k
1264 # i think its embedding extra fonts in the pdf file.
1265 #  mode => 'graphic',
1266             );
1267         };
1268     }
1269     elsif ( $barcodetype eq 'Code39' ) {
1270         eval {
1271             PDF::Reuse::Barcode::Code39(
1272                 x     => ( $x_pos_circ + 9 ),
1273                 y     => ( $y_pos + 15 ),
1274                 value => $value,
1275                 # prolong => 2.96,
1276                 xSize => .85,
1277                 ySize => 1.3,
1278             );
1279         };
1280     }
1281     elsif ( $barcodetype eq 'Matrix2of5' ) {
1282         # testing MATRIX25  barcodes hack
1283         # $value = $value.'000000000';
1284         $value =~ s/-//;
1285         # $value = substr( $value, 0, 12 );
1286         #warn "revised value: $value";
1287         eval {
1288             PDF::Reuse::Barcode::Matrix2of5(
1289                 x     => ( $x_pos_circ + 27 ),
1290                 y     => ( $y_pos + 15 ),
1291                 value => $value,
1292                 # prolong => 2.96,
1293                 # xSize   => 1.5,
1294                 # ySize   => 1.2,
1295             );
1296         };
1297     }
1298     elsif ( $barcodetype eq 'EAN8' ) {
1299         #testing ean8 barcodes hack
1300         $value = $value . '000000000';
1301         $value =~ s/-//;
1302         $value = substr( $value, 0, 8 );
1303         #warn "revised value: $value";
1304         eval {
1305             PDF::Reuse::Barcode::EAN8(
1306                 x       => ( $x_pos_circ + 42 ),
1307                 y       => ( $y_pos + 15 ),
1308                 value   => $value,
1309                 prolong => 2.96,
1310                 xSize   => 1.5,
1311                 # ySize   => 1.2,
1312             );
1313         };
1314     }
1315     elsif ( $barcodetype eq 'UPC-E' ) {
1316         eval {
1317             PDF::Reuse::Barcode::UPCE(
1318                 x       => ( $x_pos_circ + 27 ),
1319                 y       => ( $y_pos + 15 ),
1320                 value   => $value,
1321                 prolong => 2.96,
1322                 xSize   => 1.5,
1323                 # ySize   => 1.2,
1324             );
1325         };
1326     }
1327     elsif ( $barcodetype eq 'NW7' ) {
1328         eval {
1329             PDF::Reuse::Barcode::NW7(
1330                 x       => ( $x_pos_circ + 27 ),
1331                 y       => ( $y_pos + 15 ),
1332                 value   => $value,
1333                 prolong => 2.96,
1334                 xSize   => 1.5,
1335                 # ySize   => 1.2,
1336             );
1337         };
1338     }
1339     elsif ( $barcodetype eq 'ITF' ) {
1340         eval {
1341             PDF::Reuse::Barcode::ITF(
1342                 x       => ( $x_pos_circ + 27 ),
1343                 y       => ( $y_pos + 15 ),
1344                 value   => $value,
1345                 prolong => 2.96,
1346                 xSize   => 1.5,
1347                 # ySize   => 1.2,
1348             );
1349         };
1350     }
1351     elsif ( $barcodetype eq 'Industrial2of5' ) {
1352         eval {
1353             PDF::Reuse::Barcode::Industrial2of5(
1354                 x       => ( $x_pos_circ + 27 ),
1355                 y       => ( $y_pos + 15 ),
1356                 value   => $value,
1357                 prolong => 2.96,
1358                 xSize   => 1.5,
1359                 # ySize   => 1.2,
1360             );
1361         };
1362     }
1363     elsif ( $barcodetype eq 'IATA2of5' ) {
1364         eval {
1365             PDF::Reuse::Barcode::IATA2of5(
1366                 x       => ( $x_pos_circ + 27 ),
1367                 y       => ( $y_pos + 15 ),
1368                 value   => $value,
1369                 prolong => 2.96,
1370                 xSize   => 1.5,
1371                 # ySize   => 1.2,
1372             );
1373         };
1374     }
1375     elsif ( $barcodetype eq 'COOP2of5' ) {
1376         eval {
1377             PDF::Reuse::Barcode::COOP2of5(
1378                 x       => ( $x_pos_circ + 27 ),
1379                 y       => ( $y_pos + 15 ),
1380                 value   => $value,
1381                 prolong => 2.96,
1382                 xSize   => 1.5,
1383                 # ySize   => 1.2,
1384             );
1385         };
1386     }
1387     elsif ( $barcodetype eq 'UPC-A' ) {
1388         eval {
1389             PDF::Reuse::Barcode::UPCA(
1390                 x       => ( $x_pos_circ + 27 ),
1391                 y       => ( $y_pos + 15 ),
1392                 value   => $value,
1393                 prolong => 2.96,
1394                 xSize   => 1.5,
1395                 # ySize   => 1.2,
1396             );
1397         };
1398     }
1399     if ($@) {
1400         $item->{'barcodeerror'} = 1;
1401         #warn "BARCODE (type: $barcodetype) FAILED:$@";
1402     }
1403 }
1404
1405 =head2 draw_boundaries
1406
1407  sub draw_boundaries ($x_pos_spine, $x_pos_circ1, $x_pos_circ2,
1408                 $y_pos, $spine_width, $label_height, $circ_width)
1409
1410 This sub draws boundary lines where the label outlines are, to aid in printer testing, and debugging.
1411
1412 =cut
1413
1414 sub draw_boundaries {
1415     my (
1416         $x_pos_spine, $x_pos_circ1,  $x_pos_circ2, $y_pos,
1417         $spine_width, $label_height, $circ_width
1418     ) = @_;
1419
1420     my $y_pos_initial = ( ( 792 - 36 ) - 90 );
1421     $y_pos            = $y_pos_initial; # FIXME - why are we ignoring the y_pos parameter by redefining it?
1422     my $i             = 1;
1423
1424     for ( $i = 1 ; $i <= 8 ; $i++ ) {
1425         &drawbox( $x_pos_spine, $y_pos, ($spine_width), ($label_height) );
1426    #warn "OLD BOXES  x=$x_pos_spine, y=$y_pos, w=$spine_width, h=$label_height";
1427         &drawbox( $x_pos_circ1, $y_pos, ($circ_width), ($label_height) );
1428         &drawbox( $x_pos_circ2, $y_pos, ($circ_width), ($label_height) );
1429         $y_pos = ( $y_pos - $label_height );
1430     }
1431 }
1432
1433 =head2 drawbox
1434
1435         sub drawbox {   $lower_left_x, $lower_left_y,
1436                         $upper_right_x, $upper_right_y )
1437
1438 this is a low level sub, that draws a pdf box, it is called by draw_boxes
1439
1440 FYI: the  $upper_right_x and $upper_right_y values are RELATIVE to  $lower_left_x and $lower_left_y
1441
1442 and $lower_left_x, $lower_left_y are ABSOLUTE, this caught me out!
1443
1444 =cut
1445
1446 sub drawbox {
1447     my ( $llx, $lly, $urx, $ury ) = @_;
1448     #    warn "llx,y= $llx,$lly  ,   urx,y=$urx,$ury \n";
1449
1450     my $str = "q\n";    # save the graphic state
1451     $str .= "0.5 w\n";              # border color red
1452     $str .= "1.0 0.0 0.0  RG\n";    # border color red
1453          #   $str .= "0.5 0.75 1.0 rg\n";           # fill color blue
1454     $str .= "1.0 1.0 1.0  rg\n";    # fill color white
1455
1456     $str .= "$llx $lly $urx $ury re\n";    # a rectangle
1457     $str .= "B\n";                         # fill (and a little more)
1458     $str .= "Q\n";                         # save the graphic state
1459
1460     prAdd($str);
1461 }
1462
1463 1;
1464 __END__
1465
1466 =head1 AUTHOR
1467
1468 Mason James <mason@katipo.co.nz>
1469
1470 =cut
1471