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;
29 # use Smart::Comments;
36 &get_label_options &GetLabelItems
37 &build_circ_barcode &draw_boundaries
38 &drawbox &GetActiveLabelTemplate
39 &GetAllLabelTemplates &DeleteTemplate
40 &GetSingleLabelTemplate &SaveTemplate
41 &CreateTemplate &SetActiveTemplate
42 &SaveConf &DrawSpineText &GetTextWrapCols
43 &GetUnitsValue &DrawBarcode &DrawPatronCardText
44 &get_printingtypes &GetPatronCardItems
47 &get_batches &delete_batch
51 get_layout &save_layout &add_layout
52 &set_active_layout &by_order
54 &delete_layout &get_active_layout
57 &GetAllPrinterProfiles &GetSinglePrinterProfile
58 &SaveProfile &CreateProfile &DeleteProfile
59 &GetAssociatedProfile &SetAssociatedProfile
67 C4::Labels - Functions for printing spine labels and barcodes in Koha
73 =item get_label_options;
75 $options = get_label_options()
77 Return a pointer on a hash list containing info from labels_conf table in Koha DB.
82 sub get_label_options {
83 my $dbh = C4::Context->dbh;
84 my $query2 = " SELECT * FROM labels_conf where active = 1";
85 my $sth = $dbh->prepare($query2);
87 my $conf_data = $sth->fetchrow_hashref;
94 ## FIXME: this if/else could be compacted...
95 my $dbh = C4::Context->dbh;
97 my $query = " Select * from labels_conf";
98 my $sth = $dbh->prepare($query);
101 while ( my $data = $sth->fetchrow_hashref ) {
103 $data->{'fieldlist'} = get_text_fields( $data->{'id'} );
104 push( @resultsloop, $data );
114 my ($layout_id) = @_;
115 my $dbh = C4::Context->dbh;
117 # get the actual items to be printed.
118 my $query = " Select * from labels_conf where id = ?";
119 my $sth = $dbh->prepare($query);
120 $sth->execute($layout_id);
121 my $data = $sth->fetchrow_hashref;
126 sub get_active_layout {
127 my ($layout_id) = @_;
128 my $dbh = C4::Context->dbh;
130 # get the actual items to be printed.
131 my $query = " Select * from labels_conf where active = 1";
132 my $sth = $dbh->prepare($query);
134 my $data = $sth->fetchrow_hashref;
140 my ($layout_id) = @_;
141 my $dbh = C4::Context->dbh;
143 # get the actual items to be printed.
144 my $query = "delete from labels_conf where id = ?";
145 my $sth = $dbh->prepare($query);
146 $sth->execute($layout_id);
150 sub get_printingtypes {
151 my ($layout_id) = @_;
154 push( @printtypes, { code => 'BAR', desc => "barcode" } );
155 push( @printtypes, { code => 'BIB', desc => "biblio" } );
156 push( @printtypes, { code => 'BARBIB', desc => "barcode / biblio" } );
157 push( @printtypes, { code => 'BIBBAR', desc => "biblio / barcode" } );
158 push( @printtypes, { code => 'ALT', desc => "alternating labels" } );
160 my $conf = get_layout($layout_id);
161 my $active_printtype = $conf->{'printingtype'};
163 # lop thru layout, insert selected to hash
165 foreach my $printtype (@printtypes) {
166 if ( $printtype->{'code'} eq $active_printtype ) {
167 $printtype->{'active'} = 'MOO';
173 sub build_text_dropbox {
176 # my @fields = get_text_fields();
177 # my $field_count = scalar @fields;
178 my $field_count = 10; # <----------- FIXME hard coded
182 ? push( @lines, { num => '', selected => '1' } )
183 : push( @lines, { num => '' } );
184 for ( my $i = 1 ; $i <= $field_count ; $i++ ) {
185 my $line = { num => "$i" };
186 $line->{'selected'} = 1 if $i eq $order;
187 push( @lines, $line );
190 # add a blank row too
195 sub get_text_fields {
196 my ($layout_id, $sorttype) = @_;
198 my ( $a, $b, $c, $d, $e, $f, $g, $h, $i ,$j, $k );
200 my $sortorder = get_layout($layout_id);
207 order => $sortorder->{'itemtype'}
212 order => $sortorder->{'dewey'}
214 $c = { code => 'issn', desc => "ISSN",
215 order => $sortorder->{'issn'} };
216 $d = { code => 'isbn', desc => "ISBN",
217 order => $sortorder->{'isbn'} };
220 desc => "Classification",
221 order => $sortorder->{'class'}
226 order => $sortorder->{'subclass'}
231 order => $sortorder->{'barcode'}
234 { code => 'author', desc => "Author", order => $sortorder->{'author'} };
235 $i = { code => 'title', desc => "Title", order => $sortorder->{'title'} };
236 $j = { code => 'itemcallnumber', desc => "Call Number", order => $sortorder->{'itemcallnumber'} };
237 $k = { code => 'subtitle', desc => "Subtitle", order => $sortorder->{'subtitle'} };
239 my @text_fields = ( $a, $b, $c, $d, $e, $f, $g, $h, $i ,$j, $k );
242 foreach my $field (@text_fields) {
243 push( @new_fields, $field ) if $field->{'order'} > 0;
246 my @sorted_fields = sort by_order @new_fields;
248 foreach my $field (@sorted_fields) {
249 $sorttype eq 'codes' ? $active_fields .= "$field->{'code'} " :
250 $active_fields .= "$field->{'desc'} ";
252 return $active_fields;
257 $$a{order} <=> $$b{order};
261 my ( $batch_type ) = @_;
263 my $dbh = C4::Context->dbh;
265 "SELECT DISTINCT batch_id FROM $batch_type ORDER BY batch_id desc LIMIT 1";
266 my $sth = $dbh->prepare($q);
268 my $data = $sth->fetchrow_hashref;
271 if ( !$data->{'batch_id'} ) {
275 $new_batch = ( $data->{'batch_id'} + 1 );
281 #FIXME: Needs to be ported to receive $batch_type
282 sub get_highest_batch {
284 my $dbh = C4::Context->dbh;
286 "select distinct batch_id from labels order by batch_id desc limit 1";
287 my $sth = $dbh->prepare($q);
289 my $data = $sth->fetchrow_hashref;
292 if ( !$data->{'batch_id'} ) {
296 $new_batch = $data->{'batch_id'};
303 #FIXME: Needs to be ported to receive $batch_type
305 my ($batch_type) = @_;
306 my $dbh = C4::Context->dbh;
307 my $q = "select batch_id, count(*) as num from $batch_type group by batch_id";
308 my $sth = $dbh->prepare($q);
311 while ( my $data = $sth->fetchrow_hashref ) {
312 push( @resultsloop, $data );
316 # Not sure why we are doing this rather than simply telling the user that no batches are currently defined.
317 # So I'm commenting this out and modifying label-manager.tmpl to properly inform the user as stated. -fbcit
318 # adding a dummy batch=1 value , if none exists in the db
319 # if ( !scalar(@resultsloop) ) {
320 # push( @resultsloop, { batch_id => '1' , num => '0' } );
326 my ($batch_id, $batch_type) = @_;
327 warn "Deleteing batch of type $batch_type";
328 my $dbh = C4::Context->dbh;
329 my $q = "DELETE FROM $batch_type WHERE batch_id = ?";
330 my $sth = $dbh->prepare($q);
331 $sth->execute($batch_id);
335 sub get_barcode_types {
336 my ($layout_id) = @_;
337 my $layout = get_layout($layout_id);
338 my $barcode = $layout->{'barcodetype'};
341 push( @array, { code => 'CODE39', desc => 'Code 39' } );
342 push( @array, { code => 'CODE39MOD', desc => 'Code39 + Modulo43' } );
343 push( @array, { code => 'CODE39MOD10', desc => 'Code39 + Modulo10' } );
344 push( @array, { code => 'ITF', desc => 'Interleaved 2 of 5' } );
346 foreach my $line (@array) {
347 if ( $line->{'code'} eq $barcode ) {
348 $line->{'active'} = 1;
359 $unitvalue = '1' if ( $units eq 'POINT' );
360 $unitvalue = '2.83464567' if ( $units eq 'MM' );
361 $unitvalue = '28.3464567' if ( $units eq 'CM' );
362 $unitvalue = 72 if ( $units eq 'INCH' );
366 sub GetTextWrapCols {
367 my ( $font, $fontsize, $label_width, $left_text_margin ) = @_;
371 # my $textlimit = $label_width - ($left_text_margin);
372 my $textlimit = $label_width - ( 2* $left_text_margin);
374 while ( $strwidth < $textlimit ) {
375 $strwidth = prStrWidth( $string, $font, $fontsize );
376 $string = $string . '0';
377 #warn "strwidth:$strwidth, textlimit:$textlimit, count:$count string:$string";
383 sub GetActiveLabelTemplate {
384 my $dbh = C4::Context->dbh;
385 my $query = " SELECT * FROM labels_templates where active = 1 limit 1";
386 my $sth = $dbh->prepare($query);
388 my $active_tmpl = $sth->fetchrow_hashref;
393 sub GetSingleLabelTemplate {
395 my $dbh = C4::Context->dbh;
396 my $query = " SELECT * FROM labels_templates where tmpl_id = ?";
397 my $sth = $dbh->prepare($query);
398 $sth->execute($tmpl_id);
399 my $template = $sth->fetchrow_hashref;
404 sub SetActiveTemplate {
408 my $dbh = C4::Context->dbh;
409 my $query = " UPDATE labels_templates SET active = NULL";
410 my $sth = $dbh->prepare($query);
413 $query = "UPDATE labels_templates SET active = 1 WHERE tmpl_id = ?";
414 $sth = $dbh->prepare($query);
415 $sth->execute($tmpl_id);
419 sub set_active_layout {
421 my ($layout_id) = @_;
422 my $dbh = C4::Context->dbh;
423 my $query = " UPDATE labels_conf SET active = NULL";
424 my $sth = $dbh->prepare($query);
427 $query = "UPDATE labels_conf SET active = 1 WHERE id = ?";
428 $sth = $dbh->prepare($query);
429 $sth->execute($layout_id);
435 my $dbh = C4::Context->dbh;
436 my $query = " DELETE FROM labels_templates where tmpl_id = ?";
437 my $sth = $dbh->prepare($query);
438 $sth->execute($tmpl_id);
444 $tmpl_id, $tmpl_code, $tmpl_desc, $page_width,
445 $page_height, $label_width, $label_height, $topmargin,
446 $leftmargin, $cols, $rows, $colgap,
447 $rowgap, $font, $fontsize, $units
449 warn "Passed \$font:$font";
450 my $dbh = C4::Context->dbh;
452 " UPDATE labels_templates SET tmpl_code=?, tmpl_desc=?, page_width=?,
453 page_height=?, label_width=?, label_height=?, topmargin=?,
454 leftmargin=?, cols=?, rows=?, colgap=?, rowgap=?, font=?, fontsize=?,
458 my $sth = $dbh->prepare($query);
460 $tmpl_code, $tmpl_desc, $page_width, $page_height,
461 $label_width, $label_height, $topmargin, $leftmargin,
462 $cols, $rows, $colgap, $rowgap,
463 $font, $fontsize, $units, $tmpl_id
465 my $dberror = $sth->errstr;
473 $tmpl_code, $tmpl_desc, $page_width, $page_height,
474 $label_width, $label_height, $topmargin, $leftmargin,
475 $cols, $rows, $colgap, $rowgap,
476 $font, $fontsize, $units
479 my $dbh = C4::Context->dbh;
481 my $query = "INSERT INTO labels_templates (tmpl_code, tmpl_desc, page_width,
482 page_height, label_width, label_height, topmargin,
483 leftmargin, cols, rows, colgap, rowgap, font, fontsize, units)
484 VALUES(?,?,?,?,?,?,?,?,?,?,?,?,?,?,?)";
486 my $sth = $dbh->prepare($query);
488 $tmpl_code, $tmpl_desc, $page_width, $page_height,
489 $label_width, $label_height, $topmargin, $leftmargin,
490 $cols, $rows, $colgap, $rowgap,
491 $font, $fontsize, $units
493 my $dberror = $sth->errstr;
498 sub GetAllLabelTemplates {
499 my $dbh = C4::Context->dbh;
501 # get the actual items to be printed.
503 my $query = " Select * from labels_templates ";
504 my $sth = $dbh->prepare($query);
507 while ( my $data = $sth->fetchrow_hashref ) {
508 push( @resultsloop, $data );
512 #warn Dumper @resultsloop;
520 $barcodetype, $title, $subtitle, $isbn, $issn,
521 $itemtype, $bcn, $dcn, $classif,
522 $subclass, $itemcallnumber, $author, $tmpl_id,
523 $printingtype, $guidebox, $startlabel, $layoutname
526 my $dbh = C4::Context->dbh;
527 my $query2 = "update labels_conf set active = NULL";
528 my $sth2 = $dbh->prepare($query2);
530 $query2 = "INSERT INTO labels_conf
531 ( barcodetype, title, subtitle, isbn,issn, itemtype, barcode,
532 dewey, class, subclass, itemcallnumber, author, printingtype,
533 guidebox, startlabel, layoutname, active )
534 values ( ?, ?, ?, ?, ?, ?, ?, ?,?, ?, ?, ?, ?, ?,?,?, 1 )";
535 $sth2 = $dbh->prepare($query2);
537 $barcodetype, $title, $subtitle, $isbn, $issn,
539 $itemtype, $bcn, $dcn, $classif,
540 $subclass, $itemcallnumber, $author, $printingtype,
541 $guidebox, $startlabel, $layoutname
545 SetActiveTemplate($tmpl_id);
552 $barcodetype, $title, $subtitle, $isbn, $issn,
553 $itemtype, $bcn, $dcn, $classif,
554 $subclass, $itemcallnumber, $author, $tmpl_id,
555 $printingtype, $guidebox, $startlabel, $layoutname,
561 my $dbh = C4::Context->dbh;
562 my $query2 = "update labels_conf set
563 barcodetype=?, title=?, subtitle=?, isbn=?,issn=?,
564 itemtype=?, barcode=?, dewey=?, class=?,
565 subclass=?, itemcallnumber=?, author=?, printingtype=?,
566 guidebox=?, startlabel=?, layoutname=? where id = ?";
567 my $sth2 = $dbh->prepare($query2);
569 $barcodetype, $title, $subtitle, $isbn, $issn,
570 $itemtype, $bcn, $dcn, $classif,
571 $subclass, $itemcallnumber, $author, $printingtype,
572 $guidebox, $startlabel, $layoutname, $layout_id
579 =item GetAllPrinterProfiles;
581 @profiles = GetAllPrinterProfiles()
583 Returns an array of references-to-hash, whos keys are .....
587 sub GetAllPrinterProfiles {
589 my $dbh = C4::Context->dbh;
591 my $query = "SELECT * FROM printers_profile AS pp INNER JOIN labels_templates AS lt ON pp.tmpl_id = lt.tmpl_id; ";
592 my $sth = $dbh->prepare($query);
595 while ( my $data = $sth->fetchrow_hashref ) {
596 push( @resultsloop, $data );
603 =item GetSinglePrinterProfile;
605 $profile = GetSinglePrinterProfile()
607 Returns a hashref whos keys are...
611 sub GetSinglePrinterProfile {
613 my $dbh = C4::Context->dbh;
614 my $query = " SELECT * FROM printers_profile WHERE prof_id = ?; ";
615 my $sth = $dbh->prepare($query);
616 $sth->execute($prof_id);
617 my $template = $sth->fetchrow_hashref;
624 SaveProfile('parameters')
626 When passed a set of parameters, this function updates the given profile with the new parameters.
632 $prof_id, $offset_horz, $offset_vert, $creep_horz, $creep_vert, $units
634 my $dbh = C4::Context->dbh;
636 " UPDATE printers_profile
637 SET offset_horz=?, offset_vert=?, creep_horz=?, creep_vert=?, unit=?
639 my $sth = $dbh->prepare($query);
641 $offset_horz, $offset_vert, $creep_horz, $creep_vert, $units, $prof_id
648 CreateProfile('parameters')
650 When passed a set of parameters, this function creates a new profile containing those parameters
651 and returns any errors.
657 $prof_id, $printername, $paper_bin, $tmpl_id, $offset_horz,
658 $offset_vert, $creep_horz, $creep_vert, $units
660 my $dbh = C4::Context->dbh;
662 " INSERT INTO printers_profile (prof_id, printername, paper_bin, tmpl_id,
663 offset_horz, offset_vert, creep_horz, creep_vert, unit)
664 VALUES(?,?,?,?,?,?,?,?,?) ";
665 my $sth = $dbh->prepare($query);
667 $prof_id, $printername, $paper_bin, $tmpl_id, $offset_horz,
668 $offset_vert, $creep_horz, $creep_vert, $units
670 my $error = $sth->errstr;
677 DeleteProfile(prof_id)
679 When passed a profile id, this function deletes that profile from the database and returns any errors.
685 my $dbh = C4::Context->dbh;
686 my $query = " DELETE FROM printers_profile WHERE prof_id = ?";
687 my $sth = $dbh->prepare($query);
688 $sth->execute($prof_id);
689 my $error = $sth->errstr;
694 =item GetAssociatedProfile;
696 $assoc_prof = GetAssociatedProfile(tmpl_id)
698 When passed a template id, this function returns the parameters from the currently associated printer profile
699 in a hashref where key=fieldname and value=fieldvalue.
703 sub GetAssociatedProfile {
705 my $dbh = C4::Context->dbh;
706 # First we find out the prof_id for the associated profile...
707 my $query = "SELECT * FROM labels_profile WHERE tmpl_id = ?";
708 my $sth = $dbh->prepare($query);
709 $sth->execute($tmpl_id);
710 my $assoc_prof = $sth->fetchrow_hashref;
712 # Then we retrieve that profile and return it to the caller...
713 $assoc_prof = GetSinglePrinterProfile($assoc_prof->{'prof_id'});
717 =item SetAssociatedProfile;
719 SetAssociatedProfile($prof_id, $tmpl_id)
721 When passed both a profile id and template id, this function establishes an association between the two. No more
722 than one profile may be associated with any given template at the same time.
726 sub SetAssociatedProfile {
728 my ($prof_id, $tmpl_id) = @_;
730 my $dbh = C4::Context->dbh;
731 my $query = "INSERT INTO labels_profile (prof_id, tmpl_id) VALUES (?,?) ON DUPLICATE KEY UPDATE prof_id = ?";
732 my $sth = $dbh->prepare($query);
733 $sth->execute($prof_id, $tmpl_id, $prof_id);
739 $options = GetLabelItems()
741 Returns an array of references-to-hash, whos keys are the field from the biblio, biblioitems, items and labels tables in the Koha database.
748 my $dbh = C4::Context->dbh;
750 my @resultsloop = ();
756 my $query3 = "Select * from labels where batch_id = ? order by labelid ";
757 $sth = $dbh->prepare($query3);
758 $sth->execute($batch_id);
763 my $query3 = "Select * from labels";
764 $sth = $dbh->prepare($query3);
767 my $cnt = $sth->rows;
769 while ( my $data = $sth->fetchrow_hashref ) {
771 # lets get some summary info from each item
773 select i.*, bi.*, b.* from items i,biblioitems bi,biblio b
774 where itemnumber=? and i.biblioitemnumber=bi.biblioitemnumber and
775 bi.biblionumber=b.biblionumber";
777 my $sth1 = $dbh->prepare($query1);
778 $sth1->execute( $data->{'itemnumber'} );
780 my $data1 = $sth1->fetchrow_hashref();
781 $data1->{'labelno'} = $i1;
782 $data1->{'labelid'} = $data->{'labelid'};
783 $data1->{'batch_id'} = $batch_id;
784 $data1->{'summary'} =
785 "$data1->{'barcode'}, $data1->{'title'}, $data1->{'isbn'}";
787 push( @resultsloop, $data1 );
799 barcode title subtitle
800 dewey isbn issn author class
801 itemtype subclass itemcallnumber
807 sub GetPatronCardItems {
809 my ( $batch_id ) = @_;
812 my $dbh = C4::Context->dbh;
813 my $query = "SELECT * FROM patroncards WHERE batch_id = ? ORDER BY borrowernumber";
814 my $sth = $dbh->prepare($query);
815 $sth->execute($batch_id);
817 while ( my $data = $sth->fetchrow_hashref ) {
818 my $patron_data = GetMember( $data->{'borrowernumber'} );
819 $patron_data->{'branchname'} = GetBranchName( $patron_data->{'branchcode'} );
820 $patron_data->{'cardno'} = $cardno;
821 $patron_data->{'cardid'} = $data->{'cardid'};
822 $patron_data->{'batch_id'} = $batch_id;
823 push( @resultsloop, $patron_data );
831 sub deduplicate_batch {
832 my $batch_id = shift or return undef;
836 count(labelid) as count
839 GROUP BY itemnumber,batch_id
843 my $sth = C4::Context->dbh->prepare($query);
844 $sth->execute($batch_id);
845 $sth->rows or return undef;
852 ORDER BY timestamp ASC
855 while (my $data = $sth->fetchrow_hashref()) {
856 my $itemnumber = $data->{itemnumber} or next;
857 my $limit = $data->{count} - 1 or next;
858 my $sth2 = C4::Context->dbh->prepare("$del_query LIMIT $limit");
859 # die sprintf "$del_query LIMIT %s\n (%s, %s)", $limit, $batch_id, $itemnumber;
860 # $sth2->execute($batch_id, C4::Context->dbh->quote($data->{itemnumber}), $data->{count} - 1)
861 $sth2->execute($batch_id, $itemnumber) and
862 $killed += ($data->{count} - 1);
869 my ( $x_pos, $y_pos, $label_height, $label_width, $fontname, $fontsize, $left_text_margin,
870 $text_wrap_cols, $item, $conf_data, $printingtype )
872 # hack to fix column name mismatch betwen labels_conf.class, and bibitems.classification
873 $$item->{'class'} = $$item->{'classification'};
875 $Text::Wrap::columns = $text_wrap_cols;
876 $Text::Wrap::separator = "\n";
880 my $top_text_margin = ( $fontsize + 3 ); #FIXME: This should be a template parameter and passed in...
881 my $line_spacer = ( $fontsize * 1 ); # number of pixels between text rows (This is actually leading: baseline to baseline minus font size. Recommended starting point is 20% of font size.).
883 # add your printable fields manually in here
885 my $layout_id = $$conf_data->{'id'};
887 # my @fields = GetItemFields();
889 my $str_fields = get_text_fields($layout_id, 'codes' );
890 my @fields = split(/ /, $str_fields);
891 #warn Dumper(@fields);
893 my $vPos = ( $y_pos + ( $label_height - $top_text_margin ) );
894 my $font = prFont($fontname);
896 # warn Dumper $conf_data;
899 foreach my $field (@fields) {
902 # $$item->{"$field"} = $field . ": " . $$item->{"$field"};
904 # if the display option for this field is selected in the DB,
905 # and the item record has some values for this field, display it.
906 if ( $$conf_data->{"$field"} && $$item->{"$field"} ) {
908 # warn "CONF_TYPE = $field";
911 $str = $$item->{"$field"};
912 # strip out naughty existing nl/cr's
915 # wrap lines based on call number dividers '/'
918 while ( $str =~ /\// ) {
919 $str =~ /^(.*)\/(.*)$/;
922 unshift @strings, $2;
926 unshift @strings, $str;
928 # strip out division slashes
930 #warn "\$str after striping division marks: $str";
931 # chop the string up into _upto_ 12 chunks
932 # and seperate the chunks with newlines
934 #$str = wrap( "", "", "$str" );
935 #$str = wrap( "", "", "$str" );
937 # split the chunks between newline's, into an array
938 #my @strings = split /\n/, $str;
940 # then loop for each string line
941 foreach my $str (@strings) {
943 if ( $printingtype eq 'BIB' ) { #FIXME: This is a hack and needs to be implimented as a text justification option in the template...
944 # some code to try and center each line on the label based on font size and string point width...
945 my $stringwidth = prStrWidth($str, $fontname, $fontsize);
946 my $whitespace = ( $label_width - ( $stringwidth + (2 * $left_text_margin) ) );
947 $hPos = ( ( $whitespace / 2 ) + $x_pos + $left_text_margin );
948 #warn "\$label_width=$label_width \$stringwidth=$stringwidth \$whitespace=$whitespace \$left_text_margin=$left_text_margin for $str\n";
950 $hPos = ( $x_pos + $left_text_margin );
952 PrintText( $hPos, $vPos, $font, $fontsize, $str );
953 $vPos = $vPos - $line_spacer;
961 my ( $hPos, $vPos, $font, $fontsize, $text ) = @_;
962 my $str = "BT /$font $fontsize Tf $hPos $vPos Td ($text) Tj ET";
967 sub DrawPatronCardText {
969 my ( $x_pos, $y_pos, $label_height, $label_width, $fontname, $fontsize, $left_text_margin,
970 $text_wrap_cols, $text, $printingtype )
973 my $top_text_margin = 25; #FIXME: This should be a template parameter and passed in...
975 my $vPos = ( $y_pos + ( $label_height - $top_text_margin ) );
976 my $font = prFont($fontname);
980 foreach my $line (keys %$text) {
981 warn "Current text is \"$line\" and font size for \"$line\" is $text->{$line} points";
982 # some code to try and center each line on the label based on font size and string point width...
983 my $stringwidth = prStrWidth($line, $fontname, $text->{$line});
984 my $whitespace = ( $label_width - ( $stringwidth + (2 * $left_text_margin) ) );
985 $hPos = ( ( $whitespace / 2 ) + $x_pos + $left_text_margin );
987 PrintText( $hPos, $vPos, $font, $text->{$line}, $line );
988 my $line_spacer = ( $text->{$line} * 1 ); # number of pixels between text rows (This is actually leading: baseline to baseline minus font size. Recommended starting point is 20% (0.20) of font size.).
989 $vPos = $vPos - ($line_spacer + $text->{$line}); # Linefeed equiv: leading + font size
997 # my ($fontsize) = @_;
999 # my $str = "BT/F13 30 Tf288 720 Td( AAAAAAAAAA ) TjET";
1005 # x and y are from the top-left :)
1006 my ( $x_pos, $y_pos, $height, $width, $barcode, $barcodetype ) = @_;
1007 my $num_of_bars = length($barcode);
1008 my $bar_width = $width * .8; # %80 of length of label width
1011 my $guard_length = 10;
1014 if ( $barcodetype eq 'CODE39' ) {
1015 $bar_length = '17.5';
1017 ( $bar_length * $num_of_bars ) + ( $guard_length * 2 );
1018 $xsize_ratio = ( $bar_width / $tot_bar_length );
1020 PDF::Reuse::Barcode::Code39(
1021 x => ( $x_pos + ( $width / 10 ) ),
1022 y => ( $y_pos + ( $height / 10 ) ),
1023 value => "*$barcode*",
1024 ySize => ( .02 * $height ),
1025 xSize => $xsize_ratio,
1030 warn "$barcodetype, $barcode FAILED:$@";
1034 elsif ( $barcodetype eq 'CODE39MOD' ) {
1036 # get modulo43 checksum
1037 my $c39 = CheckDigits('code_39');
1038 $barcode = $c39->complete($barcode);
1042 ( $bar_length * $num_of_bars ) + ( $guard_length * 2 );
1043 $xsize_ratio = ( $bar_width / $tot_bar_length );
1045 PDF::Reuse::Barcode::Code39(
1046 x => ( $x_pos + ( $width / 10 ) ),
1047 y => ( $y_pos + ( $height / 10 ) ),
1048 value => "*$barcode*",
1049 ySize => ( .02 * $height ),
1050 xSize => $xsize_ratio,
1056 warn "$barcodetype, $barcode FAILED:$@";
1059 elsif ( $barcodetype eq 'CODE39MOD10' ) {
1061 # get modulo43 checksum
1062 my $c39_10 = CheckDigits('visa');
1063 $barcode = $c39_10->complete($barcode);
1067 ( $bar_length * $num_of_bars ) + ( $guard_length * 2 );
1068 $xsize_ratio = ( $bar_width / $tot_bar_length );
1070 PDF::Reuse::Barcode::Code39(
1071 x => ( $x_pos + ( $width / 10 ) ),
1072 y => ( $y_pos + ( $height / 10 ) ),
1073 value => "*$barcode*",
1074 ySize => ( .02 * $height ),
1075 xSize => $xsize_ratio,
1082 warn "$barcodetype, $barcode FAILED:$@";
1087 elsif ( $barcodetype eq 'COOP2OF5' ) {
1088 $bar_length = '9.43333333333333';
1090 ( $bar_length * $num_of_bars ) + ( $guard_length * 2 );
1091 $xsize_ratio = ( $bar_width / $tot_bar_length ) * .9;
1093 PDF::Reuse::Barcode::COOP2of5(
1094 x => ( $x_pos + ( $width / 10 ) ),
1095 y => ( $y_pos + ( $height / 10 ) ),
1097 ySize => ( .02 * $height ),
1098 xSize => $xsize_ratio,
1102 warn "$barcodetype, $barcode FAILED:$@";
1106 elsif ( $barcodetype eq 'INDUSTRIAL2OF5' ) {
1107 $bar_length = '13.1333333333333';
1109 ( $bar_length * $num_of_bars ) + ( $guard_length * 2 );
1110 $xsize_ratio = ( $bar_width / $tot_bar_length ) * .9;
1112 PDF::Reuse::Barcode::Industrial2of5(
1113 x => ( $x_pos + ( $width / 10 ) ),
1114 y => ( $y_pos + ( $height / 10 ) ),
1116 ySize => ( .02 * $height ),
1117 xSize => $xsize_ratio,
1121 warn "$barcodetype, $barcode FAILED:$@";
1125 my $moo2 = $tot_bar_length * $xsize_ratio;
1127 warn "$x_pos, $y_pos, $barcode, $barcodetype" if $DEBUG;
1128 warn "BAR_WDTH = $bar_width, TOT.BAR.LGHT=$tot_bar_length R*TOT.BAR =$moo2" if $DEBUG;
1131 =item build_circ_barcode;
1133 build_circ_barcode( $x_pos, $y_pos, $barcode,
1134 $barcodetype, \$item);
1136 $item is the result of a previous call to GetLabelItems();
1141 sub build_circ_barcode {
1142 my ( $x_pos_circ, $y_pos, $value, $barcodetype, $item ) = @_;
1144 #warn Dumper \$item;
1146 #warn "value = $value\n";
1150 if ( $barcodetype eq 'EAN13' ) {
1152 #testing EAN13 barcodes hack
1153 $value = $value . '000000000';
1155 $value = substr( $value, 0, 12 );
1159 PDF::Reuse::Barcode::EAN13(
1160 x => ( $x_pos_circ + 27 ),
1161 y => ( $y_pos + 15 ),
1169 # added for xpdf compat. doesnt use type3 fonts., but increases filesize from 20k to 200k
1170 # i think its embedding extra fonts in the pdf file.
1171 # mode => 'graphic',
1175 $item->{'barcodeerror'} = 1;
1177 #warn "EAN13BARCODE FAILED:$@";
1183 elsif ( $barcodetype eq 'Code39' ) {
1186 PDF::Reuse::Barcode::Code39(
1187 x => ( $x_pos_circ + 9 ),
1188 y => ( $y_pos + 15 ),
1198 $item->{'barcodeerror'} = 1;
1200 #warn "CODE39BARCODE $value FAILED:$@";
1207 elsif ( $barcodetype eq 'Matrix2of5' ) {
1209 #warn "MATRIX ELSE:";
1211 #testing MATRIX25 barcodes hack
1212 # $value = $value.'000000000';
1215 # $value = substr( $value, 0, 12 );
1219 PDF::Reuse::Barcode::Matrix2of5(
1220 x => ( $x_pos_circ + 27 ),
1221 y => ( $y_pos + 15 ),
1231 $item->{'barcodeerror'} = 1;
1233 #warn "BARCODE FAILED:$@";
1240 elsif ( $barcodetype eq 'EAN8' ) {
1242 #testing ean8 barcodes hack
1243 $value = $value . '000000000';
1245 $value = substr( $value, 0, 8 );
1249 #warn "EAN8 ELSEIF";
1251 PDF::Reuse::Barcode::EAN8(
1252 x => ( $x_pos_circ + 42 ),
1253 y => ( $y_pos + 15 ),
1263 $item->{'barcodeerror'} = 1;
1265 #warn "BARCODE FAILED:$@";
1272 elsif ( $barcodetype eq 'UPC-E' ) {
1274 PDF::Reuse::Barcode::UPCE(
1275 x => ( $x_pos_circ + 27 ),
1276 y => ( $y_pos + 15 ),
1286 $item->{'barcodeerror'} = 1;
1288 #warn "BARCODE FAILED:$@";
1294 elsif ( $barcodetype eq 'NW7' ) {
1296 PDF::Reuse::Barcode::NW7(
1297 x => ( $x_pos_circ + 27 ),
1298 y => ( $y_pos + 15 ),
1308 $item->{'barcodeerror'} = 1;
1310 #warn "BARCODE FAILED:$@";
1316 elsif ( $barcodetype eq 'ITF' ) {
1318 PDF::Reuse::Barcode::ITF(
1319 x => ( $x_pos_circ + 27 ),
1320 y => ( $y_pos + 15 ),
1330 $item->{'barcodeerror'} = 1;
1332 #warn "BARCODE FAILED:$@";
1338 elsif ( $barcodetype eq 'Industrial2of5' ) {
1340 PDF::Reuse::Barcode::Industrial2of5(
1341 x => ( $x_pos_circ + 27 ),
1342 y => ( $y_pos + 15 ),
1351 $item->{'barcodeerror'} = 1;
1353 #warn "BARCODE FAILED:$@";
1359 elsif ( $barcodetype eq 'IATA2of5' ) {
1361 PDF::Reuse::Barcode::IATA2of5(
1362 x => ( $x_pos_circ + 27 ),
1363 y => ( $y_pos + 15 ),
1372 $item->{'barcodeerror'} = 1;
1374 #warn "BARCODE FAILED:$@";
1381 elsif ( $barcodetype eq 'COOP2of5' ) {
1383 PDF::Reuse::Barcode::COOP2of5(
1384 x => ( $x_pos_circ + 27 ),
1385 y => ( $y_pos + 15 ),
1394 $item->{'barcodeerror'} = 1;
1396 #warn "BARCODE FAILED:$@";
1402 elsif ( $barcodetype eq 'UPC-A' ) {
1405 PDF::Reuse::Barcode::UPCA(
1406 x => ( $x_pos_circ + 27 ),
1407 y => ( $y_pos + 15 ),
1416 $item->{'barcodeerror'} = 1;
1418 #warn "BARCODE FAILED:$@";
1427 =item draw_boundaries
1429 sub draw_boundaries ($x_pos_spine, $x_pos_circ1, $x_pos_circ2,
1430 $y_pos, $spine_width, $label_height, $circ_width)
1432 This sub draws boundary lines where the label outlines are, to aid in printer testing, and debugging.
1437 sub draw_boundaries {
1440 $x_pos_spine, $x_pos_circ1, $x_pos_circ2, $y_pos,
1441 $spine_width, $label_height, $circ_width
1444 my $y_pos_initial = ( ( 792 - 36 ) - 90 );
1445 $y_pos = $y_pos_initial; # FIXME - why are we ignoring the y_pos parameter by redefining it?
1448 for ( $i = 1 ; $i <= 8 ; $i++ ) {
1450 &drawbox( $x_pos_spine, $y_pos, ($spine_width), ($label_height) );
1452 #warn "OLD BOXES x=$x_pos_spine, y=$y_pos, w=$spine_width, h=$label_height";
1453 &drawbox( $x_pos_circ1, $y_pos, ($circ_width), ($label_height) );
1454 &drawbox( $x_pos_circ2, $y_pos, ($circ_width), ($label_height) );
1456 $y_pos = ( $y_pos - $label_height );
1463 sub drawbox { $lower_left_x, $lower_left_y,
1464 $upper_right_x, $upper_right_y )
1466 this is a low level sub, that draws a pdf box, it is called by draw_boxes
1468 FYI: the $upper_right_x and $upper_right_y values are RELATIVE to $lower_left_x and $lower_left_y
1470 and $lower_left_x, $lower_left_y are ABSOLUTE, this caught me out!
1476 my ( $llx, $lly, $urx, $ury ) = @_;
1478 # warn "llx,y= $llx,$lly , urx,y=$urx,$ury \n";
1480 my $str = "q\n"; # save the graphic state
1481 $str .= "0.5 w\n"; # border color red
1482 $str .= "1.0 0.0 0.0 RG\n"; # border color red
1483 # $str .= "0.5 0.75 1.0 rg\n"; # fill color blue
1484 $str .= "1.0 1.0 1.0 rg\n"; # fill color white
1486 $str .= "$llx $lly $urx $ury re\n"; # a rectangle
1487 $str .= "B\n"; # fill (and a little more)
1488 $str .= "Q\n"; # save the graphic state
1494 END { } # module clean-up code here (global destructor)
1503 Mason James <mason@katipo.co.nz>