help.pl - bugfix module usage (HTML::Template::Pro)
[koha.git] / 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.02;
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   &deduplicate_batch
66 );
67
68 =item get_label_options;
69
70         $options = get_label_options()
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     $query = "UPDATE labels_templates SET active = 1 WHERE tmpl_id = ?";
404     $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     $query = "UPDATE labels_conf SET active = 1 WHERE id = ?";
418     $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     $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     $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 Returns an array of references-to-hash, whos keys are the field from the biblio, biblioitems, items and labels tables in the Koha database.
568
569 =cut
570
571 #'
572 sub get_label_items {
573     my ($batch_id) = @_;
574     my $dbh = C4::Context->dbh;
575
576     my @resultsloop = ();
577     my $count;
578     my @data;
579     my $sth;
580
581     if ($batch_id) {
582         my $query3 = "Select * from labels where batch_id = ? order by labelid ";
583         $sth = $dbh->prepare($query3);
584         $sth->execute($batch_id);
585
586     }
587     else {
588
589         my $query3 = "Select * from labels";
590         $sth = $dbh->prepare($query3);
591         $sth->execute();
592     }
593     my $cnt = $sth->rows;
594     my $i1  = 1;
595     while ( my $data = $sth->fetchrow_hashref ) {
596
597         # lets get some summary info from each item
598         my $query1 = " 
599          select i.*, bi.*, b.*  from items i,biblioitems bi,biblio b 
600                 where itemnumber=? and  i.biblioitemnumber=bi.biblioitemnumber and                  
601                 bi.biblionumber=b.biblionumber"; 
602      
603                 my $sth1 = $dbh->prepare($query1);
604         $sth1->execute( $data->{'itemnumber'} );
605
606         my $data1 = $sth1->fetchrow_hashref();
607         $data1->{'labelno'}  = $i1;
608         $data1->{'labelid'}  = $data->{'labelid'};
609         $data1->{'batch_id'} = $batch_id;
610         $data1->{'summary'} =
611           "$data1->{'barcode'}, $data1->{'title'}, $data1->{'isbn'}";
612
613         push( @resultsloop, $data1 );
614         $sth1->finish;
615
616         $i1++;
617     }
618     $sth->finish;
619     return @resultsloop;
620
621 }
622
623 sub GetItemFields {
624     my @fields = qw (
625       barcode title subtitle
626       dewey isbn issn author class
627       itemtype subclass itemcallnumber
628
629     );
630     return @fields;
631 }
632
633 sub deduplicate_batch {
634         my $batch_id = shift or return undef;
635         my $query = "
636         SELECT DISTINCT
637                         batch_id,itemnumber,
638                         count(labelid) as count 
639         FROM     labels 
640         WHERE    batch_id = ?
641         GROUP BY itemnumber,batch_id
642         HAVING   count > 1
643         ORDER BY batch_id,
644                          count DESC  ";
645         my $sth = C4::Context->dbh->prepare($query);
646         $sth->execute($batch_id);
647         $sth->rows or return undef;
648
649         my $del_query = qq(
650         DELETE 
651         FROM     labels 
652         WHERE    batch_id = ?
653         AND      itemnumber = ?
654         ORDER BY timestamp ASC
655         );
656         my $killed = 0;
657         while (my $data = $sth->fetchrow_hashref()) {
658                 my $itemnumber = $data->{itemnumber} or next;
659                 my $limit      = $data->{count} - 1  or next;
660                 my $sth2 = C4::Context->dbh->prepare("$del_query  LIMIT $limit");
661                 # die sprintf "$del_query LIMIT %s\n (%s, %s)", $limit, $batch_id, $itemnumber;
662                 # $sth2->execute($batch_id, C4::Context->dbh->quote($data->{itemnumber}), $data->{count} - 1)
663                 $sth2->execute($batch_id, $itemnumber) and
664                         $killed += ($data->{count} - 1);
665         }
666         return $killed;
667 }
668
669 sub DrawSpineText {
670
671     my ( $y_pos, $label_height, $fontsize, $x_pos, $left_text_margin,
672         $text_wrap_cols, $item, $conf_data )
673       = @_;
674 # hack to fix column name mismatch betwen labels_conf.class, and bibitems.classification
675         $$item->{'class'} = $$item->{'classification'};
676  
677     $Text::Wrap::columns   = $text_wrap_cols;
678     $Text::Wrap::separator = "\n";
679
680     my $str;
681     ##      $item
682
683     my $top_text_margin = ( $fontsize + 3 );
684     my $line_spacer = ($fontsize);    # number of pixels between text rows.
685
686     # add your printable fields manually in here
687
688 my $layout_id = $$conf_data->{'id'};
689
690 #    my @fields = GetItemFields();
691
692 my $str_fields = get_text_fields($layout_id, 'codes' );
693 my @fields = split(/ /, $str_fields);
694 ### @fields
695
696     my $vPos   = ( $y_pos + ( $label_height - $top_text_margin ) );
697     my $hPos   = ( $x_pos + $left_text_margin );
698
699     # warn Dumper $conf_data;
700     #warn Dumper $item;
701
702     foreach my $field (@fields) {
703
704         # testing hack
705 #     $$item->{"$field"} = $field . ": " . $$item->{"$field"};
706
707         # if the display option for this field is selected in the DB,
708         # and the item record has some values for this field, display it.
709         if ( $$conf_data->{"$field"} && $$item->{"$field"} ) {
710
711             #            warn "CONF_TYPE = $field";
712
713             # get the string
714             $str = $$item->{"$field"};
715             # strip out naughty existing nl/cr's
716             $str =~ s/\n//g;
717             $str =~ s/\r//g;
718
719             # chop the string up into _upto_ 12 chunks
720             # and seperate the chunks with newlines
721
722             $str = wrap( "", "", "$str" );
723             $str = wrap( "", "", "$str" );
724
725             # split the chunks between newline's, into an array
726             my @strings = split /\n/, $str;
727
728             # then loop for each string line
729             foreach my $str (@strings) {
730
731                 #warn "HPOS ,  VPOS $hPos, $vPos ";
732                 # set the font size A
733
734                 #   prText( $hPos, $vPos, $str );
735                 PrintText( $hPos, $vPos, $fontsize, $str );
736                 $vPos = $vPos - $line_spacer;
737             }
738         }    # if field is     }    #foreach feild
739     }
740 }
741
742 sub PrintText {
743     my ( $hPos, $vPos, $fontsize, $text ) = @_;
744     my $str = "BT /Ft1 $fontsize Tf $hPos $vPos Td ($text) Tj ET";
745     prAdd($str);
746 }
747
748 sub SetFontSize {
749
750     my ($fontsize) = @_;
751 ### fontsize
752     my $str = "BT/F13 30 Tf288 720 Td( AAAAAAAAAA ) TjET";
753     prAdd($str);
754 }
755
756 sub DrawBarcode {
757
758     # x and y are from the top-left :)
759     my ( $x_pos, $y_pos, $height, $width, $barcode, $barcodetype ) = @_;
760     my $num_of_bars = length($barcode);
761     my $bar_width   = $width * .8;        # %80 of length of label width
762     my $tot_bar_length;
763     my $bar_length;
764     my $guard_length = 10;
765     my $xsize_ratio;
766
767     if ( $barcodetype eq 'CODE39' ) {
768         $bar_length = '17.5';
769         $tot_bar_length =
770           ( $bar_length * $num_of_bars ) + ( $guard_length * 2 );
771         $xsize_ratio = ( $bar_width / $tot_bar_length );
772         eval {
773             PDF::Reuse::Barcode::Code39(
774                 x => ( $x_pos + ( $width / 10 ) ),
775                 y => ( $y_pos + ( $height / 10 ) ),
776                 value         => "*$barcode*",
777                 ySize         => ( .02 * $height ),
778                 xSize         => $xsize_ratio,
779                 hide_asterisk => 1,
780             );
781         };
782         if ($@) {
783             warn "$barcodetype, $barcode FAILED:$@";
784         }
785     }
786
787     elsif ( $barcodetype eq 'CODE39MOD' ) {
788
789         # get modulo43 checksum
790         my $c39 = CheckDigits('code_39');
791         $barcode = $c39->complete($barcode);
792
793         $bar_length = '19';
794         $tot_bar_length =
795           ( $bar_length * $num_of_bars ) + ( $guard_length * 2 );
796         $xsize_ratio = ( $bar_width / $tot_bar_length );
797         eval {
798             PDF::Reuse::Barcode::Code39(
799                 x => ( $x_pos + ( $width / 10 ) ),
800                 y => ( $y_pos + ( $height / 10 ) ),
801                 value         => "*$barcode*",
802                 ySize         => ( .02 * $height ),
803                 xSize         => $xsize_ratio,
804                 hide_asterisk => 1,
805             );
806         };
807
808         if ($@) {
809             warn "$barcodetype, $barcode FAILED:$@";
810         }
811     }
812     elsif ( $barcodetype eq 'CODE39MOD10' ) {
813  
814         # get modulo43 checksum
815         my $c39_10 = CheckDigits('visa');
816         $barcode = $c39_10->complete($barcode);
817
818         $bar_length = '19';
819         $tot_bar_length =
820           ( $bar_length * $num_of_bars ) + ( $guard_length * 2 );
821         $xsize_ratio = ( $bar_width / $tot_bar_length );
822         eval {
823             PDF::Reuse::Barcode::Code39(
824                 x => ( $x_pos + ( $width / 10 ) ),
825                 y => ( $y_pos + ( $height / 10 ) ),
826                 value         => "*$barcode*",
827                 ySize         => ( .02 * $height ),
828                 xSize         => $xsize_ratio,
829                 hide_asterisk => 1,
830                                 text         => 0, 
831             );
832         };
833
834         if ($@) {
835             warn "$barcodetype, $barcode FAILED:$@";
836         }
837     }
838
839  
840     elsif ( $barcodetype eq 'COOP2OF5' ) {
841         $bar_length = '9.43333333333333';
842         $tot_bar_length =
843           ( $bar_length * $num_of_bars ) + ( $guard_length * 2 );
844         $xsize_ratio = ( $bar_width / $tot_bar_length ) * .9;
845         eval {
846             PDF::Reuse::Barcode::COOP2of5(
847                 x => ( $x_pos + ( $width / 10 ) ),
848                 y => ( $y_pos + ( $height / 10 ) ),
849                 value => $barcode,
850                 ySize => ( .02 * $height ),
851                 xSize => $xsize_ratio,
852             );
853         };
854         if ($@) {
855             warn "$barcodetype, $barcode FAILED:$@";
856         }
857     }
858
859     elsif ( $barcodetype eq 'INDUSTRIAL2OF5' ) {
860         $bar_length = '13.1333333333333';
861         $tot_bar_length =
862           ( $bar_length * $num_of_bars ) + ( $guard_length * 2 );
863         $xsize_ratio = ( $bar_width / $tot_bar_length ) * .9;
864         eval {
865             PDF::Reuse::Barcode::Industrial2of5(
866                 x => ( $x_pos + ( $width / 10 ) ),
867                 y => ( $y_pos + ( $height / 10 ) ),
868                 value => $barcode,
869                 ySize => ( .02 * $height ),
870                 xSize => $xsize_ratio,
871             );
872         };
873         if ($@) {
874             warn "$barcodetype, $barcode FAILED:$@";
875         }
876     }
877
878     my $moo2 = $tot_bar_length * $xsize_ratio;
879
880     warn " $x_pos, $y_pos, $barcode, $barcodetype\n";
881     warn
882 "BAR_WDTH = $bar_width, TOT.BAR.LGHT=$tot_bar_length  R*TOT.BAR =$moo2 \n";
883 }
884
885 =item build_circ_barcode;
886
887   build_circ_barcode( $x_pos, $y_pos, $barcode,
888                 $barcodetype, \$item);
889
890 $item is the result of a previous call to get_label_items();
891
892 =cut
893
894 #'
895 sub build_circ_barcode {
896     my ( $x_pos_circ, $y_pos, $value, $barcodetype, $item ) = @_;
897
898     #warn Dumper \$item;
899
900     #warn "value = $value\n";
901
902     #$DB::single = 1;
903
904     if ( $barcodetype eq 'EAN13' ) {
905
906         #testing EAN13 barcodes hack
907         $value = $value . '000000000';
908         $value =~ s/-//;
909         $value = substr( $value, 0, 12 );
910
911         #warn $value;
912         eval {
913             PDF::Reuse::Barcode::EAN13(
914                 x     => ( $x_pos_circ + 27 ),
915                 y     => ( $y_pos + 15 ),
916                 value => $value,
917
918                 #            prolong => 2.96,
919                 #            xSize   => 1.5,
920
921                 # ySize   => 1.2,
922
923 # added for xpdf compat. doesnt use type3 fonts., but increases filesize from 20k to 200k
924 # i think its embedding extra fonts in the pdf file.
925 #  mode => 'graphic',
926             );
927         };
928         if ($@) {
929             $item->{'barcodeerror'} = 1;
930
931             #warn "EAN13BARCODE FAILED:$@";
932         }
933
934         #warn $barcodetype;
935
936     }
937     elsif ( $barcodetype eq 'Code39' ) {
938
939         eval {
940             PDF::Reuse::Barcode::Code39(
941                 x     => ( $x_pos_circ + 9 ),
942                 y     => ( $y_pos + 15 ),
943                 value => $value,
944
945                 #           prolong => 2.96,
946                 xSize => .85,
947
948                 ySize => 1.3,
949             );
950         };
951         if ($@) {
952             $item->{'barcodeerror'} = 1;
953
954             #warn "CODE39BARCODE $value FAILED:$@";
955         }
956
957         #warn $barcodetype;
958
959     }
960
961     elsif ( $barcodetype eq 'Matrix2of5' ) {
962
963         #warn "MATRIX ELSE:";
964
965         #testing MATRIX25  barcodes hack
966         #    $value = $value.'000000000';
967         $value =~ s/-//;
968
969         #    $value = substr( $value, 0, 12 );
970         #warn $value;
971
972         eval {
973             PDF::Reuse::Barcode::Matrix2of5(
974                 x     => ( $x_pos_circ + 27 ),
975                 y     => ( $y_pos + 15 ),
976                 value => $value,
977
978                 #        prolong => 2.96,
979                 #       xSize   => 1.5,
980
981                 # ySize   => 1.2,
982             );
983         };
984         if ($@) {
985             $item->{'barcodeerror'} = 1;
986
987             #warn "BARCODE FAILED:$@";
988         }
989
990         #warn $barcodetype;
991
992     }
993
994     elsif ( $barcodetype eq 'EAN8' ) {
995
996         #testing ean8 barcodes hack
997         $value = $value . '000000000';
998         $value =~ s/-//;
999         $value = substr( $value, 0, 8 );
1000
1001         #warn $value;
1002
1003         #warn "EAN8 ELSEIF";
1004         eval {
1005             PDF::Reuse::Barcode::EAN8(
1006                 x       => ( $x_pos_circ + 42 ),
1007                 y       => ( $y_pos + 15 ),
1008                 value   => $value,
1009                 prolong => 2.96,
1010                 xSize   => 1.5,
1011
1012                 # ySize   => 1.2,
1013             );
1014         };
1015
1016         if ($@) {
1017             $item->{'barcodeerror'} = 1;
1018
1019             #warn "BARCODE FAILED:$@";
1020         }
1021
1022         #warn $barcodetype;
1023
1024     }
1025
1026     elsif ( $barcodetype eq 'UPC-E' ) {
1027         eval {
1028             PDF::Reuse::Barcode::UPCE(
1029                 x       => ( $x_pos_circ + 27 ),
1030                 y       => ( $y_pos + 15 ),
1031                 value   => $value,
1032                 prolong => 2.96,
1033                 xSize   => 1.5,
1034
1035                 # ySize   => 1.2,
1036             );
1037         };
1038
1039         if ($@) {
1040             $item->{'barcodeerror'} = 1;
1041
1042             #warn "BARCODE FAILED:$@";
1043         }
1044
1045         #warn $barcodetype;
1046
1047     }
1048     elsif ( $barcodetype eq 'NW7' ) {
1049         eval {
1050             PDF::Reuse::Barcode::NW7(
1051                 x       => ( $x_pos_circ + 27 ),
1052                 y       => ( $y_pos + 15 ),
1053                 value   => $value,
1054                 prolong => 2.96,
1055                 xSize   => 1.5,
1056
1057                 # ySize   => 1.2,
1058             );
1059         };
1060
1061         if ($@) {
1062             $item->{'barcodeerror'} = 1;
1063
1064             #warn "BARCODE FAILED:$@";
1065         }
1066
1067         #warn $barcodetype;
1068
1069     }
1070     elsif ( $barcodetype eq 'ITF' ) {
1071         eval {
1072             PDF::Reuse::Barcode::ITF(
1073                 x       => ( $x_pos_circ + 27 ),
1074                 y       => ( $y_pos + 15 ),
1075                 value   => $value,
1076                 prolong => 2.96,
1077                 xSize   => 1.5,
1078
1079                 # ySize   => 1.2,
1080             );
1081         };
1082
1083         if ($@) {
1084             $item->{'barcodeerror'} = 1;
1085
1086             #warn "BARCODE FAILED:$@";
1087         }
1088
1089         #warn $barcodetype;
1090
1091     }
1092     elsif ( $barcodetype eq 'Industrial2of5' ) {
1093         eval {
1094             PDF::Reuse::Barcode::Industrial2of5(
1095                 x       => ( $x_pos_circ + 27 ),
1096                 y       => ( $y_pos + 15 ),
1097                 value   => $value,
1098                 prolong => 2.96,
1099                 xSize   => 1.5,
1100
1101                 # ySize   => 1.2,
1102             );
1103         };
1104         if ($@) {
1105             $item->{'barcodeerror'} = 1;
1106
1107             #warn "BARCODE FAILED:$@";
1108         }
1109
1110         #warn $barcodetype;
1111
1112     }
1113     elsif ( $barcodetype eq 'IATA2of5' ) {
1114         eval {
1115             PDF::Reuse::Barcode::IATA2of5(
1116                 x       => ( $x_pos_circ + 27 ),
1117                 y       => ( $y_pos + 15 ),
1118                 value   => $value,
1119                 prolong => 2.96,
1120                 xSize   => 1.5,
1121
1122                 # ySize   => 1.2,
1123             );
1124         };
1125         if ($@) {
1126             $item->{'barcodeerror'} = 1;
1127
1128             #warn "BARCODE FAILED:$@";
1129         }
1130
1131         #warn $barcodetype;
1132
1133     }
1134
1135     elsif ( $barcodetype eq 'COOP2of5' ) {
1136         eval {
1137             PDF::Reuse::Barcode::COOP2of5(
1138                 x       => ( $x_pos_circ + 27 ),
1139                 y       => ( $y_pos + 15 ),
1140                 value   => $value,
1141                 prolong => 2.96,
1142                 xSize   => 1.5,
1143
1144                 # ySize   => 1.2,
1145             );
1146         };
1147         if ($@) {
1148             $item->{'barcodeerror'} = 1;
1149
1150             #warn "BARCODE FAILED:$@";
1151         }
1152
1153         #warn $barcodetype;
1154
1155     }
1156     elsif ( $barcodetype eq 'UPC-A' ) {
1157
1158         eval {
1159             PDF::Reuse::Barcode::UPCA(
1160                 x       => ( $x_pos_circ + 27 ),
1161                 y       => ( $y_pos + 15 ),
1162                 value   => $value,
1163                 prolong => 2.96,
1164                 xSize   => 1.5,
1165
1166                 # ySize   => 1.2,
1167             );
1168         };
1169         if ($@) {
1170             $item->{'barcodeerror'} = 1;
1171
1172             #warn "BARCODE FAILED:$@";
1173         }
1174
1175         #warn $barcodetype;
1176
1177     }
1178
1179 }
1180
1181 =item draw_boundaries
1182
1183  sub draw_boundaries ($x_pos_spine, $x_pos_circ1, $x_pos_circ2,
1184                 $y_pos, $spine_width, $label_height, $circ_width)  
1185
1186 This sub draws boundary lines where the label outlines are, to aid in printer testing, and debugging.
1187
1188 =cut
1189
1190 #'
1191 sub draw_boundaries {
1192
1193     my (
1194         $x_pos_spine, $x_pos_circ1,  $x_pos_circ2, $y_pos,
1195         $spine_width, $label_height, $circ_width
1196     ) = @_;
1197
1198     my $y_pos_initial = ( ( 792 - 36 ) - 90 );
1199     $y_pos            = $y_pos_initial; # FIXME - why are we ignoring the y_pos parameter by redefining it?
1200     my $i             = 1;
1201
1202     for ( $i = 1 ; $i <= 8 ; $i++ ) {
1203
1204         &drawbox( $x_pos_spine, $y_pos, ($spine_width), ($label_height) );
1205
1206    #warn "OLD BOXES  x=$x_pos_spine, y=$y_pos, w=$spine_width, h=$label_height";
1207         &drawbox( $x_pos_circ1, $y_pos, ($circ_width), ($label_height) );
1208         &drawbox( $x_pos_circ2, $y_pos, ($circ_width), ($label_height) );
1209
1210         $y_pos = ( $y_pos - $label_height );
1211
1212     }
1213 }
1214
1215 =item drawbox
1216
1217         sub drawbox {   $lower_left_x, $lower_left_y, 
1218                         $upper_right_x, $upper_right_y )
1219
1220 this is a low level sub, that draws a pdf box, it is called by draw_boxes
1221
1222 FYI: the  $upper_right_x and $upper_right_y values are RELATIVE to  $lower_left_x and $lower_left_y
1223
1224 and $lower_left_x, $lower_left_y are ABSOLUTE, this caught me out!
1225
1226 =cut
1227
1228 #'
1229 sub drawbox {
1230     my ( $llx, $lly, $urx, $ury ) = @_;
1231
1232     #    warn "llx,y= $llx,$lly  ,   urx,y=$urx,$ury \n";
1233
1234     my $str = "q\n";    # save the graphic state
1235     $str .= "0.5 w\n";              # border color red
1236     $str .= "1.0 0.0 0.0  RG\n";    # border color red
1237          #   $str .= "0.5 0.75 1.0 rg\n";           # fill color blue
1238     $str .= "1.0 1.0 1.0  rg\n";    # fill color white
1239
1240     $str .= "$llx $lly $urx $ury re\n";    # a rectangle
1241     $str .= "B\n";                         # fill (and a little more)
1242     $str .= "Q\n";                         # save the graphic state
1243
1244     prAdd($str);
1245
1246 }
1247
1248 END { }    # module clean-up code here (global destructor)
1249
1250 1;
1251 __END__
1252
1253 =back
1254
1255 =head1 AUTHOR
1256
1257 Mason James <mason@katipo.co.nz>
1258
1259 =cut
1260