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