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 require Exporter;
  22
  23 use vars qw($VERSION @ISA @EXPORT);
  24
  25 use PDF::Reuse;
  26 use Text::Wrap;
  27 use Algorithm::CheckDigits;
  28 # use Data::Dumper;
  29 # use Smart::Comments;
  30
  31 $VERSION = 0.01;
  32
  33 =head1 NAME
  34
  35 C4::Labels - Functions for printing spine labels and barcodes in Koha
  36
  37 =head1 FUNCTIONS
  38
  39 =over 2
  40
  41 =cut
  42
  43 @ISA    = qw(Exporter);
  44 @EXPORT = qw(
  45   &get_label_options &get_label_items
  46   &build_circ_barcode &draw_boundaries
  47   &drawbox &GetActiveLabelTemplate
  48   &GetAllLabelTemplates &DeleteTemplate
  49   &GetSingleLabelTemplate &SaveTemplate
  50   &CreateTemplate &SetActiveTemplate
  51   &SaveConf &DrawSpineText &GetTextWrapCols
  52   &GetUnitsValue &DrawBarcode
  53   &get_printingtypes
  54   &get_layouts
  55   &get_barcode_types
  56   &get_batches &delete_batch
  57   &add_batch &SetFontSize &printText
  58   &GetItemFields
  59   &get_text_fields
  60   get_layout &save_layout &add_layout
  61   &set_active_layout &by_order
  62   &build_text_dropbox
  63   &delete_layout &get_active_layout
  64 &get_highest_batch
  65 );
  66
  67 =item get_label_options;
  68
  69         $options = get_label_options()
  70
  71
  72 Return a pointer on a hash list containing info from labels_conf table in Koha DB.
  73
  74 =cut
  75
  76 #'
  77 sub get_label_options {
  78     my $dbh    = C4::Context->dbh;
  79     my $query2 = " SELECT * FROM labels_conf where active = 1";
  80     my $sth    = $dbh->prepare($query2);
  81     $sth->execute();
  82     my $conf_data = $sth->fetchrow_hashref;
  83     $sth->finish;
  84     return $conf_data;
  85 }
  86
  87 sub get_layouts {
  88
  89 ## FIXME: this if/else could be compacted...
  90     my $dbh = C4::Context->dbh;
  91     my @data;
  92     my $query = " Select * from labels_conf";
  93     my $sth   = $dbh->prepare($query);
  94     $sth->execute();
  95     my @resultsloop;
  96     while ( my $data = $sth->fetchrow_hashref ) {
  97
  98         $data->{'fieldlist'} = get_text_fields( $data->{'id'} );
  99         push( @resultsloop, $data );
 100     }
 101     $sth->finish;
 102
 103     # @resultsloop
 104
 105     return @resultsloop;
 106 }
 107
 108 sub get_layout {
 109     my ($layout_id) = @_;
 110     my $dbh = C4::Context->dbh;
 111
 112     # get the actual items to be printed.
 113     my $query = " Select * from labels_conf where id = ?";
 114     my $sth   = $dbh->prepare($query);
 115     $sth->execute($layout_id);
 116     my $data = $sth->fetchrow_hashref;
 117     $sth->finish;
 118     return $data;
 119 }
 120
 121 sub get_active_layout {
 122     my ($layout_id) = @_;
 123     my $dbh = C4::Context->dbh;
 124
 125     # get the actual items to be printed.
 126     my $query = " Select * from labels_conf where active = 1";
 127     my $sth   = $dbh->prepare($query);
 128     $sth->execute();
 129     my $data = $sth->fetchrow_hashref;
 130     $sth->finish;
 131     return $data;
 132 }
 133
 134 sub delete_layout {
 135     my ($layout_id) = @_;
 136     my $dbh = C4::Context->dbh;
 137
 138     # get the actual items to be printed.
 139     my $query = "delete from  labels_conf where id = ?";
 140     my $sth   = $dbh->prepare($query);
 141     $sth->execute($layout_id);
 142     $sth->finish;
 143 }
 144
 145 sub get_printingtypes {
 146     my ($layout_id) = @_;
 147     my @printtypes;
 148
 149     push( @printtypes, { code => 'BAR',    desc => "barcode" } );
 150     push( @printtypes, { code => 'BIB',    desc => "biblio" } );
 151     push( @printtypes, { code => 'BARBIB', desc => "barcode / biblio" } );
 152     push( @printtypes, { code => 'BIBBAR', desc => "biblio / barcode" } );
 153     push( @printtypes, { code => 'ALT',    desc => "alternating labels" } );
 154
 155     my $conf             = get_layout($layout_id);
 156     my $active_printtype = $conf->{'printingtype'};
 157
 158     # lop thru layout, insert selected to hash
 159
 160     foreach my $printtype (@printtypes) {
 161         if ( $printtype->{'code'} eq $active_printtype ) {
 162             $printtype->{'active'} = 'MOO';
 163         }
 164     }
 165     return @printtypes;
 166 }
 167
 168 sub build_text_dropbox {
 169     my ($order) = @_;
 170
 171     #  my @fields      = get_text_fields();
 172     #    my $field_count = scalar @fields;
 173     my $field_count = 10;    # <-----------       FIXME hard coded
 174
 175     my @lines;
 176     !$order
 177       ? push( @lines, { num => '', selected => '1' } )
 178       : push( @lines, { num => '' } );
 179     for ( my $i = 1 ; $i <= $field_count ; $i++ ) {
 180         my $line = { num => "$i" };
 181         $line->{'selected'} = 1 if $i eq $order;
 182         push( @lines, $line );
 183     }
 184
 185     # add a blank row too
 186
 187     return @lines;
 188 }
 189
 190 sub get_text_fields {
 191     my ($layout_id, $sorttype) = @_;
 192
 193     my ( $a, $b, $c, $d, $e, $f, $g, $h, $i ,$j, $k );
 194
 195     my $sortorder = get_layout($layout_id);
 196
 197     # $sortorder
 198
 199     $a = {
 200         code  => 'itemtype',
 201         desc  => "Item Type",
 202         order => $sortorder->{'itemtype'}
 203     };
 204     $b = {
 205         code  => 'dewey',
 206         desc  => "Dewey",
 207         order => $sortorder->{'dewey'}
 208     };
 209     $c = { code => 'issn', desc => "ISSN",
 210         order => $sortorder->{'issn'} };
 211     $d = { code => 'isbn', desc => "ISBN",
 212             order => $sortorder->{'isbn'} };
 213     $e = {
 214         code  => 'class',
 215         desc  => "Classification",
 216         order => $sortorder->{'class'}
 217     };
 218     $f = {
 219         code  => 'subclass',
 220         desc  => "Sub-Class",
 221         order => $sortorder->{'subclass'}
 222     };
 223     $g = {
 224         code  => 'barcode',
 225         desc  => "Barcode",
 226         order => $sortorder->{'barcode'}
 227     };
 228     $h =
 229       { code => 'author', desc => "Author", order => $sortorder->{'author'} };
 230     $i = { code => 'title', desc => "Title", order => $sortorder->{'title'} };
 231     $j = { code => 'itemcallnumber', desc => "Call Number", order => $sortorder->{'itemcallnumber'} };
 232         $k = { code => 'subtitle', desc => "Subtitle", order => $sortorder->{'subtitle'} };
 233
 234         my @text_fields = ( $a, $b, $c, $d, $e, $f, $g, $h, $i ,$j, $k );
 235
 236     my @new_fields;
 237     foreach my $field (@text_fields) {
 238         push( @new_fields, $field ) if $field->{'order'} > 0;
 239     }
 240
 241     my @sorted_fields = sort by_order @new_fields;
 242     my $active_fields;
 243     foreach my $field (@sorted_fields) {
 244      $sorttype eq 'codes' ?   $active_fields .= "$field->{'code'} " :
 245           $active_fields .= "$field->{'desc'} ";
 246     }
 247     return $active_fields;
 248
 249 }
 250
 251 sub by_order {
 252     $$a{order} <=> $$b{order};
 253 }
 254
 255 sub add_batch {
 256     my $new_batch;
 257     my $dbh = C4::Context->dbh;
 258     my $q =
 259       "select distinct batch_id from labels order by batch_id desc limit 1";
 260     my $sth = $dbh->prepare($q);
 261     $sth->execute();
 262     my $data = $sth->fetchrow_hashref;
 263     $sth->finish;
 264
 265     if ( !$data->{'batch_id'} ) {
 266         $new_batch = 1;
 267     }
 268     else {
 269         $new_batch = ( $data->{'batch_id'} + 1 );
 270     }
 271
 272     return $new_batch;
 273 }
 274
 275
 276 sub get_highest_batch {
 277     my $new_batch;
 278     my $dbh = C4::Context->dbh;
 279     my $q =
 280       "select distinct batch_id from labels order by batch_id desc limit 1";
 281     my $sth = $dbh->prepare($q);
 282     $sth->execute();
 283     my $data = $sth->fetchrow_hashref;
 284     $sth->finish;
 285
 286     if ( !$data->{'batch_id'} ) {
 287         $new_batch = 1;
 288     }
 289     else {
 290         $new_batch =  $data->{'batch_id'};
 291     }
 292
 293     return $new_batch;
 294 }
 295
 296
 297 sub get_batches {
 298     my $dbh = C4::Context->dbh;
 299     my $q   = "select batch_id, count(*) as num from labels group by batch_id";
 300     my $sth = $dbh->prepare($q);
 301     $sth->execute();
 302     my @resultsloop;
 303     while ( my $data = $sth->fetchrow_hashref ) {
 304         push( @resultsloop, $data );
 305     }
 306     $sth->finish;
 307
 308     # adding a dummy batch=1 value , if none exists in the db
 309     if ( !scalar(@resultsloop) ) {
 310         push( @resultsloop, { batch_id => '1' , num => '0' } );
 311     }
 312     return @resultsloop;
 313 }
 314
 315 sub delete_batch {
 316     my ($batch_id) = @_;
 317     my $dbh        = C4::Context->dbh;
 318     my $q          = "DELETE FROM labels where batch_id  = ?";
 319     my $sth        = $dbh->prepare($q);
 320     $sth->execute($batch_id);
 321     $sth->finish;
 322 }
 323
 324 sub get_barcode_types {
 325     my ($layout_id) = @_;
 326     my $layout      = get_layout($layout_id);
 327     my $barcode     = $layout->{'barcodetype'};
 328     my @array;
 329
 330     push( @array, { code => 'CODE39',    desc => 'Code 39' } );
 331     push( @array, { code => 'CODE39MOD', desc => 'Code39 + Modulo43' } );
 332     push( @array, { code => 'CODE39MOD10', desc => 'Code39 + Modulo10' } );
 333         push( @array, { code => 'ITF',       desc => 'Interleaved 2 of 5' } );
 334
 335     foreach my $line (@array) {
 336         if ( $line->{'code'} eq $barcode ) {
 337             $line->{'active'} = 1;
 338         }
 339
 340     }
 341     return @array;
 342 }
 343
 344 sub GetUnitsValue {
 345     my ($units) = @_;
 346     my $unitvalue;
 347
 348     $unitvalue = '1'          if ( $units eq 'POINT' );
 349     $unitvalue = '2.83464567' if ( $units eq 'MM' );
 350     $unitvalue = '28.3464567' if ( $units eq 'CM' );
 351     $unitvalue = 72           if ( $units eq 'INCH' );
 352     return $unitvalue;
 353 }
 354
 355 sub GetTextWrapCols {
 356     my ( $fontsize, $label_width ) = @_;
 357     my $string           = "0";
 358     my $left_text_margin = 3;
 359     my ( $strtmp, $strwidth );
 360     my $count     = 0;
 361     my $textlimit = $label_width - $left_text_margin;
 362
 363     while ( $strwidth < $textlimit ) {
 364         $strwidth = prStrWidth( $string, 'C', $fontsize );
 365         $string = $string . '0';
 366
 367         #       warn "strwidth $strwidth, $textlimit, $string";
 368         $count++;
 369     }
 370     return $count;
 371 }
 372
 373 sub GetActiveLabelTemplate {
 374     my $dbh   = C4::Context->dbh;
 375     my $query = " SELECT * FROM labels_templates where active = 1 limit 1";
 376     my $sth   = $dbh->prepare($query);
 377     $sth->execute();
 378     my $active_tmpl = $sth->fetchrow_hashref;
 379     $sth->finish;
 380     return $active_tmpl;
 381 }
 382
 383 sub GetSingleLabelTemplate {
 384     my ($tmpl_id) = @_;
 385     my $dbh       = C4::Context->dbh;
 386     my $query     = " SELECT * FROM labels_templates where tmpl_id = ?";
 387     my $sth       = $dbh->prepare($query);
 388     $sth->execute($tmpl_id);
 389     my $template = $sth->fetchrow_hashref;
 390     $sth->finish;
 391     return $template;
 392 }
 393
 394 sub SetActiveTemplate {
 395
 396     my ($tmpl_id) = @_;
 397
 398     my $dbh   = C4::Context->dbh;
 399     my $query = " UPDATE labels_templates SET active = NULL";
 400     my $sth   = $dbh->prepare($query);
 401     $sth->execute();
 402
 403     my $query = "UPDATE labels_templates SET active = 1 WHERE tmpl_id = ?";
 404     my $sth   = $dbh->prepare($query);
 405     $sth->execute($tmpl_id);
 406     $sth->finish;
 407 }
 408
 409 sub set_active_layout {
 410
 411     my ($layout_id) = @_;
 412     my $dbh         = C4::Context->dbh;
 413     my $query       = " UPDATE labels_conf SET active = NULL";
 414     my $sth         = $dbh->prepare($query);
 415     $sth->execute();
 416
 417     my $query = "UPDATE labels_conf SET active = 1 WHERE id = ?";
 418     my $sth   = $dbh->prepare($query);
 419     $sth->execute($layout_id);
 420     $sth->finish;
 421 }
 422
 423 sub DeleteTemplate {
 424     my ($tmpl_id) = @_;
 425     my $dbh       = C4::Context->dbh;
 426     my $query     = " DELETE  FROM labels_templates where tmpl_id = ?";
 427     my $sth       = $dbh->prepare($query);
 428     $sth->execute($tmpl_id);
 429     $sth->finish;
 430 }
 431
 432 sub SaveTemplate {
 433     my (
 434         $tmpl_id,     $tmpl_code,   $tmpl_desc,    $page_width,
 435         $page_height, $label_width, $label_height, $topmargin,
 436         $leftmargin,  $cols,        $rows,         $colgap,
 437         $rowgap,      $fontsize,     $units
 438     ) = @_;
 439     my $dbh = C4::Context->dbh;
 440     my $query =
 441       " UPDATE labels_templates SET tmpl_code=?, tmpl_desc=?, page_width=?,
 442                page_height=?, label_width=?, label_height=?, topmargin=?,
 443                leftmargin=?, cols=?, rows=?, colgap=?, rowgap=?, fontsize=?,
 444                            units=?
 445                   WHERE tmpl_id = ?";
 446
 447     my $sth = $dbh->prepare($query);
 448     $sth->execute(
 449         $tmpl_code,   $tmpl_desc,    $page_width, $page_height,
 450         $label_width, $label_height, $topmargin,  $leftmargin,
 451         $cols,        $rows,         $colgap,     $rowgap,
 452         $fontsize,    $units,        $tmpl_id
 453     );
 454     $sth->finish;
 455 }
 456
 457 sub CreateTemplate {
 458     my $tmpl_id;
 459     my (
 460         $tmpl_code,   $tmpl_desc,    $page_width, $page_height,
 461         $label_width, $label_height, $topmargin,  $leftmargin,
 462         $cols,        $rows,         $colgap,     $rowgap,
 463         $fontsize,     $units
 464     ) = @_;
 465
 466     my $dbh = C4::Context->dbh;
 467
 468     my $query = "INSERT INTO labels_templates (tmpl_code, tmpl_desc, page_width,
 469                          page_height, label_width, label_height, topmargin,
 470                          leftmargin, cols, rows, colgap, rowgap, fontsize, units)
 471                          VALUES(?,?,?,?,?,?,?,?,?,?,?,?,?,?)";
 472
 473     my $sth = $dbh->prepare($query);
 474     $sth->execute(
 475         $tmpl_code,   $tmpl_desc,    $page_width, $page_height,
 476         $label_width, $label_height, $topmargin,  $leftmargin,
 477         $cols,        $rows,         $colgap,     $rowgap,
 478         $fontsize,    $units
 479     );
 480 }
 481
 482 sub GetAllLabelTemplates {
 483     my $dbh = C4::Context->dbh;
 484
 485     # get the actual items to be printed.
 486     my @data;
 487     my $query = " Select * from labels_templates ";
 488     my $sth   = $dbh->prepare($query);
 489     $sth->execute();
 490     my @resultsloop;
 491     while ( my $data = $sth->fetchrow_hashref ) {
 492         push( @resultsloop, $data );
 493     }
 494     $sth->finish;
 495
 496     #warn Dumper @resultsloop;
 497     return @resultsloop;
 498 }
 499
 500 #sub SaveConf {
 501 sub add_layout {
 502
 503     my (
 504         $barcodetype,  $title,          $subtitle,      $isbn,       $issn,
 505         $itemtype,     $bcn,            $dcn,        $classif,
 506         $subclass,     $itemcallnumber, $author,     $tmpl_id,
 507         $printingtype, $guidebox,       $startlabel, $layoutname
 508     ) = @_;
 509
 510     my $dbh    = C4::Context->dbh;
 511     my $query2 = "update labels_conf set active = NULL";
 512     my $sth2   = $dbh->prepare($query2);
 513     $sth2->execute();
 514     my $query2 = "INSERT INTO labels_conf
 515             ( barcodetype, title, subtitle, isbn,issn, itemtype, barcode,
 516               dewey, class, subclass, itemcallnumber, author, printingtype,
 517                 guidebox, startlabel, layoutname, active )
 518                values ( ?, ?, ?, ?, ?, ?, ?,  ?,?, ?, ?, ?, ?, ?,?,?, 1 )";
 519     my $sth2 = $dbh->prepare($query2);
 520     $sth2->execute(
 521         $barcodetype, $title, $subtitle, $isbn, $issn,
 522
 523         $itemtype, $bcn,            $dcn,    $classif,
 524         $subclass, $itemcallnumber, $author, $printingtype,
 525         $guidebox, $startlabel,     $layoutname
 526     );
 527     $sth2->finish;
 528
 529     SetActiveTemplate($tmpl_id);
 530     return;
 531 }
 532
 533 sub save_layout {
 534
 535     my (
 536         $barcodetype,  $title,          $subtitle,      $isbn,       $issn,
 537         $itemtype,     $bcn,            $dcn,        $classif,
 538         $subclass,     $itemcallnumber, $author,     $tmpl_id,
 539         $printingtype, $guidebox,       $startlabel, $layoutname,
 540         $layout_id
 541     ) = @_;
 542 ### $layoutname
 543 ### $layout_id
 544
 545     my $dbh    = C4::Context->dbh;
 546     my $query2 = "update labels_conf set
 547              barcodetype=?, title=?, subtitle=?, isbn=?,issn=?,
 548             itemtype=?, barcode=?,    dewey=?, class=?,
 549              subclass=?, itemcallnumber=?, author=?,  printingtype=?,
 550                guidebox=?, startlabel=?, layoutname=? where id = ?";
 551     my $sth2 = $dbh->prepare($query2);
 552     $sth2->execute(
 553         $barcodetype, $title,          $subtitle,       $isbn,       $issn,
 554         $itemtype,    $bcn,            $dcn,        $classif,
 555         $subclass,    $itemcallnumber, $author,     $printingtype,
 556         $guidebox,    $startlabel,     $layoutname, $layout_id
 557     );
 558     $sth2->finish;
 559
 560     return;
 561 }
 562
 563 =item get_label_items;
 564
 565         $options = get_label_items()
 566
 567
 568 Returns an array of references-to-hash, whos keys are the field from the biblio, biblioitems, items and labels tables in the Koha database.
 569
 570 =cut
 571
 572 #'
 573 sub get_label_items {
 574     my ($batch_id) = @_;
 575     my $dbh = C4::Context->dbh;
 576
 577     my @resultsloop = ();
 578     my $count;
 579     my @data;
 580     my $sth;
 581
 582     if ($batch_id) {
 583         my $query3 = "Select * from labels where batch_id = ? order by labelid ";
 584         $sth = $dbh->prepare($query3);
 585         $sth->execute($batch_id);
 586
 587     }
 588     else {
 589
 590         my $query3 = "Select * from labels";
 591         $sth = $dbh->prepare($query3);
 592         $sth->execute();
 593     }
 594     my $cnt = $sth->rows;
 595     my $i1  = 1;
 596     while ( my $data = $sth->fetchrow_hashref ) {
 597
 598         # lets get some summary info from each item
 599         my $query1 = "
 600          select i.*, bi.*, b.*  from items i,biblioitems bi,biblio b
 601                 where itemnumber=? and  i.biblioitemnumber=bi.biblioitemnumber and
 602                 bi.biblionumber=b.biblionumber";
 603
 604          my $sth1 = $dbh->prepare($query1);
 605         $sth1->execute( $data->{'itemnumber'} );
 606
 607         my $data1 = $sth1->fetchrow_hashref();
 608
 609         $data1->{'labelno'}  = $i1;
 610         $data1->{'batch_id'} = $batch_id;
 611         $data1->{'summary'} =
 612           "$data1->{'barcode'}, $data1->{'title'}, $data1->{'isbn'}";
 613
 614         push( @resultsloop, $data1 );
 615         $sth1->finish;
 616
 617         $i1++;
 618     }
 619     $sth->finish;
 620     return @resultsloop;
 621
 622 }
 623
 624 sub GetItemFields {
 625     my @fields = qw (
 626       barcode title subtitle
 627       dewey isbn issn author class
 628       itemtype subclass itemcallnumber
 629
 630     );
 631     return @fields;
 632 }
 633
 634 sub DrawSpineText {
 635
 636     my ( $y_pos, $label_height, $fontsize, $x_pos, $left_text_margin,
 637         $text_wrap_cols, $item, $conf_data )
 638       = @_;
 639 # hack to fix column name mismatch betwen labels_conf.class, and bibitems.classification
 640         $$item->{'class'} = $$item->{'classification'};
 641
 642     $Text::Wrap::columns   = $text_wrap_cols;
 643     $Text::Wrap::separator = "\n";
 644
 645     my $str;
 646     ##      $item
 647
 648     my $top_text_margin = ( $fontsize + 3 );
 649     my $line_spacer = ($fontsize);    # number of pixels between text rows.
 650
 651     # add your printable fields manually in here
 652
 653 my $layout_id = $$conf_data->{'id'};
 654
 655 #    my @fields = GetItemFields();
 656
 657 my $str_fields = get_text_fields($layout_id, 'codes' );
 658 my @fields = split(/ /, $str_fields);
 659 ### @fields
 660
 661     my $vPos   = ( $y_pos + ( $label_height - $top_text_margin ) );
 662     my $hPos   = ( $x_pos + $left_text_margin );
 663
 664     # warn Dumper $conf_data;
 665     #warn Dumper $item;
 666
 667     foreach my $field (@fields) {
 668
 669         # testing hack
 670 #     $$item->{"$field"} = $field . ": " . $$item->{"$field"};
 671
 672         # if the display option for this field is selected in the DB,
 673         # and the item record has some values for this field, display it.
 674         if ( $$conf_data->{"$field"} && $$item->{"$field"} ) {
 675
 676             #            warn "CONF_TYPE = $field";
 677
 678             # get the string
 679             $str = $$item->{"$field"};
 680             # strip out naughty existing nl/cr's
 681             $str =~ s/\n//g;
 682             $str =~ s/\r//g;
 683
 684             # chop the string up into _upto_ 12 chunks
 685             # and seperate the chunks with newlines
 686
 687             $str = wrap( "", "", "$str" );
 688             $str = wrap( "", "", "$str" );
 689
 690             # split the chunks between newline's, into an array
 691             my @strings = split /\n/, $str;
 692
 693             # then loop for each string line
 694             foreach my $str (@strings) {
 695
 696                 #warn "HPOS ,  VPOS $hPos, $vPos ";
 697                 # set the font size A
 698
 699                 #   prText( $hPos, $vPos, $str );
 700                 PrintText( $hPos, $vPos, $fontsize, $str );
 701                 $vPos = $vPos - $line_spacer;
 702             }
 703         }    # if field is     }    #foreach feild
 704     }
 705 }
 706
 707 sub PrintText {
 708     my ( $hPos, $vPos, $fontsize, $text ) = @_;
 709     my $str = "BT /Ft1 $fontsize Tf $hPos $vPos Td ($text) Tj ET";
 710     prAdd($str);
 711 }
 712
 713 sub SetFontSize {
 714
 715     my ($fontsize) = @_;
 716 ### fontsize
 717     my $str = "BT/F13 30 Tf288 720 Td( AAAAAAAAAA ) TjET";
 718     prAdd($str);
 719 }
 720
 721 sub DrawBarcode {
 722
 723     # x and y are from the top-left :)
 724     my ( $x_pos, $y_pos, $height, $width, $barcode, $barcodetype ) = @_;
 725     my $num_of_bars = length($barcode);
 726     my $bar_width   = $width * .8;        # %80 of length of label width
 727     my $tot_bar_length;
 728     my $bar_length;
 729     my $guard_length = 10;
 730     my $xsize_ratio;
 731
 732     if ( $barcodetype eq 'CODE39' ) {
 733         $bar_length = '17.5';
 734         $tot_bar_length =
 735           ( $bar_length * $num_of_bars ) + ( $guard_length * 2 );
 736         $xsize_ratio = ( $bar_width / $tot_bar_length );
 737         eval {
 738             PDF::Reuse::Barcode::Code39(
 739                 x => ( $x_pos + ( $width / 10 ) ),
 740                 y => ( $y_pos + ( $height / 10 ) ),
 741                 value         => "*$barcode*",
 742                 ySize         => ( .02 * $height ),
 743                 xSize         => $xsize_ratio,
 744                 hide_asterisk => 1,
 745             );
 746         };
 747         if ($@) {
 748             warn "$barcodetype, $barcode FAILED:$@";
 749         }
 750     }
 751
 752     elsif ( $barcodetype eq 'CODE39MOD' ) {
 753
 754         # get modulo43 checksum
 755         my $c39 = CheckDigits('code_39');
 756         $barcode = $c39->complete($barcode);
 757
 758         $bar_length = '19';
 759         $tot_bar_length =
 760           ( $bar_length * $num_of_bars ) + ( $guard_length * 2 );
 761         $xsize_ratio = ( $bar_width / $tot_bar_length );
 762         eval {
 763             PDF::Reuse::Barcode::Code39(
 764                 x => ( $x_pos + ( $width / 10 ) ),
 765                 y => ( $y_pos + ( $height / 10 ) ),
 766                 value         => "*$barcode*",
 767                 ySize         => ( .02 * $height ),
 768                 xSize         => $xsize_ratio,
 769                 hide_asterisk => 1,
 770             );
 771         };
 772
 773         if ($@) {
 774             warn "$barcodetype, $barcode FAILED:$@";
 775         }
 776     }
 777     elsif ( $barcodetype eq 'CODE39MOD10' ) {
 778
 779         # get modulo43 checksum
 780         my $c39_10 = CheckDigits('visa');
 781         $barcode = $c39_10->complete($barcode);
 782
 783         $bar_length = '19';
 784         $tot_bar_length =
 785           ( $bar_length * $num_of_bars ) + ( $guard_length * 2 );
 786         $xsize_ratio = ( $bar_width / $tot_bar_length );
 787         eval {
 788             PDF::Reuse::Barcode::Code39(
 789                 x => ( $x_pos + ( $width / 10 ) ),
 790                 y => ( $y_pos + ( $height / 10 ) ),
 791                 value         => "*$barcode*",
 792                 ySize         => ( .02 * $height ),
 793                 xSize         => $xsize_ratio,
 794                 hide_asterisk => 1,
 795                                 text         => 0,
 796             );
 797         };
 798
 799         if ($@) {
 800             warn "$barcodetype, $barcode FAILED:$@";
 801         }
 802     }
 803
 804
 805     elsif ( $barcodetype eq 'COOP2OF5' ) {
 806         $bar_length = '9.43333333333333';
 807         $tot_bar_length =
 808           ( $bar_length * $num_of_bars ) + ( $guard_length * 2 );
 809         $xsize_ratio = ( $bar_width / $tot_bar_length ) * .9;
 810         eval {
 811             PDF::Reuse::Barcode::COOP2of5(
 812                 x => ( $x_pos + ( $width / 10 ) ),
 813                 y => ( $y_pos + ( $height / 10 ) ),
 814                 value => $barcode,
 815                 ySize => ( .02 * $height ),
 816                 xSize => $xsize_ratio,
 817             );
 818         };
 819         if ($@) {
 820             warn "$barcodetype, $barcode FAILED:$@";
 821         }
 822     }
 823
 824     elsif ( $barcodetype eq 'INDUSTRIAL2OF5' ) {
 825         $bar_length = '13.1333333333333';
 826         $tot_bar_length =
 827           ( $bar_length * $num_of_bars ) + ( $guard_length * 2 );
 828         $xsize_ratio = ( $bar_width / $tot_bar_length ) * .9;
 829         eval {
 830             PDF::Reuse::Barcode::Industrial2of5(
 831                 x => ( $x_pos + ( $width / 10 ) ),
 832                 y => ( $y_pos + ( $height / 10 ) ),
 833                 value => $barcode,
 834                 ySize => ( .02 * $height ),
 835                 xSize => $xsize_ratio,
 836             );
 837         };
 838         if ($@) {
 839             warn "$barcodetype, $barcode FAILED:$@";
 840         }
 841     }
 842
 843     my $moo2 = $tot_bar_length * $xsize_ratio;
 844
 845     warn " $x_pos, $y_pos, $barcode, $barcodetype\n";
 846     warn
 847 "BAR_WDTH = $bar_width, TOT.BAR.LGHT=$tot_bar_length  R*TOT.BAR =$moo2 \n";
 848 }
 849
 850 =item build_circ_barcode;
 851
 852   build_circ_barcode( $x_pos, $y_pos, $barcode,
 853                 $barcodetype, \$item);
 854
 855 $item is the result of a previous call to get_label_items();
 856
 857 =cut
 858
 859 #'
 860 sub build_circ_barcode {
 861     my ( $x_pos_circ, $y_pos, $value, $barcodetype, $item ) = @_;
 862
 863     #warn Dumper \$item;
 864
 865     #warn "value = $value\n";
 866
 867     #$DB::single = 1;
 868
 869     if ( $barcodetype eq 'EAN13' ) {
 870
 871         #testing EAN13 barcodes hack
 872         $value = $value . '000000000';
 873         $value =~ s/-//;
 874         $value = substr( $value, 0, 12 );
 875
 876         #warn $value;
 877         eval {
 878             PDF::Reuse::Barcode::EAN13(
 879                 x     => ( $x_pos_circ + 27 ),
 880                 y     => ( $y_pos + 15 ),
 881                 value => $value,
 882
 883                 #            prolong => 2.96,
 884                 #            xSize   => 1.5,
 885
 886                 # ySize   => 1.2,
 887
 888 # added for xpdf compat. doesnt use type3 fonts., but increases filesize from 20k to 200k
 889 # i think its embedding extra fonts in the pdf file.
 890 #  mode => 'graphic',
 891             );
 892         };
 893         if ($@) {
 894             $item->{'barcodeerror'} = 1;
 895
 896             #warn "EAN13BARCODE FAILED:$@";
 897         }
 898
 899         #warn $barcodetype;
 900
 901     }
 902     elsif ( $barcodetype eq 'Code39' ) {
 903
 904         eval {
 905             PDF::Reuse::Barcode::Code39(
 906                 x     => ( $x_pos_circ + 9 ),
 907                 y     => ( $y_pos + 15 ),
 908                 value => $value,
 909
 910                 #           prolong => 2.96,
 911                 xSize => .85,
 912
 913                 ySize => 1.3,
 914             );
 915         };
 916         if ($@) {
 917             $item->{'barcodeerror'} = 1;
 918
 919             #warn "CODE39BARCODE $value FAILED:$@";
 920         }
 921
 922         #warn $barcodetype;
 923
 924     }
 925
 926     elsif ( $barcodetype eq 'Matrix2of5' ) {
 927
 928         #warn "MATRIX ELSE:";
 929
 930         #testing MATRIX25  barcodes hack
 931         #    $value = $value.'000000000';
 932         $value =~ s/-//;
 933
 934         #    $value = substr( $value, 0, 12 );
 935         #warn $value;
 936
 937         eval {
 938             PDF::Reuse::Barcode::Matrix2of5(
 939                 x     => ( $x_pos_circ + 27 ),
 940                 y     => ( $y_pos + 15 ),
 941                 value => $value,
 942
 943                 #        prolong => 2.96,
 944                 #       xSize   => 1.5,
 945
 946                 # ySize   => 1.2,
 947             );
 948         };
 949         if ($@) {
 950             $item->{'barcodeerror'} = 1;
 951
 952             #warn "BARCODE FAILED:$@";
 953         }
 954
 955         #warn $barcodetype;
 956
 957     }
 958
 959     elsif ( $barcodetype eq 'EAN8' ) {
 960
 961         #testing ean8 barcodes hack
 962         $value = $value . '000000000';
 963         $value =~ s/-//;
 964         $value = substr( $value, 0, 8 );
 965
 966         #warn $value;
 967
 968         #warn "EAN8 ELSEIF";
 969         eval {
 970             PDF::Reuse::Barcode::EAN8(
 971                 x       => ( $x_pos_circ + 42 ),
 972                 y       => ( $y_pos + 15 ),
 973                 value   => $value,
 974                 prolong => 2.96,
 975                 xSize   => 1.5,
 976
 977                 # ySize   => 1.2,
 978             );
 979         };
 980
 981         if ($@) {
 982             $item->{'barcodeerror'} = 1;
 983
 984             #warn "BARCODE FAILED:$@";
 985         }
 986
 987         #warn $barcodetype;
 988
 989     }
 990
 991     elsif ( $barcodetype eq 'UPC-E' ) {
 992         eval {
 993             PDF::Reuse::Barcode::UPCE(
 994                 x       => ( $x_pos_circ + 27 ),
 995                 y       => ( $y_pos + 15 ),
 996                 value   => $value,
 997                 prolong => 2.96,
 998                 xSize   => 1.5,
 999
1000                 # ySize   => 1.2,
1001             );
1002         };
1003
1004         if ($@) {
1005             $item->{'barcodeerror'} = 1;
1006
1007             #warn "BARCODE FAILED:$@";
1008         }
1009
1010         #warn $barcodetype;
1011
1012     }
1013     elsif ( $barcodetype eq 'NW7' ) {
1014         eval {
1015             PDF::Reuse::Barcode::NW7(
1016                 x       => ( $x_pos_circ + 27 ),
1017                 y       => ( $y_pos + 15 ),
1018                 value   => $value,
1019                 prolong => 2.96,
1020                 xSize   => 1.5,
1021
1022                 # ySize   => 1.2,
1023             );
1024         };
1025
1026         if ($@) {
1027             $item->{'barcodeerror'} = 1;
1028
1029             #warn "BARCODE FAILED:$@";
1030         }
1031
1032         #warn $barcodetype;
1033
1034     }
1035     elsif ( $barcodetype eq 'ITF' ) {
1036         eval {
1037             PDF::Reuse::Barcode::ITF(
1038                 x       => ( $x_pos_circ + 27 ),
1039                 y       => ( $y_pos + 15 ),
1040                 value   => $value,
1041                 prolong => 2.96,
1042                 xSize   => 1.5,
1043
1044                 # ySize   => 1.2,
1045             );
1046         };
1047
1048         if ($@) {
1049             $item->{'barcodeerror'} = 1;
1050
1051             #warn "BARCODE FAILED:$@";
1052         }
1053
1054         #warn $barcodetype;
1055
1056     }
1057     elsif ( $barcodetype eq 'Industrial2of5' ) {
1058         eval {
1059             PDF::Reuse::Barcode::Industrial2of5(
1060                 x       => ( $x_pos_circ + 27 ),
1061                 y       => ( $y_pos + 15 ),
1062                 value   => $value,
1063                 prolong => 2.96,
1064                 xSize   => 1.5,
1065
1066                 # ySize   => 1.2,
1067             );
1068         };
1069         if ($@) {
1070             $item->{'barcodeerror'} = 1;
1071
1072             #warn "BARCODE FAILED:$@";
1073         }
1074
1075         #warn $barcodetype;
1076
1077     }
1078     elsif ( $barcodetype eq 'IATA2of5' ) {
1079         eval {
1080             PDF::Reuse::Barcode::IATA2of5(
1081                 x       => ( $x_pos_circ + 27 ),
1082                 y       => ( $y_pos + 15 ),
1083                 value   => $value,
1084                 prolong => 2.96,
1085                 xSize   => 1.5,
1086
1087                 # ySize   => 1.2,
1088             );
1089         };
1090         if ($@) {
1091             $item->{'barcodeerror'} = 1;
1092
1093             #warn "BARCODE FAILED:$@";
1094         }
1095
1096         #warn $barcodetype;
1097
1098     }
1099
1100     elsif ( $barcodetype eq 'COOP2of5' ) {
1101         eval {
1102             PDF::Reuse::Barcode::COOP2of5(
1103                 x       => ( $x_pos_circ + 27 ),
1104                 y       => ( $y_pos + 15 ),
1105                 value   => $value,
1106                 prolong => 2.96,
1107                 xSize   => 1.5,
1108
1109                 # ySize   => 1.2,
1110             );
1111         };
1112         if ($@) {
1113             $item->{'barcodeerror'} = 1;
1114
1115             #warn "BARCODE FAILED:$@";
1116         }
1117
1118         #warn $barcodetype;
1119
1120     }
1121     elsif ( $barcodetype eq 'UPC-A' ) {
1122
1123         eval {
1124             PDF::Reuse::Barcode::UPCA(
1125                 x       => ( $x_pos_circ + 27 ),
1126                 y       => ( $y_pos + 15 ),
1127                 value   => $value,
1128                 prolong => 2.96,
1129                 xSize   => 1.5,
1130
1131                 # ySize   => 1.2,
1132             );
1133         };
1134         if ($@) {
1135             $item->{'barcodeerror'} = 1;
1136
1137             #warn "BARCODE FAILED:$@";
1138         }
1139
1140         #warn $barcodetype;
1141
1142     }
1143
1144 }
1145
1146 =item draw_boundaries
1147
1148  sub draw_boundaries ($x_pos_spine, $x_pos_circ1, $x_pos_circ2,
1149                 $y_pos, $spine_width, $label_height, $circ_width)
1150
1151 This sub draws boundary lines where the label outlines are, to aid in printer testing, and debugging.
1152
1153 =cut
1154
1155 #'
1156 sub draw_boundaries {
1157
1158     my (
1159         $x_pos_spine, $x_pos_circ1,  $x_pos_circ2, $y_pos,
1160         $spine_width, $label_height, $circ_width
1161     ) = @_;
1162
1163     my $y_pos_initial = ( ( 792 - 36 ) - 90 );
1164     my $y_pos         = $y_pos_initial;
1165     my $i             = 1;
1166
1167     for ( $i = 1 ; $i <= 8 ; $i++ ) {
1168
1169         &drawbox( $x_pos_spine, $y_pos, ($spine_width), ($label_height) );
1170
1171    #warn "OLD BOXES  x=$x_pos_spine, y=$y_pos, w=$spine_width, h=$label_height";
1172         &drawbox( $x_pos_circ1, $y_pos, ($circ_width), ($label_height) );
1173         &drawbox( $x_pos_circ2, $y_pos, ($circ_width), ($label_height) );
1174
1175         $y_pos = ( $y_pos - $label_height );
1176
1177     }
1178 }
1179
1180 =item drawbox
1181
1182         sub drawbox {   $lower_left_x, $lower_left_y,
1183                         $upper_right_x, $upper_right_y )
1184
1185 this is a low level sub, that draws a pdf box, it is called by draw_boxes
1186
1187 FYI: the  $upper_right_x and $upper_right_y values are RELATIVE to  $lower_left_x and $lower_left_y
1188
1189 and $lower_left_x, $lower_left_y are ABSOLUTE, this caught me out!
1190
1191 =cut
1192
1193 #'
1194 sub drawbox {
1195     my ( $llx, $lly, $urx, $ury ) = @_;
1196
1197     #    warn "llx,y= $llx,$lly  ,   urx,y=$urx,$ury \n";
1198
1199     my $str = "q\n";    # save the graphic state
1200     $str .= "0.5 w\n";              # border color red
1201     $str .= "1.0 0.0 0.0  RG\n";    # border color red
1202          #   $str .= "0.5 0.75 1.0 rg\n";           # fill color blue
1203     $str .= "1.0 1.0 1.0  rg\n";    # fill color white
1204
1205     $str .= "$llx $lly $urx $ury re\n";    # a rectangle
1206     $str .= "B\n";                         # fill (and a little more)
1207     $str .= "Q\n";                         # save the graphic state
1208
1209     prAdd($str);
1210
1211 }
1212
1213 END { }    # module clean-up code here (global destructor)
1214
1215 1;
1216 __END__
1217
1218 =back
1219
1220 =head1 AUTHOR
1221
1222 Mason James <mason@katipo.co.nz>
1223 =cut
1224