C4/Labels.pm

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