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 # Not sure why we are doing this rather than simply telling the user that no batches are currently defined.
312 # So I'm commenting this out and modifying label-manager.tmpl to properly inform the user as stated. -fbcit
313 # adding a dummy batch=1 value , if none exists in the db
314 # if ( !scalar(@resultsloop) ) {
315 # push( @resultsloop, { batch_id => '1' , num => '0' } );
322 my $dbh = C4::Context->dbh;
323 my $q = "DELETE FROM labels where batch_id = ?";
324 my $sth = $dbh->prepare($q);
325 $sth->execute($batch_id);
329 sub get_barcode_types {
330 my ($layout_id) = @_;
331 my $layout = get_layout($layout_id);
332 my $barcode = $layout->{'barcodetype'};
335 push( @array, { code => 'CODE39', desc => 'Code 39' } );
336 push( @array, { code => 'CODE39MOD', desc => 'Code39 + Modulo43' } );
337 push( @array, { code => 'CODE39MOD10', desc => 'Code39 + Modulo10' } );
338 push( @array, { code => 'ITF', desc => 'Interleaved 2 of 5' } );
340 foreach my $line (@array) {
341 if ( $line->{'code'} eq $barcode ) {
342 $line->{'active'} = 1;
353 $unitvalue = '1' if ( $units eq 'POINT' );
354 $unitvalue = '2.83464567' if ( $units eq 'MM' );
355 $unitvalue = '28.3464567' if ( $units eq 'CM' );
356 $unitvalue = 72 if ( $units eq 'INCH' );
360 sub GetTextWrapCols {
361 my ( $fontsize, $label_width ) = @_;
363 my $left_text_margin = 3;
364 my ( $strtmp, $strwidth );
366 my $textlimit = $label_width - $left_text_margin;
368 while ( $strwidth < $textlimit ) {
369 $strwidth = prStrWidth( $string, 'C', $fontsize );
370 $string = $string . '0';
372 # warn "strwidth $strwidth, $textlimit, $string";
378 sub GetActiveLabelTemplate {
379 my $dbh = C4::Context->dbh;
380 my $query = " SELECT * FROM labels_templates where active = 1 limit 1";
381 my $sth = $dbh->prepare($query);
383 my $active_tmpl = $sth->fetchrow_hashref;
388 sub GetSingleLabelTemplate {
390 my $dbh = C4::Context->dbh;
391 my $query = " SELECT * FROM labels_templates where tmpl_id = ?";
392 my $sth = $dbh->prepare($query);
393 $sth->execute($tmpl_id);
394 my $template = $sth->fetchrow_hashref;
399 sub SetActiveTemplate {
403 my $dbh = C4::Context->dbh;
404 my $query = " UPDATE labels_templates SET active = NULL";
405 my $sth = $dbh->prepare($query);
408 $query = "UPDATE labels_templates SET active = 1 WHERE tmpl_id = ?";
409 $sth = $dbh->prepare($query);
410 $sth->execute($tmpl_id);
414 sub set_active_layout {
416 my ($layout_id) = @_;
417 my $dbh = C4::Context->dbh;
418 my $query = " UPDATE labels_conf SET active = NULL";
419 my $sth = $dbh->prepare($query);
422 $query = "UPDATE labels_conf SET active = 1 WHERE id = ?";
423 $sth = $dbh->prepare($query);
424 $sth->execute($layout_id);
430 my $dbh = C4::Context->dbh;
431 my $query = " DELETE FROM labels_templates where tmpl_id = ?";
432 my $sth = $dbh->prepare($query);
433 $sth->execute($tmpl_id);
439 $tmpl_id, $tmpl_code, $tmpl_desc, $page_width,
440 $page_height, $label_width, $label_height, $topmargin,
441 $leftmargin, $cols, $rows, $colgap,
442 $rowgap, $fontsize, $units
444 my $dbh = C4::Context->dbh;
446 " UPDATE labels_templates SET tmpl_code=?, tmpl_desc=?, page_width=?,
447 page_height=?, label_width=?, label_height=?, topmargin=?,
448 leftmargin=?, cols=?, rows=?, colgap=?, rowgap=?, fontsize=?,
452 my $sth = $dbh->prepare($query);
454 $tmpl_code, $tmpl_desc, $page_width, $page_height,
455 $label_width, $label_height, $topmargin, $leftmargin,
456 $cols, $rows, $colgap, $rowgap,
457 $fontsize, $units, $tmpl_id
465 $tmpl_code, $tmpl_desc, $page_width, $page_height,
466 $label_width, $label_height, $topmargin, $leftmargin,
467 $cols, $rows, $colgap, $rowgap,
471 my $dbh = C4::Context->dbh;
473 my $query = "INSERT INTO labels_templates (tmpl_code, tmpl_desc, page_width,
474 page_height, label_width, label_height, topmargin,
475 leftmargin, cols, rows, colgap, rowgap, fontsize, units)
476 VALUES(?,?,?,?,?,?,?,?,?,?,?,?,?,?)";
478 my $sth = $dbh->prepare($query);
480 $tmpl_code, $tmpl_desc, $page_width, $page_height,
481 $label_width, $label_height, $topmargin, $leftmargin,
482 $cols, $rows, $colgap, $rowgap,
487 sub GetAllLabelTemplates {
488 my $dbh = C4::Context->dbh;
490 # get the actual items to be printed.
492 my $query = " Select * from labels_templates ";
493 my $sth = $dbh->prepare($query);
496 while ( my $data = $sth->fetchrow_hashref ) {
497 push( @resultsloop, $data );
501 #warn Dumper @resultsloop;
509 $barcodetype, $title, $subtitle, $isbn, $issn,
510 $itemtype, $bcn, $dcn, $classif,
511 $subclass, $itemcallnumber, $author, $tmpl_id,
512 $printingtype, $guidebox, $startlabel, $layoutname
515 my $dbh = C4::Context->dbh;
516 my $query2 = "update labels_conf set active = NULL";
517 my $sth2 = $dbh->prepare($query2);
519 $query2 = "INSERT INTO labels_conf
520 ( barcodetype, title, subtitle, isbn,issn, itemtype, barcode,
521 dewey, class, subclass, itemcallnumber, author, printingtype,
522 guidebox, startlabel, layoutname, active )
523 values ( ?, ?, ?, ?, ?, ?, ?, ?,?, ?, ?, ?, ?, ?,?,?, 1 )";
524 $sth2 = $dbh->prepare($query2);
526 $barcodetype, $title, $subtitle, $isbn, $issn,
528 $itemtype, $bcn, $dcn, $classif,
529 $subclass, $itemcallnumber, $author, $printingtype,
530 $guidebox, $startlabel, $layoutname
534 SetActiveTemplate($tmpl_id);
541 $barcodetype, $title, $subtitle, $isbn, $issn,
542 $itemtype, $bcn, $dcn, $classif,
543 $subclass, $itemcallnumber, $author, $tmpl_id,
544 $printingtype, $guidebox, $startlabel, $layoutname,
550 my $dbh = C4::Context->dbh;
551 my $query2 = "update labels_conf set
552 barcodetype=?, title=?, subtitle=?, isbn=?,issn=?,
553 itemtype=?, barcode=?, dewey=?, class=?,
554 subclass=?, itemcallnumber=?, author=?, printingtype=?,
555 guidebox=?, startlabel=?, layoutname=? where id = ?";
556 my $sth2 = $dbh->prepare($query2);
558 $barcodetype, $title, $subtitle, $isbn, $issn,
559 $itemtype, $bcn, $dcn, $classif,
560 $subclass, $itemcallnumber, $author, $printingtype,
561 $guidebox, $startlabel, $layoutname, $layout_id
568 =item GetAllPrinterProfiles;
570 @profiles = GetAllPrinterProfiles()
572 Returns an array of references-to-hash, whos keys are .....
576 sub GetAllPrinterProfiles {
578 my $dbh = C4::Context->dbh;
580 my $query = "SELECT * FROM printers_profile AS pp INNER JOIN labels_templates AS lt ON pp.tmpl_id = lt.tmpl_id; ";
581 my $sth = $dbh->prepare($query);
584 while ( my $data = $sth->fetchrow_hashref ) {
585 push( @resultsloop, $data );
592 =item GetSinglePrinterProfile;
594 $profile = GetSinglePrinterProfile()
596 Returns a hashref whos keys are...
600 sub GetSinglePrinterProfile {
602 my $dbh = C4::Context->dbh;
603 my $query = " SELECT * FROM printers_profile WHERE prof_id = ?; ";
604 my $sth = $dbh->prepare($query);
605 $sth->execute($prof_id);
606 my $template = $sth->fetchrow_hashref;
613 SaveProfile('parameters')
615 When passed a set of parameters, this function updates the given profile with the new parameters.
621 $prof_id, $offset_horz, $offset_vert, $creep_horz, $creep_vert, $units
623 my $dbh = C4::Context->dbh;
625 " UPDATE printers_profile
626 SET offset_horz=?, offset_vert=?, creep_horz=?, creep_vert=?, unit=?
628 my $sth = $dbh->prepare($query);
630 $offset_horz, $offset_vert, $creep_horz, $creep_vert, $units, $prof_id
637 CreateProfile('parameters')
639 When passed a set of parameters, this function creates a new profile containing those parameters
640 and returns any errors.
646 $prof_id, $printername, $paper_bin, $tmpl_id, $offset_horz,
647 $offset_vert, $creep_horz, $creep_vert, $units
649 my $dbh = C4::Context->dbh;
651 " INSERT INTO printers_profile (prof_id, printername, paper_bin, tmpl_id,
652 offset_horz, offset_vert, creep_horz, creep_vert, unit)
653 VALUES(?,?,?,?,?,?,?,?,?) ";
654 my $sth = $dbh->prepare($query);
656 $prof_id, $printername, $paper_bin, $tmpl_id, $offset_horz,
657 $offset_vert, $creep_horz, $creep_vert, $units
659 my $error = $sth->errstr;
666 DeleteProfile(prof_id)
668 When passed a profile id, this function deletes that profile from the database and returns any errors.
674 my $dbh = C4::Context->dbh;
675 my $query = " DELETE FROM printers_profile WHERE prof_id = ?";
676 my $sth = $dbh->prepare($query);
677 $sth->execute($prof_id);
678 my $error = $sth->errstr;
683 =item GetAssociatedProfile;
685 $assoc_prof = GetAssociatedProfile(tmpl_id)
687 When passed a template id, this function returns the parameters from the currently associated printer profile
688 in a hashref where key=fieldname and value=fieldvalue.
692 sub GetAssociatedProfile {
694 my $dbh = C4::Context->dbh;
695 # First we find out the prof_id for the associated profile...
696 my $query = "SELECT * FROM labels_profile WHERE tmpl_id = ?";
697 my $sth = $dbh->prepare($query);
698 $sth->execute($tmpl_id);
699 my $assoc_prof = $sth->fetchrow_hashref;
701 # Then we retrieve that profile and return it to the caller...
702 $assoc_prof = GetSinglePrinterProfile($assoc_prof->{'prof_id'});
706 =item SetAssociatedProfile;
708 SetAssociatedProfile($prof_id, $tmpl_id)
710 When passed both a profile id and template id, this function establishes an association between the two. No more
711 than one profile may be associated with any given template at the same time.
715 sub SetAssociatedProfile {
717 my ($prof_id, $tmpl_id) = @_;
719 my $dbh = C4::Context->dbh;
720 my $query = "INSERT INTO labels_profile (prof_id, tmpl_id) VALUES (?,?) ON DUPLICATE KEY UPDATE prof_id = ?";
721 my $sth = $dbh->prepare($query);
722 $sth->execute($prof_id, $tmpl_id, $prof_id);
726 =item get_label_items;
728 $options = get_label_items()
730 Returns an array of references-to-hash, whos keys are the field from the biblio, biblioitems, items and labels tables in the Koha database.
735 sub get_label_items {
737 my $dbh = C4::Context->dbh;
739 my @resultsloop = ();
745 my $query3 = "Select * from labels where batch_id = ? order by labelid ";
746 $sth = $dbh->prepare($query3);
747 $sth->execute($batch_id);
752 my $query3 = "Select * from labels";
753 $sth = $dbh->prepare($query3);
756 my $cnt = $sth->rows;
758 while ( my $data = $sth->fetchrow_hashref ) {
760 # lets get some summary info from each item
762 select i.*, bi.*, b.* from items i,biblioitems bi,biblio b
763 where itemnumber=? and i.biblioitemnumber=bi.biblioitemnumber and
764 bi.biblionumber=b.biblionumber";
766 my $sth1 = $dbh->prepare($query1);
767 $sth1->execute( $data->{'itemnumber'} );
769 my $data1 = $sth1->fetchrow_hashref();
770 $data1->{'labelno'} = $i1;
771 $data1->{'labelid'} = $data->{'labelid'};
772 $data1->{'batch_id'} = $batch_id;
773 $data1->{'summary'} =
774 "$data1->{'barcode'}, $data1->{'title'}, $data1->{'isbn'}";
776 push( @resultsloop, $data1 );
788 barcode title subtitle
789 dewey isbn issn author class
790 itemtype subclass itemcallnumber
796 sub deduplicate_batch {
797 my $batch_id = shift or return undef;
801 count(labelid) as count
804 GROUP BY itemnumber,batch_id
808 my $sth = C4::Context->dbh->prepare($query);
809 $sth->execute($batch_id);
810 $sth->rows or return undef;
817 ORDER BY timestamp ASC
820 while (my $data = $sth->fetchrow_hashref()) {
821 my $itemnumber = $data->{itemnumber} or next;
822 my $limit = $data->{count} - 1 or next;
823 my $sth2 = C4::Context->dbh->prepare("$del_query LIMIT $limit");
824 # die sprintf "$del_query LIMIT %s\n (%s, %s)", $limit, $batch_id, $itemnumber;
825 # $sth2->execute($batch_id, C4::Context->dbh->quote($data->{itemnumber}), $data->{count} - 1)
826 $sth2->execute($batch_id, $itemnumber) and
827 $killed += ($data->{count} - 1);
834 my ( $y_pos, $label_height, $fontsize, $x_pos, $left_text_margin,
835 $text_wrap_cols, $item, $conf_data )
837 # hack to fix column name mismatch betwen labels_conf.class, and bibitems.classification
838 $$item->{'class'} = $$item->{'classification'};
840 $Text::Wrap::columns = $text_wrap_cols;
841 $Text::Wrap::separator = "\n";
846 my $top_text_margin = ( $fontsize + 3 );
847 my $line_spacer = ($fontsize); # number of pixels between text rows.
849 # add your printable fields manually in here
851 my $layout_id = $$conf_data->{'id'};
853 # my @fields = GetItemFields();
855 my $str_fields = get_text_fields($layout_id, 'codes' );
856 my @fields = split(/ /, $str_fields);
857 #warn Dumper(@fields);
860 my $vPos = ( $y_pos + ( $label_height - $top_text_margin ) );
861 my $hPos = ( $x_pos + $left_text_margin );
863 # warn Dumper $conf_data;
866 foreach my $field (@fields) {
869 # $$item->{"$field"} = $field . ": " . $$item->{"$field"};
871 # if the display option for this field is selected in the DB,
872 # and the item record has some values for this field, display it.
873 if ( $$conf_data->{"$field"} && $$item->{"$field"} ) {
875 # warn "CONF_TYPE = $field";
878 $str = $$item->{"$field"};
879 # strip out naughty existing nl/cr's
883 # chop the string up into _upto_ 12 chunks
884 # and seperate the chunks with newlines
886 $str = wrap( "", "", "$str" );
887 $str = wrap( "", "", "$str" );
889 # split the chunks between newline's, into an array
890 my @strings = split /\n/, $str;
892 # then loop for each string line
893 foreach my $str (@strings) {
895 #warn "HPOS , VPOS $hPos, $vPos ";
896 # set the font size A
898 # prText( $hPos, $vPos, $str );
899 PrintText( $hPos, $vPos, $fontsize, $str );
900 $vPos = $vPos - $line_spacer;
902 } # if field is } #foreach feild
907 my ( $hPos, $vPos, $fontsize, $text ) = @_;
908 my $str = "BT /Ft1 $fontsize Tf $hPos $vPos Td ($text) Tj ET";
916 my $str = "BT/F13 30 Tf288 720 Td( AAAAAAAAAA ) TjET";
922 # x and y are from the top-left :)
923 my ( $x_pos, $y_pos, $height, $width, $barcode, $barcodetype ) = @_;
924 my $num_of_bars = length($barcode);
925 my $bar_width = $width * .8; # %80 of length of label width
928 my $guard_length = 10;
931 if ( $barcodetype eq 'CODE39' ) {
932 $bar_length = '17.5';
934 ( $bar_length * $num_of_bars ) + ( $guard_length * 2 );
935 $xsize_ratio = ( $bar_width / $tot_bar_length );
937 PDF::Reuse::Barcode::Code39(
938 x => ( $x_pos + ( $width / 10 ) ),
939 y => ( $y_pos + ( $height / 10 ) ),
940 value => "*$barcode*",
941 ySize => ( .02 * $height ),
942 xSize => $xsize_ratio,
947 warn "$barcodetype, $barcode FAILED:$@";
951 elsif ( $barcodetype eq 'CODE39MOD' ) {
953 # get modulo43 checksum
954 my $c39 = CheckDigits('code_39');
955 $barcode = $c39->complete($barcode);
959 ( $bar_length * $num_of_bars ) + ( $guard_length * 2 );
960 $xsize_ratio = ( $bar_width / $tot_bar_length );
962 PDF::Reuse::Barcode::Code39(
963 x => ( $x_pos + ( $width / 10 ) ),
964 y => ( $y_pos + ( $height / 10 ) ),
965 value => "*$barcode*",
966 ySize => ( .02 * $height ),
967 xSize => $xsize_ratio,
973 warn "$barcodetype, $barcode FAILED:$@";
976 elsif ( $barcodetype eq 'CODE39MOD10' ) {
978 # get modulo43 checksum
979 my $c39_10 = CheckDigits('visa');
980 $barcode = $c39_10->complete($barcode);
984 ( $bar_length * $num_of_bars ) + ( $guard_length * 2 );
985 $xsize_ratio = ( $bar_width / $tot_bar_length );
987 PDF::Reuse::Barcode::Code39(
988 x => ( $x_pos + ( $width / 10 ) ),
989 y => ( $y_pos + ( $height / 10 ) ),
990 value => "*$barcode*",
991 ySize => ( .02 * $height ),
992 xSize => $xsize_ratio,
999 warn "$barcodetype, $barcode FAILED:$@";
1004 elsif ( $barcodetype eq 'COOP2OF5' ) {
1005 $bar_length = '9.43333333333333';
1007 ( $bar_length * $num_of_bars ) + ( $guard_length * 2 );
1008 $xsize_ratio = ( $bar_width / $tot_bar_length ) * .9;
1010 PDF::Reuse::Barcode::COOP2of5(
1011 x => ( $x_pos + ( $width / 10 ) ),
1012 y => ( $y_pos + ( $height / 10 ) ),
1014 ySize => ( .02 * $height ),
1015 xSize => $xsize_ratio,
1019 warn "$barcodetype, $barcode FAILED:$@";
1023 elsif ( $barcodetype eq 'INDUSTRIAL2OF5' ) {
1024 $bar_length = '13.1333333333333';
1026 ( $bar_length * $num_of_bars ) + ( $guard_length * 2 );
1027 $xsize_ratio = ( $bar_width / $tot_bar_length ) * .9;
1029 PDF::Reuse::Barcode::Industrial2of5(
1030 x => ( $x_pos + ( $width / 10 ) ),
1031 y => ( $y_pos + ( $height / 10 ) ),
1033 ySize => ( .02 * $height ),
1034 xSize => $xsize_ratio,
1038 warn "$barcodetype, $barcode FAILED:$@";
1042 my $moo2 = $tot_bar_length * $xsize_ratio;
1044 warn "$x_pos, $y_pos, $barcode, $barcodetype" if $DEBUG;
1045 warn "BAR_WDTH = $bar_width, TOT.BAR.LGHT=$tot_bar_length R*TOT.BAR =$moo2" if $DEBUG;
1048 =item build_circ_barcode;
1050 build_circ_barcode( $x_pos, $y_pos, $barcode,
1051 $barcodetype, \$item);
1053 $item is the result of a previous call to get_label_items();
1058 sub build_circ_barcode {
1059 my ( $x_pos_circ, $y_pos, $value, $barcodetype, $item ) = @_;
1061 #warn Dumper \$item;
1063 #warn "value = $value\n";
1067 if ( $barcodetype eq 'EAN13' ) {
1069 #testing EAN13 barcodes hack
1070 $value = $value . '000000000';
1072 $value = substr( $value, 0, 12 );
1076 PDF::Reuse::Barcode::EAN13(
1077 x => ( $x_pos_circ + 27 ),
1078 y => ( $y_pos + 15 ),
1086 # added for xpdf compat. doesnt use type3 fonts., but increases filesize from 20k to 200k
1087 # i think its embedding extra fonts in the pdf file.
1088 # mode => 'graphic',
1092 $item->{'barcodeerror'} = 1;
1094 #warn "EAN13BARCODE FAILED:$@";
1100 elsif ( $barcodetype eq 'Code39' ) {
1103 PDF::Reuse::Barcode::Code39(
1104 x => ( $x_pos_circ + 9 ),
1105 y => ( $y_pos + 15 ),
1115 $item->{'barcodeerror'} = 1;
1117 #warn "CODE39BARCODE $value FAILED:$@";
1124 elsif ( $barcodetype eq 'Matrix2of5' ) {
1126 #warn "MATRIX ELSE:";
1128 #testing MATRIX25 barcodes hack
1129 # $value = $value.'000000000';
1132 # $value = substr( $value, 0, 12 );
1136 PDF::Reuse::Barcode::Matrix2of5(
1137 x => ( $x_pos_circ + 27 ),
1138 y => ( $y_pos + 15 ),
1148 $item->{'barcodeerror'} = 1;
1150 #warn "BARCODE FAILED:$@";
1157 elsif ( $barcodetype eq 'EAN8' ) {
1159 #testing ean8 barcodes hack
1160 $value = $value . '000000000';
1162 $value = substr( $value, 0, 8 );
1166 #warn "EAN8 ELSEIF";
1168 PDF::Reuse::Barcode::EAN8(
1169 x => ( $x_pos_circ + 42 ),
1170 y => ( $y_pos + 15 ),
1180 $item->{'barcodeerror'} = 1;
1182 #warn "BARCODE FAILED:$@";
1189 elsif ( $barcodetype eq 'UPC-E' ) {
1191 PDF::Reuse::Barcode::UPCE(
1192 x => ( $x_pos_circ + 27 ),
1193 y => ( $y_pos + 15 ),
1203 $item->{'barcodeerror'} = 1;
1205 #warn "BARCODE FAILED:$@";
1211 elsif ( $barcodetype eq 'NW7' ) {
1213 PDF::Reuse::Barcode::NW7(
1214 x => ( $x_pos_circ + 27 ),
1215 y => ( $y_pos + 15 ),
1225 $item->{'barcodeerror'} = 1;
1227 #warn "BARCODE FAILED:$@";
1233 elsif ( $barcodetype eq 'ITF' ) {
1235 PDF::Reuse::Barcode::ITF(
1236 x => ( $x_pos_circ + 27 ),
1237 y => ( $y_pos + 15 ),
1247 $item->{'barcodeerror'} = 1;
1249 #warn "BARCODE FAILED:$@";
1255 elsif ( $barcodetype eq 'Industrial2of5' ) {
1257 PDF::Reuse::Barcode::Industrial2of5(
1258 x => ( $x_pos_circ + 27 ),
1259 y => ( $y_pos + 15 ),
1268 $item->{'barcodeerror'} = 1;
1270 #warn "BARCODE FAILED:$@";
1276 elsif ( $barcodetype eq 'IATA2of5' ) {
1278 PDF::Reuse::Barcode::IATA2of5(
1279 x => ( $x_pos_circ + 27 ),
1280 y => ( $y_pos + 15 ),
1289 $item->{'barcodeerror'} = 1;
1291 #warn "BARCODE FAILED:$@";
1298 elsif ( $barcodetype eq 'COOP2of5' ) {
1300 PDF::Reuse::Barcode::COOP2of5(
1301 x => ( $x_pos_circ + 27 ),
1302 y => ( $y_pos + 15 ),
1311 $item->{'barcodeerror'} = 1;
1313 #warn "BARCODE FAILED:$@";
1319 elsif ( $barcodetype eq 'UPC-A' ) {
1322 PDF::Reuse::Barcode::UPCA(
1323 x => ( $x_pos_circ + 27 ),
1324 y => ( $y_pos + 15 ),
1333 $item->{'barcodeerror'} = 1;
1335 #warn "BARCODE FAILED:$@";
1344 =item draw_boundaries
1346 sub draw_boundaries ($x_pos_spine, $x_pos_circ1, $x_pos_circ2,
1347 $y_pos, $spine_width, $label_height, $circ_width)
1349 This sub draws boundary lines where the label outlines are, to aid in printer testing, and debugging.
1354 sub draw_boundaries {
1357 $x_pos_spine, $x_pos_circ1, $x_pos_circ2, $y_pos,
1358 $spine_width, $label_height, $circ_width
1361 my $y_pos_initial = ( ( 792 - 36 ) - 90 );
1362 $y_pos = $y_pos_initial; # FIXME - why are we ignoring the y_pos parameter by redefining it?
1365 for ( $i = 1 ; $i <= 8 ; $i++ ) {
1367 &drawbox( $x_pos_spine, $y_pos, ($spine_width), ($label_height) );
1369 #warn "OLD BOXES x=$x_pos_spine, y=$y_pos, w=$spine_width, h=$label_height";
1370 &drawbox( $x_pos_circ1, $y_pos, ($circ_width), ($label_height) );
1371 &drawbox( $x_pos_circ2, $y_pos, ($circ_width), ($label_height) );
1373 $y_pos = ( $y_pos - $label_height );
1380 sub drawbox { $lower_left_x, $lower_left_y,
1381 $upper_right_x, $upper_right_y )
1383 this is a low level sub, that draws a pdf box, it is called by draw_boxes
1385 FYI: the $upper_right_x and $upper_right_y values are RELATIVE to $lower_left_x and $lower_left_y
1387 and $lower_left_x, $lower_left_y are ABSOLUTE, this caught me out!
1393 my ( $llx, $lly, $urx, $ury ) = @_;
1395 # warn "llx,y= $llx,$lly , urx,y=$urx,$ury \n";
1397 my $str = "q\n"; # save the graphic state
1398 $str .= "0.5 w\n"; # border color red
1399 $str .= "1.0 0.0 0.0 RG\n"; # border color red
1400 # $str .= "0.5 0.75 1.0 rg\n"; # fill color blue
1401 $str .= "1.0 1.0 1.0 rg\n"; # fill color white
1403 $str .= "$llx $lly $urx $ury re\n"; # a rectangle
1404 $str .= "B\n"; # fill (and a little more)
1405 $str .= "Q\n"; # save the graphic state
1411 END { } # module clean-up code here (global destructor)
1420 Mason James <mason@katipo.co.nz>