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
23 use vars
qw($VERSION @ISA @EXPORT);
27 use Algorithm::CheckDigits;
29 # use Smart::Comments;
35 C4::Labels - Functions for printing spine labels and barcodes in Koha
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
56 &get_batches &delete_batch
57 &add_batch &SetFontSize &printText
60 get_layout &save_layout &add_layout
61 &set_active_layout &by_order
63 &delete_layout &get_active_layout
68 =item get_label_options;
70 $options = get_label_options()
72 Return a pointer on a hash list containing info from labels_conf table in Koha DB.
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);
82 my $conf_data = $sth->fetchrow_hashref;
89 ## FIXME: this if/else could be compacted...
90 my $dbh = C4
::Context
->dbh;
92 my $query = " Select * from labels_conf";
93 my $sth = $dbh->prepare($query);
96 while ( my $data = $sth->fetchrow_hashref ) {
98 $data->{'fieldlist'} = get_text_fields
( $data->{'id'} );
99 push( @resultsloop, $data );
109 my ($layout_id) = @_;
110 my $dbh = C4
::Context
->dbh;
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;
121 sub get_active_layout
{
122 my ($layout_id) = @_;
123 my $dbh = C4
::Context
->dbh;
125 # get the actual items to be printed.
126 my $query = " Select * from labels_conf where active = 1";
127 my $sth = $dbh->prepare($query);
129 my $data = $sth->fetchrow_hashref;
135 my ($layout_id) = @_;
136 my $dbh = C4
::Context
->dbh;
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);
145 sub get_printingtypes
{
146 my ($layout_id) = @_;
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" } );
155 my $conf = get_layout
($layout_id);
156 my $active_printtype = $conf->{'printingtype'};
158 # lop thru layout, insert selected to hash
160 foreach my $printtype (@printtypes) {
161 if ( $printtype->{'code'} eq $active_printtype ) {
162 $printtype->{'active'} = 'MOO';
168 sub build_text_dropbox
{
171 # my @fields = get_text_fields();
172 # my $field_count = scalar @fields;
173 my $field_count = 10; # <----------- FIXME hard coded
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 );
185 # add a blank row too
190 sub get_text_fields
{
191 my ($layout_id, $sorttype) = @_;
193 my ( $a, $b, $c, $d, $e, $f, $g, $h, $i ,$j, $k );
195 my $sortorder = get_layout
($layout_id);
202 order
=> $sortorder->{'itemtype'}
207 order
=> $sortorder->{'dewey'}
209 $c = { code
=> 'issn', desc
=> "ISSN",
210 order
=> $sortorder->{'issn'} };
211 $d = { code
=> 'isbn', desc
=> "ISBN",
212 order
=> $sortorder->{'isbn'} };
215 desc
=> "Classification",
216 order
=> $sortorder->{'class'}
221 order
=> $sortorder->{'subclass'}
226 order
=> $sortorder->{'barcode'}
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'} };
234 my @text_fields = ( $a, $b, $c, $d, $e, $f, $g, $h, $i ,$j, $k );
237 foreach my $field (@text_fields) {
238 push( @new_fields, $field ) if $field->{'order'} > 0;
241 my @sorted_fields = sort by_order
@new_fields;
243 foreach my $field (@sorted_fields) {
244 $sorttype eq 'codes' ?
$active_fields .= "$field->{'code'} " :
245 $active_fields .= "$field->{'desc'} ";
247 return $active_fields;
252 $$a{order
} <=> $$b{order
};
257 my $dbh = C4
::Context
->dbh;
259 "select distinct batch_id from labels order by batch_id desc limit 1";
260 my $sth = $dbh->prepare($q);
262 my $data = $sth->fetchrow_hashref;
265 if ( !$data->{'batch_id'} ) {
269 $new_batch = ( $data->{'batch_id'} + 1 );
276 sub get_highest_batch
{
278 my $dbh = C4
::Context
->dbh;
280 "select distinct batch_id from labels order by batch_id desc limit 1";
281 my $sth = $dbh->prepare($q);
283 my $data = $sth->fetchrow_hashref;
286 if ( !$data->{'batch_id'} ) {
290 $new_batch = $data->{'batch_id'};
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);
303 while ( my $data = $sth->fetchrow_hashref ) {
304 push( @resultsloop, $data );
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' } );
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);
324 sub get_barcode_types
{
325 my ($layout_id) = @_;
326 my $layout = get_layout
($layout_id);
327 my $barcode = $layout->{'barcodetype'};
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' } );
335 foreach my $line (@array) {
336 if ( $line->{'code'} eq $barcode ) {
337 $line->{'active'} = 1;
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' );
355 sub GetTextWrapCols
{
356 my ( $fontsize, $label_width ) = @_;
358 my $left_text_margin = 3;
359 my ( $strtmp, $strwidth );
361 my $textlimit = $label_width - $left_text_margin;
363 while ( $strwidth < $textlimit ) {
364 $strwidth = prStrWidth
( $string, 'C', $fontsize );
365 $string = $string . '0';
367 # warn "strwidth $strwidth, $textlimit, $string";
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);
378 my $active_tmpl = $sth->fetchrow_hashref;
383 sub GetSingleLabelTemplate
{
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;
394 sub SetActiveTemplate
{
398 my $dbh = C4
::Context
->dbh;
399 my $query = " UPDATE labels_templates SET active = NULL";
400 my $sth = $dbh->prepare($query);
403 $query = "UPDATE labels_templates SET active = 1 WHERE tmpl_id = ?";
404 $sth = $dbh->prepare($query);
405 $sth->execute($tmpl_id);
409 sub set_active_layout
{
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);
417 $query = "UPDATE labels_conf SET active = 1 WHERE id = ?";
418 $sth = $dbh->prepare($query);
419 $sth->execute($layout_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);
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
439 my $dbh = C4
::Context
->dbh;
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=?,
447 my $sth = $dbh->prepare($query);
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
460 $tmpl_code, $tmpl_desc, $page_width, $page_height,
461 $label_width, $label_height, $topmargin, $leftmargin,
462 $cols, $rows, $colgap, $rowgap,
466 my $dbh = C4
::Context
->dbh;
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(?,?,?,?,?,?,?,?,?,?,?,?,?,?)";
473 my $sth = $dbh->prepare($query);
475 $tmpl_code, $tmpl_desc, $page_width, $page_height,
476 $label_width, $label_height, $topmargin, $leftmargin,
477 $cols, $rows, $colgap, $rowgap,
482 sub GetAllLabelTemplates
{
483 my $dbh = C4
::Context
->dbh;
485 # get the actual items to be printed.
487 my $query = " Select * from labels_templates ";
488 my $sth = $dbh->prepare($query);
491 while ( my $data = $sth->fetchrow_hashref ) {
492 push( @resultsloop, $data );
496 #warn Dumper @resultsloop;
504 $barcodetype, $title, $subtitle, $isbn, $issn,
505 $itemtype, $bcn, $dcn, $classif,
506 $subclass, $itemcallnumber, $author, $tmpl_id,
507 $printingtype, $guidebox, $startlabel, $layoutname
510 my $dbh = C4
::Context
->dbh;
511 my $query2 = "update labels_conf set active = NULL";
512 my $sth2 = $dbh->prepare($query2);
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);
521 $barcodetype, $title, $subtitle, $isbn, $issn,
523 $itemtype, $bcn, $dcn, $classif,
524 $subclass, $itemcallnumber, $author, $printingtype,
525 $guidebox, $startlabel, $layoutname
529 SetActiveTemplate
($tmpl_id);
536 $barcodetype, $title, $subtitle, $isbn, $issn,
537 $itemtype, $bcn, $dcn, $classif,
538 $subclass, $itemcallnumber, $author, $tmpl_id,
539 $printingtype, $guidebox, $startlabel, $layoutname,
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);
553 $barcodetype, $title, $subtitle, $isbn, $issn,
554 $itemtype, $bcn, $dcn, $classif,
555 $subclass, $itemcallnumber, $author, $printingtype,
556 $guidebox, $startlabel, $layoutname, $layout_id
563 =item get_label_items;
565 $options = get_label_items()
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.
572 sub get_label_items
{
574 my $dbh = C4
::Context
->dbh;
576 my @resultsloop = ();
582 my $query3 = "Select * from labels where batch_id = ? order by labelid ";
583 $sth = $dbh->prepare($query3);
584 $sth->execute($batch_id);
589 my $query3 = "Select * from labels";
590 $sth = $dbh->prepare($query3);
593 my $cnt = $sth->rows;
595 while ( my $data = $sth->fetchrow_hashref ) {
597 # lets get some summary info from each item
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";
603 my $sth1 = $dbh->prepare($query1);
604 $sth1->execute( $data->{'itemnumber'} );
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'}";
613 push( @resultsloop, $data1 );
625 barcode title subtitle
626 dewey isbn issn author
class
627 itemtype subclass itemcallnumber
633 sub deduplicate_batch
{
634 my $batch_id = shift or return undef;
638 count(labelid) as count
641 GROUP BY itemnumber,batch_id
645 my $sth = C4
::Context
->dbh->prepare($query);
646 $sth->execute($batch_id);
647 $sth->rows or return undef;
654 ORDER BY timestamp ASC
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);
671 my ( $y_pos, $label_height, $fontsize, $x_pos, $left_text_margin,
672 $text_wrap_cols, $item, $conf_data )
674 # hack to fix column name mismatch betwen labels_conf.class, and bibitems.classification
675 $$item->{'class'} = $$item->{'classification'};
677 $Text::Wrap
::columns
= $text_wrap_cols;
678 $Text::Wrap
::separator
= "\n";
683 my $top_text_margin = ( $fontsize + 3 );
684 my $line_spacer = ($fontsize); # number of pixels between text rows.
686 # add your printable fields manually in here
688 my $layout_id = $$conf_data->{'id'};
690 # my @fields = GetItemFields();
692 my $str_fields = get_text_fields
($layout_id, 'codes' );
693 my @fields = split(/ /, $str_fields);
696 my $vPos = ( $y_pos + ( $label_height - $top_text_margin ) );
697 my $hPos = ( $x_pos + $left_text_margin );
699 # warn Dumper $conf_data;
702 foreach my $field (@fields) {
705 # $$item->{"$field"} = $field . ": " . $$item->{"$field"};
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"} ) {
711 # warn "CONF_TYPE = $field";
714 $str = $$item->{"$field"};
715 # strip out naughty existing nl/cr's
719 # chop the string up into _upto_ 12 chunks
720 # and seperate the chunks with newlines
722 $str = wrap
( "", "", "$str" );
723 $str = wrap
( "", "", "$str" );
725 # split the chunks between newline's, into an array
726 my @strings = split /\n/, $str;
728 # then loop for each string line
729 foreach my $str (@strings) {
731 #warn "HPOS , VPOS $hPos, $vPos ";
732 # set the font size A
734 # prText( $hPos, $vPos, $str );
735 PrintText
( $hPos, $vPos, $fontsize, $str );
736 $vPos = $vPos - $line_spacer;
738 } # if field is } #foreach feild
743 my ( $hPos, $vPos, $fontsize, $text ) = @_;
744 my $str = "BT /Ft1 $fontsize Tf $hPos $vPos Td ($text) Tj ET";
752 my $str = "BT/F13 30 Tf288 720 Td( AAAAAAAAAA ) TjET";
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
764 my $guard_length = 10;
767 if ( $barcodetype eq 'CODE39' ) {
768 $bar_length = '17.5';
770 ( $bar_length * $num_of_bars ) + ( $guard_length * 2 );
771 $xsize_ratio = ( $bar_width / $tot_bar_length );
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,
783 warn "$barcodetype, $barcode FAILED:$@";
787 elsif ( $barcodetype eq 'CODE39MOD' ) {
789 # get modulo43 checksum
790 my $c39 = CheckDigits
('code_39');
791 $barcode = $c39->complete($barcode);
795 ( $bar_length * $num_of_bars ) + ( $guard_length * 2 );
796 $xsize_ratio = ( $bar_width / $tot_bar_length );
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,
809 warn "$barcodetype, $barcode FAILED:$@";
812 elsif ( $barcodetype eq 'CODE39MOD10' ) {
814 # get modulo43 checksum
815 my $c39_10 = CheckDigits
('visa');
816 $barcode = $c39_10->complete($barcode);
820 ( $bar_length * $num_of_bars ) + ( $guard_length * 2 );
821 $xsize_ratio = ( $bar_width / $tot_bar_length );
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,
835 warn "$barcodetype, $barcode FAILED:$@";
840 elsif ( $barcodetype eq 'COOP2OF5' ) {
841 $bar_length = '9.43333333333333';
843 ( $bar_length * $num_of_bars ) + ( $guard_length * 2 );
844 $xsize_ratio = ( $bar_width / $tot_bar_length ) * .9;
846 PDF
::Reuse
::Barcode
::COOP2of5
(
847 x
=> ( $x_pos + ( $width / 10 ) ),
848 y
=> ( $y_pos + ( $height / 10 ) ),
850 ySize
=> ( .02 * $height ),
851 xSize
=> $xsize_ratio,
855 warn "$barcodetype, $barcode FAILED:$@";
859 elsif ( $barcodetype eq 'INDUSTRIAL2OF5' ) {
860 $bar_length = '13.1333333333333';
862 ( $bar_length * $num_of_bars ) + ( $guard_length * 2 );
863 $xsize_ratio = ( $bar_width / $tot_bar_length ) * .9;
865 PDF
::Reuse
::Barcode
::Industrial2of5
(
866 x
=> ( $x_pos + ( $width / 10 ) ),
867 y
=> ( $y_pos + ( $height / 10 ) ),
869 ySize
=> ( .02 * $height ),
870 xSize
=> $xsize_ratio,
874 warn "$barcodetype, $barcode FAILED:$@";
878 my $moo2 = $tot_bar_length * $xsize_ratio;
880 warn " $x_pos, $y_pos, $barcode, $barcodetype\n";
882 "BAR_WDTH = $bar_width, TOT.BAR.LGHT=$tot_bar_length R*TOT.BAR =$moo2 \n";
885 =item build_circ_barcode;
887 build_circ_barcode( $x_pos, $y_pos, $barcode,
888 $barcodetype, \$item);
890 $item is the result of a previous call to get_label_items();
895 sub build_circ_barcode
{
896 my ( $x_pos_circ, $y_pos, $value, $barcodetype, $item ) = @_;
900 #warn "value = $value\n";
904 if ( $barcodetype eq 'EAN13' ) {
906 #testing EAN13 barcodes hack
907 $value = $value . '000000000';
909 $value = substr( $value, 0, 12 );
913 PDF
::Reuse
::Barcode
::EAN13
(
914 x
=> ( $x_pos_circ + 27 ),
915 y
=> ( $y_pos + 15 ),
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.
929 $item->{'barcodeerror'} = 1;
931 #warn "EAN13BARCODE FAILED:$@";
937 elsif ( $barcodetype eq 'Code39' ) {
940 PDF
::Reuse
::Barcode
::Code39
(
941 x
=> ( $x_pos_circ + 9 ),
942 y
=> ( $y_pos + 15 ),
952 $item->{'barcodeerror'} = 1;
954 #warn "CODE39BARCODE $value FAILED:$@";
961 elsif ( $barcodetype eq 'Matrix2of5' ) {
963 #warn "MATRIX ELSE:";
965 #testing MATRIX25 barcodes hack
966 # $value = $value.'000000000';
969 # $value = substr( $value, 0, 12 );
973 PDF
::Reuse
::Barcode
::Matrix2of5
(
974 x
=> ( $x_pos_circ + 27 ),
975 y
=> ( $y_pos + 15 ),
985 $item->{'barcodeerror'} = 1;
987 #warn "BARCODE FAILED:$@";
994 elsif ( $barcodetype eq 'EAN8' ) {
996 #testing ean8 barcodes hack
997 $value = $value . '000000000';
999 $value = substr( $value, 0, 8 );
1003 #warn "EAN8 ELSEIF";
1005 PDF
::Reuse
::Barcode
::EAN8
(
1006 x
=> ( $x_pos_circ + 42 ),
1007 y
=> ( $y_pos + 15 ),
1017 $item->{'barcodeerror'} = 1;
1019 #warn "BARCODE FAILED:$@";
1026 elsif ( $barcodetype eq 'UPC-E' ) {
1028 PDF
::Reuse
::Barcode
::UPCE
(
1029 x
=> ( $x_pos_circ + 27 ),
1030 y
=> ( $y_pos + 15 ),
1040 $item->{'barcodeerror'} = 1;
1042 #warn "BARCODE FAILED:$@";
1048 elsif ( $barcodetype eq 'NW7' ) {
1050 PDF
::Reuse
::Barcode
::NW7
(
1051 x
=> ( $x_pos_circ + 27 ),
1052 y
=> ( $y_pos + 15 ),
1062 $item->{'barcodeerror'} = 1;
1064 #warn "BARCODE FAILED:$@";
1070 elsif ( $barcodetype eq 'ITF' ) {
1072 PDF
::Reuse
::Barcode
::ITF
(
1073 x
=> ( $x_pos_circ + 27 ),
1074 y
=> ( $y_pos + 15 ),
1084 $item->{'barcodeerror'} = 1;
1086 #warn "BARCODE FAILED:$@";
1092 elsif ( $barcodetype eq 'Industrial2of5' ) {
1094 PDF
::Reuse
::Barcode
::Industrial2of5
(
1095 x
=> ( $x_pos_circ + 27 ),
1096 y
=> ( $y_pos + 15 ),
1105 $item->{'barcodeerror'} = 1;
1107 #warn "BARCODE FAILED:$@";
1113 elsif ( $barcodetype eq 'IATA2of5' ) {
1115 PDF
::Reuse
::Barcode
::IATA2of5
(
1116 x
=> ( $x_pos_circ + 27 ),
1117 y
=> ( $y_pos + 15 ),
1126 $item->{'barcodeerror'} = 1;
1128 #warn "BARCODE FAILED:$@";
1135 elsif ( $barcodetype eq 'COOP2of5' ) {
1137 PDF
::Reuse
::Barcode
::COOP2of5
(
1138 x
=> ( $x_pos_circ + 27 ),
1139 y
=> ( $y_pos + 15 ),
1148 $item->{'barcodeerror'} = 1;
1150 #warn "BARCODE FAILED:$@";
1156 elsif ( $barcodetype eq 'UPC-A' ) {
1159 PDF
::Reuse
::Barcode
::UPCA
(
1160 x
=> ( $x_pos_circ + 27 ),
1161 y
=> ( $y_pos + 15 ),
1170 $item->{'barcodeerror'} = 1;
1172 #warn "BARCODE FAILED:$@";
1181 =item draw_boundaries
1183 sub draw_boundaries ($x_pos_spine, $x_pos_circ1, $x_pos_circ2,
1184 $y_pos, $spine_width, $label_height, $circ_width)
1186 This sub draws boundary lines where the label outlines are, to aid in printer testing, and debugging.
1191 sub draw_boundaries
{
1194 $x_pos_spine, $x_pos_circ1, $x_pos_circ2, $y_pos,
1195 $spine_width, $label_height, $circ_width
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?
1202 for ( $i = 1 ; $i <= 8 ; $i++ ) {
1204 &drawbox
( $x_pos_spine, $y_pos, ($spine_width), ($label_height) );
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) );
1210 $y_pos = ( $y_pos - $label_height );
1217 sub drawbox { $lower_left_x, $lower_left_y,
1218 $upper_right_x, $upper_right_y )
1220 this is a low level sub, that draws a pdf box, it is called by draw_boxes
1222 FYI: the $upper_right_x and $upper_right_y values are RELATIVE to $lower_left_x and $lower_left_y
1224 and $lower_left_x, $lower_left_y are ABSOLUTE, this caught me out!
1230 my ( $llx, $lly, $urx, $ury ) = @_;
1232 # warn "llx,y= $llx,$lly , urx,y=$urx,$ury \n";
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
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
1248 END { } # module clean-up code here (global destructor)
1257 Mason James <mason@katipo.co.nz>