3 # Copyright 2006 Katipo Communications.
5 # This file is part of Koha.
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
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.
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
21 use vars qw($VERSION @ISA @EXPORT);
25 use Algorithm::CheckDigits;
27 # use Smart::Comments;
34 &get_label_options &get_label_items
35 &build_circ_barcode &draw_boundaries
36 &drawbox &GetActiveLabelTemplate
37 &GetAllLabelTemplates &DeleteTemplate
38 &GetSingleLabelTemplate &SaveTemplate
39 &CreateTemplate &SetActiveTemplate
40 &SaveConf &DrawSpineText &GetTextWrapCols
41 &GetUnitsValue &DrawBarcode
45 &get_batches &delete_batch
46 &add_batch &SetFontSize &printText
49 get_layout &save_layout &add_layout
50 &set_active_layout &by_order
52 &delete_layout &get_active_layout
55 &GetAllPrinterProfiles &GetSinglePrinterProfile
56 &SaveProfile &CreateProfile &DeleteProfile
57 &GetAssociatedProfile &SetAssociatedProfile
65 C4::Labels - Functions for printing spine labels and barcodes in Koha
71 =item get_label_options;
73 $options = get_label_options()
75 Return a pointer on a hash list containing info from labels_conf table in Koha DB.
80 sub get_label_options {
81 my $dbh = C4::Context->dbh;
82 my $query2 = " SELECT * FROM labels_conf where active = 1";
83 my $sth = $dbh->prepare($query2);
85 my $conf_data = $sth->fetchrow_hashref;
92 ## FIXME: this if/else could be compacted...
93 my $dbh = C4::Context->dbh;
95 my $query = " Select * from labels_conf";
96 my $sth = $dbh->prepare($query);
99 while ( my $data = $sth->fetchrow_hashref ) {
101 $data->{'fieldlist'} = get_text_fields( $data->{'id'} );
102 push( @resultsloop, $data );
112 my ($layout_id) = @_;
113 my $dbh = C4::Context->dbh;
115 # get the actual items to be printed.
116 my $query = " Select * from labels_conf where id = ?";
117 my $sth = $dbh->prepare($query);
118 $sth->execute($layout_id);
119 my $data = $sth->fetchrow_hashref;
124 sub get_active_layout {
125 my ($layout_id) = @_;
126 my $dbh = C4::Context->dbh;
128 # get the actual items to be printed.
129 my $query = " Select * from labels_conf where active = 1";
130 my $sth = $dbh->prepare($query);
132 my $data = $sth->fetchrow_hashref;
138 my ($layout_id) = @_;
139 my $dbh = C4::Context->dbh;
141 # get the actual items to be printed.
142 my $query = "delete from labels_conf where id = ?";
143 my $sth = $dbh->prepare($query);
144 $sth->execute($layout_id);
148 sub get_printingtypes {
149 my ($layout_id) = @_;
152 push( @printtypes, { code => 'BAR', desc => "barcode" } );
153 push( @printtypes, { code => 'BIB', desc => "biblio" } );
154 push( @printtypes, { code => 'BARBIB', desc => "barcode / biblio" } );
155 push( @printtypes, { code => 'BIBBAR', desc => "biblio / barcode" } );
156 push( @printtypes, { code => 'ALT', desc => "alternating labels" } );
158 my $conf = get_layout($layout_id);
159 my $active_printtype = $conf->{'printingtype'};
161 # lop thru layout, insert selected to hash
163 foreach my $printtype (@printtypes) {
164 if ( $printtype->{'code'} eq $active_printtype ) {
165 $printtype->{'active'} = 'MOO';
171 sub build_text_dropbox {
174 # my @fields = get_text_fields();
175 # my $field_count = scalar @fields;
176 my $field_count = 10; # <----------- FIXME hard coded
180 ? push( @lines, { num => '', selected => '1' } )
181 : push( @lines, { num => '' } );
182 for ( my $i = 1 ; $i <= $field_count ; $i++ ) {
183 my $line = { num => "$i" };
184 $line->{'selected'} = 1 if $i eq $order;
185 push( @lines, $line );
188 # add a blank row too
193 sub get_text_fields {
194 my ($layout_id, $sorttype) = @_;
196 my ( $a, $b, $c, $d, $e, $f, $g, $h, $i ,$j, $k );
198 my $sortorder = get_layout($layout_id);
205 order => $sortorder->{'itemtype'}
210 order => $sortorder->{'dewey'}
212 $c = { code => 'issn', desc => "ISSN",
213 order => $sortorder->{'issn'} };
214 $d = { code => 'isbn', desc => "ISBN",
215 order => $sortorder->{'isbn'} };
218 desc => "Classification",
219 order => $sortorder->{'class'}
224 order => $sortorder->{'subclass'}
229 order => $sortorder->{'barcode'}
232 { code => 'author', desc => "Author", order => $sortorder->{'author'} };
233 $i = { code => 'title', desc => "Title", order => $sortorder->{'title'} };
234 $j = { code => 'itemcallnumber', desc => "Call Number", order => $sortorder->{'itemcallnumber'} };
235 $k = { code => 'subtitle', desc => "Subtitle", order => $sortorder->{'subtitle'} };
237 my @text_fields = ( $a, $b, $c, $d, $e, $f, $g, $h, $i ,$j, $k );
240 foreach my $field (@text_fields) {
241 push( @new_fields, $field ) if $field->{'order'} > 0;
244 my @sorted_fields = sort by_order @new_fields;
246 foreach my $field (@sorted_fields) {
247 $sorttype eq 'codes' ? $active_fields .= "$field->{'code'} " :
248 $active_fields .= "$field->{'desc'} ";
250 return $active_fields;
255 $$a{order} <=> $$b{order};
260 my $dbh = C4::Context->dbh;
262 "select distinct batch_id from labels order by batch_id desc limit 1";
263 my $sth = $dbh->prepare($q);
265 my $data = $sth->fetchrow_hashref;
268 if ( !$data->{'batch_id'} ) {
272 $new_batch = ( $data->{'batch_id'} + 1 );
279 sub get_highest_batch {
281 my $dbh = C4::Context->dbh;
283 "select distinct batch_id from labels order by batch_id desc limit 1";
284 my $sth = $dbh->prepare($q);
286 my $data = $sth->fetchrow_hashref;
289 if ( !$data->{'batch_id'} ) {
293 $new_batch = $data->{'batch_id'};
301 my $dbh = C4::Context->dbh;
302 my $q = "select batch_id, count(*) as num from labels group by batch_id";
303 my $sth = $dbh->prepare($q);
306 while ( my $data = $sth->fetchrow_hashref ) {
307 push( @resultsloop, $data );
311 # adding a dummy batch=1 value , if none exists in the db
312 if ( !scalar(@resultsloop) ) {
313 push( @resultsloop, { batch_id => '1' , num => '0' } );
320 my $dbh = C4::Context->dbh;
321 my $q = "DELETE FROM labels where batch_id = ?";
322 my $sth = $dbh->prepare($q);
323 $sth->execute($batch_id);
327 sub get_barcode_types {
328 my ($layout_id) = @_;
329 my $layout = get_layout($layout_id);
330 my $barcode = $layout->{'barcodetype'};
333 push( @array, { code => 'CODE39', desc => 'Code 39' } );
334 push( @array, { code => 'CODE39MOD', desc => 'Code39 + Modulo43' } );
335 push( @array, { code => 'CODE39MOD10', desc => 'Code39 + Modulo10' } );
336 push( @array, { code => 'ITF', desc => 'Interleaved 2 of 5' } );
338 foreach my $line (@array) {
339 if ( $line->{'code'} eq $barcode ) {
340 $line->{'active'} = 1;
351 $unitvalue = '1' if ( $units eq 'POINT' );
352 $unitvalue = '2.83464567' if ( $units eq 'MM' );
353 $unitvalue = '28.3464567' if ( $units eq 'CM' );
354 $unitvalue = 72 if ( $units eq 'INCH' );
358 sub GetTextWrapCols {
359 my ( $fontsize, $label_width ) = @_;
361 my $left_text_margin = 3;
362 my ( $strtmp, $strwidth );
364 my $textlimit = $label_width - $left_text_margin;
366 while ( $strwidth < $textlimit ) {
367 $strwidth = prStrWidth( $string, 'C', $fontsize );
368 $string = $string . '0';
370 # warn "strwidth $strwidth, $textlimit, $string";
376 sub GetActiveLabelTemplate {
377 my $dbh = C4::Context->dbh;
378 my $query = " SELECT * FROM labels_templates where active = 1 limit 1";
379 my $sth = $dbh->prepare($query);
381 my $active_tmpl = $sth->fetchrow_hashref;
386 sub GetSingleLabelTemplate {
388 my $dbh = C4::Context->dbh;
389 my $query = " SELECT * FROM labels_templates where tmpl_id = ?";
390 my $sth = $dbh->prepare($query);
391 $sth->execute($tmpl_id);
392 my $template = $sth->fetchrow_hashref;
397 sub SetActiveTemplate {
401 my $dbh = C4::Context->dbh;
402 my $query = " UPDATE labels_templates SET active = NULL";
403 my $sth = $dbh->prepare($query);
406 $query = "UPDATE labels_templates SET active = 1 WHERE tmpl_id = ?";
407 $sth = $dbh->prepare($query);
408 $sth->execute($tmpl_id);
412 sub set_active_layout {
414 my ($layout_id) = @_;
415 my $dbh = C4::Context->dbh;
416 my $query = " UPDATE labels_conf SET active = NULL";
417 my $sth = $dbh->prepare($query);
420 $query = "UPDATE labels_conf SET active = 1 WHERE id = ?";
421 $sth = $dbh->prepare($query);
422 $sth->execute($layout_id);
428 my $dbh = C4::Context->dbh;
429 my $query = " DELETE FROM labels_templates where tmpl_id = ?";
430 my $sth = $dbh->prepare($query);
431 $sth->execute($tmpl_id);
437 $tmpl_id, $tmpl_code, $tmpl_desc, $page_width,
438 $page_height, $label_width, $label_height, $topmargin,
439 $leftmargin, $cols, $rows, $colgap,
440 $rowgap, $fontsize, $units
442 my $dbh = C4::Context->dbh;
444 " UPDATE labels_templates SET tmpl_code=?, tmpl_desc=?, page_width=?,
445 page_height=?, label_width=?, label_height=?, topmargin=?,
446 leftmargin=?, cols=?, rows=?, colgap=?, rowgap=?, fontsize=?,
450 my $sth = $dbh->prepare($query);
452 $tmpl_code, $tmpl_desc, $page_width, $page_height,
453 $label_width, $label_height, $topmargin, $leftmargin,
454 $cols, $rows, $colgap, $rowgap,
455 $fontsize, $units, $tmpl_id
463 $tmpl_code, $tmpl_desc, $page_width, $page_height,
464 $label_width, $label_height, $topmargin, $leftmargin,
465 $cols, $rows, $colgap, $rowgap,
469 my $dbh = C4::Context->dbh;
471 my $query = "INSERT INTO labels_templates (tmpl_code, tmpl_desc, page_width,
472 page_height, label_width, label_height, topmargin,
473 leftmargin, cols, rows, colgap, rowgap, fontsize, units)
474 VALUES(?,?,?,?,?,?,?,?,?,?,?,?,?,?)";
476 my $sth = $dbh->prepare($query);
478 $tmpl_code, $tmpl_desc, $page_width, $page_height,
479 $label_width, $label_height, $topmargin, $leftmargin,
480 $cols, $rows, $colgap, $rowgap,
485 sub GetAllLabelTemplates {
486 my $dbh = C4::Context->dbh;
488 # get the actual items to be printed.
490 my $query = " Select * from labels_templates ";
491 my $sth = $dbh->prepare($query);
494 while ( my $data = $sth->fetchrow_hashref ) {
495 push( @resultsloop, $data );
499 #warn Dumper @resultsloop;
507 $barcodetype, $title, $subtitle, $isbn, $issn,
508 $itemtype, $bcn, $dcn, $classif,
509 $subclass, $itemcallnumber, $author, $tmpl_id,
510 $printingtype, $guidebox, $startlabel, $layoutname
513 my $dbh = C4::Context->dbh;
514 my $query2 = "update labels_conf set active = NULL";
515 my $sth2 = $dbh->prepare($query2);
517 $query2 = "INSERT INTO labels_conf
518 ( barcodetype, title, subtitle, isbn,issn, itemtype, barcode,
519 dewey, class, subclass, itemcallnumber, author, printingtype,
520 guidebox, startlabel, layoutname, active )
521 values ( ?, ?, ?, ?, ?, ?, ?, ?,?, ?, ?, ?, ?, ?,?,?, 1 )";
522 $sth2 = $dbh->prepare($query2);
524 $barcodetype, $title, $subtitle, $isbn, $issn,
526 $itemtype, $bcn, $dcn, $classif,
527 $subclass, $itemcallnumber, $author, $printingtype,
528 $guidebox, $startlabel, $layoutname
532 SetActiveTemplate($tmpl_id);
539 $barcodetype, $title, $subtitle, $isbn, $issn,
540 $itemtype, $bcn, $dcn, $classif,
541 $subclass, $itemcallnumber, $author, $tmpl_id,
542 $printingtype, $guidebox, $startlabel, $layoutname,
548 my $dbh = C4::Context->dbh;
549 my $query2 = "update labels_conf set
550 barcodetype=?, title=?, subtitle=?, isbn=?,issn=?,
551 itemtype=?, barcode=?, dewey=?, class=?,
552 subclass=?, itemcallnumber=?, author=?, printingtype=?,
553 guidebox=?, startlabel=?, layoutname=? where id = ?";
554 my $sth2 = $dbh->prepare($query2);
556 $barcodetype, $title, $subtitle, $isbn, $issn,
557 $itemtype, $bcn, $dcn, $classif,
558 $subclass, $itemcallnumber, $author, $printingtype,
559 $guidebox, $startlabel, $layoutname, $layout_id
566 =item GetAllPrinterProfiles;
568 @profiles = GetAllPrinterProfiles()
570 Returns an array of references-to-hash, whos keys are .....
574 sub GetAllPrinterProfiles {
576 my $dbh = C4::Context->dbh;
578 my $query = "SELECT * FROM printers_profile AS pp INNER JOIN labels_templates AS lt ON pp.tmpl_id = lt.tmpl_id; ";
579 my $sth = $dbh->prepare($query);
582 while ( my $data = $sth->fetchrow_hashref ) {
583 push( @resultsloop, $data );
590 =item GetSinglePrinterProfile;
592 $profile = GetSinglePrinterProfile()
594 Returns a hashref whos keys are...
598 sub GetSinglePrinterProfile {
600 my $dbh = C4::Context->dbh;
601 my $query = " SELECT * FROM printers_profile WHERE prof_id = ?; ";
602 my $sth = $dbh->prepare($query);
603 $sth->execute($prof_id);
604 my $template = $sth->fetchrow_hashref;
611 SaveProfile('parameters')
613 When passed a set of parameters, this function updates the given profile with the new parameters.
619 $prof_id, $offset_horz, $offset_vert, $creep_horz, $creep_vert, $units
621 my $dbh = C4::Context->dbh;
623 " UPDATE printers_profile
624 SET offset_horz=?, offset_vert=?, creep_horz=?, creep_vert=?, unit=?
626 my $sth = $dbh->prepare($query);
628 $offset_horz, $offset_vert, $creep_horz, $creep_vert, $units, $prof_id
635 CreateProfile('parameters')
637 When passed a set of parameters, this function creates a new profile containing those parameters
638 and returns any errors.
644 $prof_id, $printername, $paper_bin, $tmpl_id, $offset_horz,
645 $offset_vert, $creep_horz, $creep_vert, $units
647 my $dbh = C4::Context->dbh;
649 " INSERT INTO printers_profile (prof_id, printername, paper_bin, tmpl_id,
650 offset_horz, offset_vert, creep_horz, creep_vert, unit)
651 VALUES(?,?,?,?,?,?,?,?,?) ";
652 my $sth = $dbh->prepare($query);
654 $prof_id, $printername, $paper_bin, $tmpl_id, $offset_horz,
655 $offset_vert, $creep_horz, $creep_vert, $units
657 my $error = $sth->errstr;
664 DeleteProfile(prof_id)
666 When passed a profile id, this function deletes that profile from the database and returns any errors.
672 my $dbh = C4::Context->dbh;
673 my $query = " DELETE FROM printers_profile WHERE prof_id = ?";
674 my $sth = $dbh->prepare($query);
675 $sth->execute($prof_id);
676 my $error = $sth->errstr;
681 =item GetAssociatedProfile;
683 $assoc_prof = GetAssociatedProfile(tmpl_id)
685 When passed a template id, this function returns the parameters from the currently associated printer profile
686 in a hashref where key=fieldname and value=fieldvalue.
690 sub GetAssociatedProfile {
692 my $dbh = C4::Context->dbh;
693 # First we find out the prof_id for the associated profile...
694 my $query = "SELECT * FROM labels_profile WHERE tmpl_id = ?";
695 my $sth = $dbh->prepare($query);
696 $sth->execute($tmpl_id);
697 my $assoc_prof = $sth->fetchrow_hashref;
699 # Then we retrieve that profile and return it to the caller...
700 $assoc_prof = GetSinglePrinterProfile($assoc_prof->{'prof_id'});
704 =item SetAssociatedProfile;
706 SetAssociatedProfile($prof_id, $tmpl_id)
708 When passed both a profile id and template id, this function establishes an association between the two. No more
709 than one profile may be associated with any given template at the same time.
713 sub SetAssociatedProfile {
715 my ($prof_id, $tmpl_id) = @_;
717 my $dbh = C4::Context->dbh;
718 my $query = "INSERT INTO labels_profile (prof_id, tmpl_id) VALUES (?,?) ON DUPLICATE KEY UPDATE prof_id = ?";
719 my $sth = $dbh->prepare($query);
720 $sth->execute($prof_id, $tmpl_id, $prof_id);
724 =item get_label_items;
726 $options = get_label_items()
728 Returns an array of references-to-hash, whos keys are the field from the biblio, biblioitems, items and labels tables in the Koha database.
733 sub get_label_items {
735 my $dbh = C4::Context->dbh;
737 my @resultsloop = ();
743 my $query3 = "Select * from labels where batch_id = ? order by labelid ";
744 $sth = $dbh->prepare($query3);
745 $sth->execute($batch_id);
750 my $query3 = "Select * from labels";
751 $sth = $dbh->prepare($query3);
754 my $cnt = $sth->rows;
756 while ( my $data = $sth->fetchrow_hashref ) {
758 # lets get some summary info from each item
760 select i.*, bi.*, b.* from items i,biblioitems bi,biblio b
761 where itemnumber=? and i.biblioitemnumber=bi.biblioitemnumber and
762 bi.biblionumber=b.biblionumber";
764 my $sth1 = $dbh->prepare($query1);
765 $sth1->execute( $data->{'itemnumber'} );
767 my $data1 = $sth1->fetchrow_hashref();
768 $data1->{'labelno'} = $i1;
769 $data1->{'labelid'} = $data->{'labelid'};
770 $data1->{'batch_id'} = $batch_id;
771 $data1->{'summary'} =
772 "$data1->{'barcode'}, $data1->{'title'}, $data1->{'isbn'}";
774 push( @resultsloop, $data1 );
786 barcode title subtitle
787 dewey isbn issn author class
788 itemtype subclass itemcallnumber
794 sub deduplicate_batch {
795 my $batch_id = shift or return undef;
799 count(labelid) as count
802 GROUP BY itemnumber,batch_id
806 my $sth = C4::Context->dbh->prepare($query);
807 $sth->execute($batch_id);
808 $sth->rows or return undef;
815 ORDER BY timestamp ASC
818 while (my $data = $sth->fetchrow_hashref()) {
819 my $itemnumber = $data->{itemnumber} or next;
820 my $limit = $data->{count} - 1 or next;
821 my $sth2 = C4::Context->dbh->prepare("$del_query LIMIT $limit");
822 # die sprintf "$del_query LIMIT %s\n (%s, %s)", $limit, $batch_id, $itemnumber;
823 # $sth2->execute($batch_id, C4::Context->dbh->quote($data->{itemnumber}), $data->{count} - 1)
824 $sth2->execute($batch_id, $itemnumber) and
825 $killed += ($data->{count} - 1);
832 my ( $y_pos, $label_height, $fontsize, $x_pos, $left_text_margin,
833 $text_wrap_cols, $item, $conf_data )
835 # hack to fix column name mismatch betwen labels_conf.class, and bibitems.classification
836 $$item->{'class'} = $$item->{'classification'};
838 $Text::Wrap::columns = $text_wrap_cols;
839 $Text::Wrap::separator = "\n";
844 my $top_text_margin = ( $fontsize + 3 );
845 my $line_spacer = ($fontsize); # number of pixels between text rows.
847 # add your printable fields manually in here
849 my $layout_id = $$conf_data->{'id'};
851 # my @fields = GetItemFields();
853 my $str_fields = get_text_fields($layout_id, 'codes' );
854 my @fields = split(/ /, $str_fields);
857 my $vPos = ( $y_pos + ( $label_height - $top_text_margin ) );
858 my $hPos = ( $x_pos + $left_text_margin );
860 # warn Dumper $conf_data;
863 foreach my $field (@fields) {
866 # $$item->{"$field"} = $field . ": " . $$item->{"$field"};
868 # if the display option for this field is selected in the DB,
869 # and the item record has some values for this field, display it.
870 if ( $$conf_data->{"$field"} && $$item->{"$field"} ) {
872 # warn "CONF_TYPE = $field";
875 $str = $$item->{"$field"};
876 # strip out naughty existing nl/cr's
880 # chop the string up into _upto_ 12 chunks
881 # and seperate the chunks with newlines
883 $str = wrap( "", "", "$str" );
884 $str = wrap( "", "", "$str" );
886 # split the chunks between newline's, into an array
887 my @strings = split /\n/, $str;
889 # then loop for each string line
890 foreach my $str (@strings) {
892 #warn "HPOS , VPOS $hPos, $vPos ";
893 # set the font size A
895 # prText( $hPos, $vPos, $str );
896 PrintText( $hPos, $vPos, $fontsize, $str );
897 $vPos = $vPos - $line_spacer;
899 } # if field is } #foreach feild
904 my ( $hPos, $vPos, $fontsize, $text ) = @_;
905 my $str = "BT /Ft1 $fontsize Tf $hPos $vPos Td ($text) Tj ET";
913 my $str = "BT/F13 30 Tf288 720 Td( AAAAAAAAAA ) TjET";
919 # x and y are from the top-left :)
920 my ( $x_pos, $y_pos, $height, $width, $barcode, $barcodetype ) = @_;
921 my $num_of_bars = length($barcode);
922 my $bar_width = $width * .8; # %80 of length of label width
925 my $guard_length = 10;
928 if ( $barcodetype eq 'CODE39' ) {
929 $bar_length = '17.5';
931 ( $bar_length * $num_of_bars ) + ( $guard_length * 2 );
932 $xsize_ratio = ( $bar_width / $tot_bar_length );
934 PDF::Reuse::Barcode::Code39(
935 x => ( $x_pos + ( $width / 10 ) ),
936 y => ( $y_pos + ( $height / 10 ) ),
937 value => "*$barcode*",
938 ySize => ( .02 * $height ),
939 xSize => $xsize_ratio,
944 warn "$barcodetype, $barcode FAILED:$@";
948 elsif ( $barcodetype eq 'CODE39MOD' ) {
950 # get modulo43 checksum
951 my $c39 = CheckDigits('code_39');
952 $barcode = $c39->complete($barcode);
956 ( $bar_length * $num_of_bars ) + ( $guard_length * 2 );
957 $xsize_ratio = ( $bar_width / $tot_bar_length );
959 PDF::Reuse::Barcode::Code39(
960 x => ( $x_pos + ( $width / 10 ) ),
961 y => ( $y_pos + ( $height / 10 ) ),
962 value => "*$barcode*",
963 ySize => ( .02 * $height ),
964 xSize => $xsize_ratio,
970 warn "$barcodetype, $barcode FAILED:$@";
973 elsif ( $barcodetype eq 'CODE39MOD10' ) {
975 # get modulo43 checksum
976 my $c39_10 = CheckDigits('visa');
977 $barcode = $c39_10->complete($barcode);
981 ( $bar_length * $num_of_bars ) + ( $guard_length * 2 );
982 $xsize_ratio = ( $bar_width / $tot_bar_length );
984 PDF::Reuse::Barcode::Code39(
985 x => ( $x_pos + ( $width / 10 ) ),
986 y => ( $y_pos + ( $height / 10 ) ),
987 value => "*$barcode*",
988 ySize => ( .02 * $height ),
989 xSize => $xsize_ratio,
996 warn "$barcodetype, $barcode FAILED:$@";
1001 elsif ( $barcodetype eq 'COOP2OF5' ) {
1002 $bar_length = '9.43333333333333';
1004 ( $bar_length * $num_of_bars ) + ( $guard_length * 2 );
1005 $xsize_ratio = ( $bar_width / $tot_bar_length ) * .9;
1007 PDF::Reuse::Barcode::COOP2of5(
1008 x => ( $x_pos + ( $width / 10 ) ),
1009 y => ( $y_pos + ( $height / 10 ) ),
1011 ySize => ( .02 * $height ),
1012 xSize => $xsize_ratio,
1016 warn "$barcodetype, $barcode FAILED:$@";
1020 elsif ( $barcodetype eq 'INDUSTRIAL2OF5' ) {
1021 $bar_length = '13.1333333333333';
1023 ( $bar_length * $num_of_bars ) + ( $guard_length * 2 );
1024 $xsize_ratio = ( $bar_width / $tot_bar_length ) * .9;
1026 PDF::Reuse::Barcode::Industrial2of5(
1027 x => ( $x_pos + ( $width / 10 ) ),
1028 y => ( $y_pos + ( $height / 10 ) ),
1030 ySize => ( .02 * $height ),
1031 xSize => $xsize_ratio,
1035 warn "$barcodetype, $barcode FAILED:$@";
1039 my $moo2 = $tot_bar_length * $xsize_ratio;
1041 warn "$x_pos, $y_pos, $barcode, $barcodetype" if $DEBUG;
1042 warn "BAR_WDTH = $bar_width, TOT.BAR.LGHT=$tot_bar_length R*TOT.BAR =$moo2" if $DEBUG;
1045 =item build_circ_barcode;
1047 build_circ_barcode( $x_pos, $y_pos, $barcode,
1048 $barcodetype, \$item);
1050 $item is the result of a previous call to get_label_items();
1055 sub build_circ_barcode {
1056 my ( $x_pos_circ, $y_pos, $value, $barcodetype, $item ) = @_;
1058 #warn Dumper \$item;
1060 #warn "value = $value\n";
1064 if ( $barcodetype eq 'EAN13' ) {
1066 #testing EAN13 barcodes hack
1067 $value = $value . '000000000';
1069 $value = substr( $value, 0, 12 );
1073 PDF::Reuse::Barcode::EAN13(
1074 x => ( $x_pos_circ + 27 ),
1075 y => ( $y_pos + 15 ),
1083 # added for xpdf compat. doesnt use type3 fonts., but increases filesize from 20k to 200k
1084 # i think its embedding extra fonts in the pdf file.
1085 # mode => 'graphic',
1089 $item->{'barcodeerror'} = 1;
1091 #warn "EAN13BARCODE FAILED:$@";
1097 elsif ( $barcodetype eq 'Code39' ) {
1100 PDF::Reuse::Barcode::Code39(
1101 x => ( $x_pos_circ + 9 ),
1102 y => ( $y_pos + 15 ),
1112 $item->{'barcodeerror'} = 1;
1114 #warn "CODE39BARCODE $value FAILED:$@";
1121 elsif ( $barcodetype eq 'Matrix2of5' ) {
1123 #warn "MATRIX ELSE:";
1125 #testing MATRIX25 barcodes hack
1126 # $value = $value.'000000000';
1129 # $value = substr( $value, 0, 12 );
1133 PDF::Reuse::Barcode::Matrix2of5(
1134 x => ( $x_pos_circ + 27 ),
1135 y => ( $y_pos + 15 ),
1145 $item->{'barcodeerror'} = 1;
1147 #warn "BARCODE FAILED:$@";
1154 elsif ( $barcodetype eq 'EAN8' ) {
1156 #testing ean8 barcodes hack
1157 $value = $value . '000000000';
1159 $value = substr( $value, 0, 8 );
1163 #warn "EAN8 ELSEIF";
1165 PDF::Reuse::Barcode::EAN8(
1166 x => ( $x_pos_circ + 42 ),
1167 y => ( $y_pos + 15 ),
1177 $item->{'barcodeerror'} = 1;
1179 #warn "BARCODE FAILED:$@";
1186 elsif ( $barcodetype eq 'UPC-E' ) {
1188 PDF::Reuse::Barcode::UPCE(
1189 x => ( $x_pos_circ + 27 ),
1190 y => ( $y_pos + 15 ),
1200 $item->{'barcodeerror'} = 1;
1202 #warn "BARCODE FAILED:$@";
1208 elsif ( $barcodetype eq 'NW7' ) {
1210 PDF::Reuse::Barcode::NW7(
1211 x => ( $x_pos_circ + 27 ),
1212 y => ( $y_pos + 15 ),
1222 $item->{'barcodeerror'} = 1;
1224 #warn "BARCODE FAILED:$@";
1230 elsif ( $barcodetype eq 'ITF' ) {
1232 PDF::Reuse::Barcode::ITF(
1233 x => ( $x_pos_circ + 27 ),
1234 y => ( $y_pos + 15 ),
1244 $item->{'barcodeerror'} = 1;
1246 #warn "BARCODE FAILED:$@";
1252 elsif ( $barcodetype eq 'Industrial2of5' ) {
1254 PDF::Reuse::Barcode::Industrial2of5(
1255 x => ( $x_pos_circ + 27 ),
1256 y => ( $y_pos + 15 ),
1265 $item->{'barcodeerror'} = 1;
1267 #warn "BARCODE FAILED:$@";
1273 elsif ( $barcodetype eq 'IATA2of5' ) {
1275 PDF::Reuse::Barcode::IATA2of5(
1276 x => ( $x_pos_circ + 27 ),
1277 y => ( $y_pos + 15 ),
1286 $item->{'barcodeerror'} = 1;
1288 #warn "BARCODE FAILED:$@";
1295 elsif ( $barcodetype eq 'COOP2of5' ) {
1297 PDF::Reuse::Barcode::COOP2of5(
1298 x => ( $x_pos_circ + 27 ),
1299 y => ( $y_pos + 15 ),
1308 $item->{'barcodeerror'} = 1;
1310 #warn "BARCODE FAILED:$@";
1316 elsif ( $barcodetype eq 'UPC-A' ) {
1319 PDF::Reuse::Barcode::UPCA(
1320 x => ( $x_pos_circ + 27 ),
1321 y => ( $y_pos + 15 ),
1330 $item->{'barcodeerror'} = 1;
1332 #warn "BARCODE FAILED:$@";
1341 =item draw_boundaries
1343 sub draw_boundaries ($x_pos_spine, $x_pos_circ1, $x_pos_circ2,
1344 $y_pos, $spine_width, $label_height, $circ_width)
1346 This sub draws boundary lines where the label outlines are, to aid in printer testing, and debugging.
1351 sub draw_boundaries {
1354 $x_pos_spine, $x_pos_circ1, $x_pos_circ2, $y_pos,
1355 $spine_width, $label_height, $circ_width
1358 my $y_pos_initial = ( ( 792 - 36 ) - 90 );
1359 $y_pos = $y_pos_initial; # FIXME - why are we ignoring the y_pos parameter by redefining it?
1362 for ( $i = 1 ; $i <= 8 ; $i++ ) {
1364 &drawbox( $x_pos_spine, $y_pos, ($spine_width), ($label_height) );
1366 #warn "OLD BOXES x=$x_pos_spine, y=$y_pos, w=$spine_width, h=$label_height";
1367 &drawbox( $x_pos_circ1, $y_pos, ($circ_width), ($label_height) );
1368 &drawbox( $x_pos_circ2, $y_pos, ($circ_width), ($label_height) );
1370 $y_pos = ( $y_pos - $label_height );
1377 sub drawbox { $lower_left_x, $lower_left_y,
1378 $upper_right_x, $upper_right_y )
1380 this is a low level sub, that draws a pdf box, it is called by draw_boxes
1382 FYI: the $upper_right_x and $upper_right_y values are RELATIVE to $lower_left_x and $lower_left_y
1384 and $lower_left_x, $lower_left_y are ABSOLUTE, this caught me out!
1390 my ( $llx, $lly, $urx, $ury ) = @_;
1392 # warn "llx,y= $llx,$lly , urx,y=$urx,$ury \n";
1394 my $str = "q\n"; # save the graphic state
1395 $str .= "0.5 w\n"; # border color red
1396 $str .= "1.0 0.0 0.0 RG\n"; # border color red
1397 # $str .= "0.5 0.75 1.0 rg\n"; # fill color blue
1398 $str .= "1.0 1.0 1.0 rg\n"; # fill color white
1400 $str .= "$llx $lly $urx $ury re\n"; # a rectangle
1401 $str .= "B\n"; # fill (and a little more)
1402 $str .= "Q\n"; # save the graphic state
1408 END { } # module clean-up code here (global destructor)
1417 Mason James <mason@katipo.co.nz>