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