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};
262 add_batch($batch_type,\@batch_list);
263 if $batch_list is supplied,
264 create a new batch with those items.
265 else, return the next available batch_id.
269 my ( $batch_type,$batch_list ) = @_;
271 my $dbh = C4::Context->dbh;
272 my $q ="SELECT MAX(DISTINCT batch_id) FROM $batch_type";
273 my $sth = $dbh->prepare($q);
275 my ($batch_id) = $sth->fetchrow_array;
282 # TODO: let this block use $batch_type
283 if(ref($batch_list) && ($batch_type eq 'labels') ) {
284 my $sth = $dbh->prepare("INSERT INTO labels (`batch_id`,`itemnumber`) VALUES (?,?)");
285 for my $item (@$batch_list) {
286 $sth->execute($batch_id,$item);
292 #FIXME: Needs to be ported to receive $batch_type
293 # ... this looks eerily like add_batch() ...
294 sub get_highest_batch {
296 my $dbh = C4::Context->dbh;
298 "select distinct batch_id from labels order by batch_id desc limit 1";
299 my $sth = $dbh->prepare($q);
301 my $data = $sth->fetchrow_hashref;
304 if ( !$data->{'batch_id'} ) {
308 $new_batch = $data->{'batch_id'};
316 my ( $batch_type ) = @_;
317 my $dbh = C4::Context->dbh;
318 my $q = "SELECT batch_id, COUNT(*) AS num FROM $batch_type GROUP BY batch_id";
319 my $sth = $dbh->prepare($q);
322 while ( my $data = $sth->fetchrow_hashref ) {
323 push( @resultsloop, $data );
327 # Not sure why we are doing this rather than simply telling the user that no batches are currently defined.
328 # So I'm commenting this out and modifying label-manager.tmpl to properly inform the user as stated. -fbcit
329 # adding a dummy batch=1 value , if none exists in the db
330 # if ( !scalar(@resultsloop) ) {
331 # push( @resultsloop, { batch_id => '1' , num => '0' } );
337 my ($batch_id, $batch_type) = @_;
338 warn "Deleteing batch of type $batch_type";
339 my $dbh = C4::Context->dbh;
340 my $q = "DELETE FROM $batch_type WHERE batch_id = ?";
341 my $sth = $dbh->prepare($q);
342 $sth->execute($batch_id);
346 sub get_barcode_types {
347 my ($layout_id) = @_;
348 my $layout = get_layout($layout_id);
349 my $barcode = $layout->{'barcodetype'};
352 push( @array, { code => 'CODE39', desc => 'Code 39' } );
353 push( @array, { code => 'CODE39MOD', desc => 'Code39 + Modulo43' } );
354 push( @array, { code => 'CODE39MOD10', desc => 'Code39 + Modulo10' } );
355 push( @array, { code => 'ITF', desc => 'Interleaved 2 of 5' } );
357 foreach my $line (@array) {
358 if ( $line->{'code'} eq $barcode ) {
359 $line->{'active'} = 1;
370 $unitvalue = '1' if ( $units eq 'POINT' );
371 $unitvalue = '2.83464567' if ( $units eq 'MM' );
372 $unitvalue = '28.3464567' if ( $units eq 'CM' );
373 $unitvalue = 72 if ( $units eq 'INCH' );
377 sub GetTextWrapCols {
378 my ( $font, $fontsize, $label_width, $left_text_margin ) = @_;
382 # my $textlimit = $label_width - ($left_text_margin);
383 my $textlimit = $label_width - ( 2* $left_text_margin);
385 while ( $strwidth < $textlimit ) {
386 $strwidth = prStrWidth( $string, $font, $fontsize );
387 $string = $string . '0';
388 #warn "strwidth:$strwidth, textlimit:$textlimit, count:$count string:$string";
394 sub GetActiveLabelTemplate {
395 my $dbh = C4::Context->dbh;
396 my $query = " SELECT * FROM labels_templates where active = 1 limit 1";
397 my $sth = $dbh->prepare($query);
399 my $active_tmpl = $sth->fetchrow_hashref;
404 sub GetSingleLabelTemplate {
406 my $dbh = C4::Context->dbh;
407 my $query = " SELECT * FROM labels_templates where tmpl_id = ?";
408 my $sth = $dbh->prepare($query);
409 $sth->execute($tmpl_id);
410 my $template = $sth->fetchrow_hashref;
415 sub SetActiveTemplate {
419 my $dbh = C4::Context->dbh;
420 my $query = " UPDATE labels_templates SET active = NULL";
421 my $sth = $dbh->prepare($query);
424 $query = "UPDATE labels_templates SET active = 1 WHERE tmpl_id = ?";
425 $sth = $dbh->prepare($query);
426 $sth->execute($tmpl_id);
430 sub set_active_layout {
432 my ($layout_id) = @_;
433 my $dbh = C4::Context->dbh;
434 my $query = " UPDATE labels_conf SET active = NULL";
435 my $sth = $dbh->prepare($query);
438 $query = "UPDATE labels_conf SET active = 1 WHERE id = ?";
439 $sth = $dbh->prepare($query);
440 $sth->execute($layout_id);
446 my $dbh = C4::Context->dbh;
447 my $query = " DELETE FROM labels_templates where tmpl_id = ?";
448 my $sth = $dbh->prepare($query);
449 $sth->execute($tmpl_id);
455 $tmpl_id, $tmpl_code, $tmpl_desc, $page_width,
456 $page_height, $label_width, $label_height, $topmargin,
457 $leftmargin, $cols, $rows, $colgap,
458 $rowgap, $font, $fontsize, $units
460 warn "Passed \$font:$font";
461 my $dbh = C4::Context->dbh;
463 " UPDATE labels_templates SET tmpl_code=?, tmpl_desc=?, page_width=?,
464 page_height=?, label_width=?, label_height=?, topmargin=?,
465 leftmargin=?, cols=?, rows=?, colgap=?, rowgap=?, font=?, fontsize=?,
469 my $sth = $dbh->prepare($query);
471 $tmpl_code, $tmpl_desc, $page_width, $page_height,
472 $label_width, $label_height, $topmargin, $leftmargin,
473 $cols, $rows, $colgap, $rowgap,
474 $font, $fontsize, $units, $tmpl_id
476 my $dberror = $sth->errstr;
484 $tmpl_code, $tmpl_desc, $page_width, $page_height,
485 $label_width, $label_height, $topmargin, $leftmargin,
486 $cols, $rows, $colgap, $rowgap,
487 $font, $fontsize, $units
490 my $dbh = C4::Context->dbh;
492 my $query = "INSERT INTO labels_templates (tmpl_code, tmpl_desc, page_width,
493 page_height, label_width, label_height, topmargin,
494 leftmargin, cols, rows, colgap, rowgap, font, fontsize, units)
495 VALUES(?,?,?,?,?,?,?,?,?,?,?,?,?,?,?)";
497 my $sth = $dbh->prepare($query);
499 $tmpl_code, $tmpl_desc, $page_width, $page_height,
500 $label_width, $label_height, $topmargin, $leftmargin,
501 $cols, $rows, $colgap, $rowgap,
502 $font, $fontsize, $units
504 my $dberror = $sth->errstr;
509 sub GetAllLabelTemplates {
510 my $dbh = C4::Context->dbh;
512 # get the actual items to be printed.
514 my $query = " Select * from labels_templates ";
515 my $sth = $dbh->prepare($query);
518 while ( my $data = $sth->fetchrow_hashref ) {
519 push( @resultsloop, $data );
523 #warn Dumper @resultsloop;
531 $barcodetype, $title, $subtitle, $isbn, $issn,
532 $itemtype, $bcn, $dcn, $classif,
533 $subclass, $itemcallnumber, $author, $tmpl_id,
534 $printingtype, $guidebox, $startlabel, $layoutname
537 my $dbh = C4::Context->dbh;
538 my $query2 = "update labels_conf set active = NULL";
539 my $sth2 = $dbh->prepare($query2);
541 $query2 = "INSERT INTO labels_conf
542 ( barcodetype, title, subtitle, isbn,issn, itemtype, barcode,
543 dewey, class, subclass, itemcallnumber, author, printingtype,
544 guidebox, startlabel, layoutname, active )
545 values ( ?, ?, ?, ?, ?, ?, ?, ?,?, ?, ?, ?, ?, ?,?,?, 1 )";
546 $sth2 = $dbh->prepare($query2);
548 $barcodetype, $title, $subtitle, $isbn, $issn,
550 $itemtype, $bcn, $dcn, $classif,
551 $subclass, $itemcallnumber, $author, $printingtype,
552 $guidebox, $startlabel, $layoutname
556 SetActiveTemplate($tmpl_id);
563 $barcodetype, $title, $subtitle, $isbn, $issn,
564 $itemtype, $bcn, $dcn, $classif,
565 $subclass, $itemcallnumber, $author, $tmpl_id,
566 $printingtype, $guidebox, $startlabel, $layoutname,
572 my $dbh = C4::Context->dbh;
573 my $query2 = "update labels_conf set
574 barcodetype=?, title=?, subtitle=?, isbn=?,issn=?,
575 itemtype=?, barcode=?, dewey=?, class=?,
576 subclass=?, itemcallnumber=?, author=?, printingtype=?,
577 guidebox=?, startlabel=?, layoutname=? where id = ?";
578 my $sth2 = $dbh->prepare($query2);
580 $barcodetype, $title, $subtitle, $isbn, $issn,
581 $itemtype, $bcn, $dcn, $classif,
582 $subclass, $itemcallnumber, $author, $printingtype,
583 $guidebox, $startlabel, $layoutname, $layout_id
590 =item GetAllPrinterProfiles;
592 @profiles = GetAllPrinterProfiles()
594 Returns an array of references-to-hash, whos keys are .....
598 sub GetAllPrinterProfiles {
600 my $dbh = C4::Context->dbh;
602 my $query = "SELECT * FROM printers_profile AS pp INNER JOIN labels_templates AS lt ON pp.tmpl_id = lt.tmpl_id; ";
603 my $sth = $dbh->prepare($query);
606 while ( my $data = $sth->fetchrow_hashref ) {
607 push( @resultsloop, $data );
614 =item GetSinglePrinterProfile;
616 $profile = GetSinglePrinterProfile()
618 Returns a hashref whos keys are...
622 sub GetSinglePrinterProfile {
624 my $dbh = C4::Context->dbh;
625 my $query = " SELECT * FROM printers_profile WHERE prof_id = ?; ";
626 my $sth = $dbh->prepare($query);
627 $sth->execute($prof_id);
628 my $template = $sth->fetchrow_hashref;
635 SaveProfile('parameters')
637 When passed a set of parameters, this function updates the given profile with the new parameters.
643 $prof_id, $offset_horz, $offset_vert, $creep_horz, $creep_vert, $units
645 my $dbh = C4::Context->dbh;
647 " UPDATE printers_profile
648 SET offset_horz=?, offset_vert=?, creep_horz=?, creep_vert=?, unit=?
650 my $sth = $dbh->prepare($query);
652 $offset_horz, $offset_vert, $creep_horz, $creep_vert, $units, $prof_id
659 CreateProfile('parameters')
661 When passed a set of parameters, this function creates a new profile containing those parameters
662 and returns any errors.
668 $prof_id, $printername, $paper_bin, $tmpl_id, $offset_horz,
669 $offset_vert, $creep_horz, $creep_vert, $units
671 my $dbh = C4::Context->dbh;
673 " INSERT INTO printers_profile (prof_id, printername, paper_bin, tmpl_id,
674 offset_horz, offset_vert, creep_horz, creep_vert, unit)
675 VALUES(?,?,?,?,?,?,?,?,?) ";
676 my $sth = $dbh->prepare($query);
678 $prof_id, $printername, $paper_bin, $tmpl_id, $offset_horz,
679 $offset_vert, $creep_horz, $creep_vert, $units
681 my $error = $sth->errstr;
688 DeleteProfile(prof_id)
690 When passed a profile id, this function deletes that profile from the database and returns any errors.
696 my $dbh = C4::Context->dbh;
697 my $query = " DELETE FROM printers_profile WHERE prof_id = ?";
698 my $sth = $dbh->prepare($query);
699 $sth->execute($prof_id);
700 my $error = $sth->errstr;
705 =item GetAssociatedProfile;
707 $assoc_prof = GetAssociatedProfile(tmpl_id)
709 When passed a template id, this function returns the parameters from the currently associated printer profile
710 in a hashref where key=fieldname and value=fieldvalue.
714 sub GetAssociatedProfile {
716 my $dbh = C4::Context->dbh;
717 # First we find out the prof_id for the associated profile...
718 my $query = "SELECT * FROM labels_profile WHERE tmpl_id = ?";
719 my $sth = $dbh->prepare($query);
720 $sth->execute($tmpl_id);
721 my $assoc_prof = $sth->fetchrow_hashref;
723 # Then we retrieve that profile and return it to the caller...
724 $assoc_prof = GetSinglePrinterProfile($assoc_prof->{'prof_id'});
728 =item SetAssociatedProfile;
730 SetAssociatedProfile($prof_id, $tmpl_id)
732 When passed both a profile id and template id, this function establishes an association between the two. No more
733 than one profile may be associated with any given template at the same time.
737 sub SetAssociatedProfile {
739 my ($prof_id, $tmpl_id) = @_;
741 my $dbh = C4::Context->dbh;
742 my $query = "INSERT INTO labels_profile (prof_id, tmpl_id) VALUES (?,?) ON DUPLICATE KEY UPDATE prof_id = ?";
743 my $sth = $dbh->prepare($query);
744 $sth->execute($prof_id, $tmpl_id, $prof_id);
750 $options = GetLabelItems()
752 Returns an array of references-to-hash, whos keys are the field from the biblio, biblioitems, items and labels tables in the Koha database.
759 my $dbh = C4::Context->dbh;
761 my @resultsloop = ();
767 my $query3 = "Select * from labels where batch_id = ? order by labelid ";
768 $sth = $dbh->prepare($query3);
769 $sth->execute($batch_id);
774 my $query3 = "Select * from labels";
775 $sth = $dbh->prepare($query3);
778 my $cnt = $sth->rows;
780 while ( my $data = $sth->fetchrow_hashref ) {
782 # lets get some summary info from each item
784 select i.*, bi.*, b.* from items i,biblioitems bi,biblio b
785 where itemnumber=? and i.biblioitemnumber=bi.biblioitemnumber and
786 bi.biblionumber=b.biblionumber";
788 my $sth1 = $dbh->prepare($query1);
789 $sth1->execute( $data->{'itemnumber'} );
791 my $data1 = $sth1->fetchrow_hashref();
792 $data1->{'labelno'} = $i1;
793 $data1->{'labelid'} = $data->{'labelid'};
794 $data1->{'batch_id'} = $batch_id;
795 $data1->{'summary'} =
796 "$data1->{'barcode'}, $data1->{'title'}, $data1->{'isbn'}";
798 push( @resultsloop, $data1 );
810 barcode title subtitle
811 dewey isbn issn author class
812 itemtype subclass itemcallnumber
818 sub GetPatronCardItems {
820 my ( $batch_id ) = @_;
823 my $dbh = C4::Context->dbh;
824 my $query = "SELECT * FROM patroncards WHERE batch_id = ? ORDER BY borrowernumber";
825 my $sth = $dbh->prepare($query);
826 $sth->execute($batch_id);
828 while ( my $data = $sth->fetchrow_hashref ) {
829 my $patron_data = GetMember( $data->{'borrowernumber'} );
830 $patron_data->{'branchname'} = GetBranchName( $patron_data->{'branchcode'} );
831 $patron_data->{'cardno'} = $cardno;
832 $patron_data->{'cardid'} = $data->{'cardid'};
833 $patron_data->{'batch_id'} = $batch_id;
834 push( @resultsloop, $patron_data );
842 sub deduplicate_batch {
843 my ( $batch_id, $batch_type ) = @_;
846 batch_id," . (($batch_type eq 'labels') ? 'itemnumber' : 'borrowernumber') . ",
847 count(". (($batch_type eq 'labels') ? 'labelid' : 'cardid') . ") as count
850 GROUP BY " . (($batch_type eq 'labels') ? 'itemnumber' : 'borrowernumber') . ",batch_id
854 my $sth = C4::Context->dbh->prepare($query);
855 $sth->execute($batch_id);
856 warn $sth->errstr if $sth->errstr;
857 $sth->rows or return undef, $sth->errstr;
863 AND " . (($batch_type eq 'labels') ? 'itemnumber' : 'borrowernumber') . " = ?
864 ORDER BY timestamp ASC
867 while (my $data = $sth->fetchrow_hashref()) {
868 my $itemnumber = $data->{(($batch_type eq 'labels') ? 'itemnumber' : 'borrowernumber')} or next;
869 my $limit = $data->{count} - 1 or next;
870 my $sth2 = C4::Context->dbh->prepare("$del_query LIMIT $limit");
871 # die sprintf "$del_query LIMIT %s\n (%s, %s)", $limit, $batch_id, $itemnumber;
872 # $sth2->execute($batch_id, C4::Context->dbh->quote($data->{itemnumber}), $data->{count} - 1)
873 $sth2->execute($batch_id, $itemnumber) and
874 $killed += ($data->{count} - 1);
875 warn $sth2->errstr if $sth2->errstr;
877 return $killed, undef;
882 my ( $x_pos, $y_pos, $label_height, $label_width, $fontname, $fontsize, $left_text_margin,
883 $text_wrap_cols, $item, $conf_data, $printingtype )
885 # hack to fix column name mismatch betwen labels_conf.class, and bibitems.classification
886 $$item->{'class'} = $$item->{'classification'};
888 $Text::Wrap::columns = $text_wrap_cols;
889 $Text::Wrap::separator = "\n";
893 my $top_text_margin = ( $fontsize + 3 ); #FIXME: This should be a template parameter and passed in...
894 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.).
896 # add your printable fields manually in here
898 my $layout_id = $$conf_data->{'id'};
900 # my @fields = GetItemFields();
902 my $str_fields = get_text_fields($layout_id, 'codes' );
903 my @fields = split(/ /, $str_fields);
904 #warn Dumper(@fields);
906 my $vPos = ( $y_pos + ( $label_height - $top_text_margin ) );
907 my $font = prFont($fontname);
909 # warn Dumper $conf_data;
912 foreach my $field (@fields) {
915 # $$item->{"$field"} = $field . ": " . $$item->{"$field"};
917 # if the display option for this field is selected in the DB,
918 # and the item record has some values for this field, display it.
919 if ( $$conf_data->{"$field"} && $$item->{"$field"} ) {
921 # warn "CONF_TYPE = $field";
924 $str = $$item->{"$field"};
925 # strip out naughty existing nl/cr's
928 # wrap lines based on call number dividers '/'
931 while ( $str =~ /\// ) {
932 $str =~ /^(.*)\/(.*)$/;
935 unshift @strings, $2;
939 unshift @strings, $str;
941 # strip out division slashes
943 #warn "\$str after striping division marks: $str";
944 # chop the string up into _upto_ 12 chunks
945 # and seperate the chunks with newlines
947 #$str = wrap( "", "", "$str" );
948 #$str = wrap( "", "", "$str" );
950 # split the chunks between newline's, into an array
951 #my @strings = split /\n/, $str;
953 # then loop for each string line
954 foreach my $str (@strings) {
956 if ( $printingtype eq 'BIB' ) { #FIXME: This is a hack and needs to be implimented as a text justification option in the template...
957 # some code to try and center each line on the label based on font size and string point width...
958 my $stringwidth = prStrWidth($str, $fontname, $fontsize);
959 my $whitespace = ( $label_width - ( $stringwidth + (2 * $left_text_margin) ) );
960 $hPos = ( ( $whitespace / 2 ) + $x_pos + $left_text_margin );
961 #warn "\$label_width=$label_width \$stringwidth=$stringwidth \$whitespace=$whitespace \$left_text_margin=$left_text_margin for $str\n";
963 $hPos = ( $x_pos + $left_text_margin );
965 PrintText( $hPos, $vPos, $font, $fontsize, $str );
966 $vPos = $vPos - $line_spacer;
974 my ( $hPos, $vPos, $font, $fontsize, $text ) = @_;
975 my $str = "BT /$font $fontsize Tf $hPos $vPos Td ($text) Tj ET";
980 sub DrawPatronCardText {
982 my ( $x_pos, $y_pos, $label_height, $label_width, $fontname, $fontsize, $left_text_margin,
983 $text_wrap_cols, $text, $printingtype )
986 my $top_text_margin = 25; #FIXME: This should be a template parameter and passed in...
988 my $vPos = ( $y_pos + ( $label_height - $top_text_margin ) );
989 my $font = prFont($fontname);
993 foreach my $line (keys %$text) {
994 warn "Current text is \"$line\" and font size for \"$line\" is $text->{$line} points";
995 # some code to try and center each line on the label based on font size and string point width...
996 my $stringwidth = prStrWidth($line, $fontname, $text->{$line});
997 my $whitespace = ( $label_width - ( $stringwidth + (2 * $left_text_margin) ) );
998 $hPos = ( ( $whitespace / 2 ) + $x_pos + $left_text_margin );
1000 PrintText( $hPos, $vPos, $font, $text->{$line}, $line );
1001 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.).
1002 $vPos = $vPos - ($line_spacer + $text->{$line}); # Linefeed equiv: leading + font size
1006 # Not used anywhere.
1010 # my ($fontsize) = @_;
1012 # my $str = "BT/F13 30 Tf288 720 Td( AAAAAAAAAA ) TjET";
1018 # x and y are from the top-left :)
1019 my ( $x_pos, $y_pos, $height, $width, $barcode, $barcodetype ) = @_;
1020 my $num_of_bars = length($barcode);
1021 my $bar_width = $width * .8; # %80 of length of label width
1024 my $guard_length = 10;
1027 if ( $barcodetype eq 'CODE39' ) {
1028 $bar_length = '17.5';
1030 ( $bar_length * $num_of_bars ) + ( $guard_length * 2 );
1031 $xsize_ratio = ( $bar_width / $tot_bar_length );
1033 PDF::Reuse::Barcode::Code39(
1034 x => ( $x_pos + ( $width / 10 ) ),
1035 y => ( $y_pos + ( $height / 10 ) ),
1036 value => "*$barcode*",
1037 ySize => ( .02 * $height ),
1038 xSize => $xsize_ratio,
1043 warn "$barcodetype, $barcode FAILED:$@";
1047 elsif ( $barcodetype eq 'CODE39MOD' ) {
1049 # get modulo43 checksum
1050 my $c39 = CheckDigits('code_39');
1051 $barcode = $c39->complete($barcode);
1055 ( $bar_length * $num_of_bars ) + ( $guard_length * 2 );
1056 $xsize_ratio = ( $bar_width / $tot_bar_length );
1058 PDF::Reuse::Barcode::Code39(
1059 x => ( $x_pos + ( $width / 10 ) ),
1060 y => ( $y_pos + ( $height / 10 ) ),
1061 value => "*$barcode*",
1062 ySize => ( .02 * $height ),
1063 xSize => $xsize_ratio,
1069 warn "$barcodetype, $barcode FAILED:$@";
1072 elsif ( $barcodetype eq 'CODE39MOD10' ) {
1074 # get modulo43 checksum
1075 my $c39_10 = CheckDigits('visa');
1076 $barcode = $c39_10->complete($barcode);
1080 ( $bar_length * $num_of_bars ) + ( $guard_length * 2 );
1081 $xsize_ratio = ( $bar_width / $tot_bar_length );
1083 PDF::Reuse::Barcode::Code39(
1084 x => ( $x_pos + ( $width / 10 ) ),
1085 y => ( $y_pos + ( $height / 10 ) ),
1086 value => "*$barcode*",
1087 ySize => ( .02 * $height ),
1088 xSize => $xsize_ratio,
1095 warn "$barcodetype, $barcode FAILED:$@";
1100 elsif ( $barcodetype eq 'COOP2OF5' ) {
1101 $bar_length = '9.43333333333333';
1103 ( $bar_length * $num_of_bars ) + ( $guard_length * 2 );
1104 $xsize_ratio = ( $bar_width / $tot_bar_length ) * .9;
1106 PDF::Reuse::Barcode::COOP2of5(
1107 x => ( $x_pos + ( $width / 10 ) ),
1108 y => ( $y_pos + ( $height / 10 ) ),
1110 ySize => ( .02 * $height ),
1111 xSize => $xsize_ratio,
1115 warn "$barcodetype, $barcode FAILED:$@";
1119 elsif ( $barcodetype eq 'INDUSTRIAL2OF5' ) {
1120 $bar_length = '13.1333333333333';
1122 ( $bar_length * $num_of_bars ) + ( $guard_length * 2 );
1123 $xsize_ratio = ( $bar_width / $tot_bar_length ) * .9;
1125 PDF::Reuse::Barcode::Industrial2of5(
1126 x => ( $x_pos + ( $width / 10 ) ),
1127 y => ( $y_pos + ( $height / 10 ) ),
1129 ySize => ( .02 * $height ),
1130 xSize => $xsize_ratio,
1134 warn "$barcodetype, $barcode FAILED:$@";
1138 my $moo2 = $tot_bar_length * $xsize_ratio;
1140 warn "$x_pos, $y_pos, $barcode, $barcodetype" if $DEBUG;
1141 warn "BAR_WDTH = $bar_width, TOT.BAR.LGHT=$tot_bar_length R*TOT.BAR =$moo2" if $DEBUG;
1144 =item build_circ_barcode;
1146 build_circ_barcode( $x_pos, $y_pos, $barcode,
1147 $barcodetype, \$item);
1149 $item is the result of a previous call to GetLabelItems();
1154 sub build_circ_barcode {
1155 my ( $x_pos_circ, $y_pos, $value, $barcodetype, $item ) = @_;
1157 #warn Dumper \$item;
1159 #warn "value = $value\n";
1163 if ( $barcodetype eq 'EAN13' ) {
1165 #testing EAN13 barcodes hack
1166 $value = $value . '000000000';
1168 $value = substr( $value, 0, 12 );
1172 PDF::Reuse::Barcode::EAN13(
1173 x => ( $x_pos_circ + 27 ),
1174 y => ( $y_pos + 15 ),
1182 # added for xpdf compat. doesnt use type3 fonts., but increases filesize from 20k to 200k
1183 # i think its embedding extra fonts in the pdf file.
1184 # mode => 'graphic',
1188 $item->{'barcodeerror'} = 1;
1190 #warn "EAN13BARCODE FAILED:$@";
1196 elsif ( $barcodetype eq 'Code39' ) {
1199 PDF::Reuse::Barcode::Code39(
1200 x => ( $x_pos_circ + 9 ),
1201 y => ( $y_pos + 15 ),
1211 $item->{'barcodeerror'} = 1;
1213 #warn "CODE39BARCODE $value FAILED:$@";
1220 elsif ( $barcodetype eq 'Matrix2of5' ) {
1222 #warn "MATRIX ELSE:";
1224 #testing MATRIX25 barcodes hack
1225 # $value = $value.'000000000';
1228 # $value = substr( $value, 0, 12 );
1232 PDF::Reuse::Barcode::Matrix2of5(
1233 x => ( $x_pos_circ + 27 ),
1234 y => ( $y_pos + 15 ),
1244 $item->{'barcodeerror'} = 1;
1246 #warn "BARCODE FAILED:$@";
1253 elsif ( $barcodetype eq 'EAN8' ) {
1255 #testing ean8 barcodes hack
1256 $value = $value . '000000000';
1258 $value = substr( $value, 0, 8 );
1262 #warn "EAN8 ELSEIF";
1264 PDF::Reuse::Barcode::EAN8(
1265 x => ( $x_pos_circ + 42 ),
1266 y => ( $y_pos + 15 ),
1276 $item->{'barcodeerror'} = 1;
1278 #warn "BARCODE FAILED:$@";
1285 elsif ( $barcodetype eq 'UPC-E' ) {
1287 PDF::Reuse::Barcode::UPCE(
1288 x => ( $x_pos_circ + 27 ),
1289 y => ( $y_pos + 15 ),
1299 $item->{'barcodeerror'} = 1;
1301 #warn "BARCODE FAILED:$@";
1307 elsif ( $barcodetype eq 'NW7' ) {
1309 PDF::Reuse::Barcode::NW7(
1310 x => ( $x_pos_circ + 27 ),
1311 y => ( $y_pos + 15 ),
1321 $item->{'barcodeerror'} = 1;
1323 #warn "BARCODE FAILED:$@";
1329 elsif ( $barcodetype eq 'ITF' ) {
1331 PDF::Reuse::Barcode::ITF(
1332 x => ( $x_pos_circ + 27 ),
1333 y => ( $y_pos + 15 ),
1343 $item->{'barcodeerror'} = 1;
1345 #warn "BARCODE FAILED:$@";
1351 elsif ( $barcodetype eq 'Industrial2of5' ) {
1353 PDF::Reuse::Barcode::Industrial2of5(
1354 x => ( $x_pos_circ + 27 ),
1355 y => ( $y_pos + 15 ),
1364 $item->{'barcodeerror'} = 1;
1366 #warn "BARCODE FAILED:$@";
1372 elsif ( $barcodetype eq 'IATA2of5' ) {
1374 PDF::Reuse::Barcode::IATA2of5(
1375 x => ( $x_pos_circ + 27 ),
1376 y => ( $y_pos + 15 ),
1385 $item->{'barcodeerror'} = 1;
1387 #warn "BARCODE FAILED:$@";
1394 elsif ( $barcodetype eq 'COOP2of5' ) {
1396 PDF::Reuse::Barcode::COOP2of5(
1397 x => ( $x_pos_circ + 27 ),
1398 y => ( $y_pos + 15 ),
1407 $item->{'barcodeerror'} = 1;
1409 #warn "BARCODE FAILED:$@";
1415 elsif ( $barcodetype eq 'UPC-A' ) {
1418 PDF::Reuse::Barcode::UPCA(
1419 x => ( $x_pos_circ + 27 ),
1420 y => ( $y_pos + 15 ),
1429 $item->{'barcodeerror'} = 1;
1431 #warn "BARCODE FAILED:$@";
1440 =item draw_boundaries
1442 sub draw_boundaries ($x_pos_spine, $x_pos_circ1, $x_pos_circ2,
1443 $y_pos, $spine_width, $label_height, $circ_width)
1445 This sub draws boundary lines where the label outlines are, to aid in printer testing, and debugging.
1450 sub draw_boundaries {
1453 $x_pos_spine, $x_pos_circ1, $x_pos_circ2, $y_pos,
1454 $spine_width, $label_height, $circ_width
1457 my $y_pos_initial = ( ( 792 - 36 ) - 90 );
1458 $y_pos = $y_pos_initial; # FIXME - why are we ignoring the y_pos parameter by redefining it?
1461 for ( $i = 1 ; $i <= 8 ; $i++ ) {
1463 &drawbox( $x_pos_spine, $y_pos, ($spine_width), ($label_height) );
1465 #warn "OLD BOXES x=$x_pos_spine, y=$y_pos, w=$spine_width, h=$label_height";
1466 &drawbox( $x_pos_circ1, $y_pos, ($circ_width), ($label_height) );
1467 &drawbox( $x_pos_circ2, $y_pos, ($circ_width), ($label_height) );
1469 $y_pos = ( $y_pos - $label_height );
1476 sub drawbox { $lower_left_x, $lower_left_y,
1477 $upper_right_x, $upper_right_y )
1479 this is a low level sub, that draws a pdf box, it is called by draw_boxes
1481 FYI: the $upper_right_x and $upper_right_y values are RELATIVE to $lower_left_x and $lower_left_y
1483 and $lower_left_x, $lower_left_y are ABSOLUTE, this caught me out!
1489 my ( $llx, $lly, $urx, $ury ) = @_;
1491 # warn "llx,y= $llx,$lly , urx,y=$urx,$ury \n";
1493 my $str = "q\n"; # save the graphic state
1494 $str .= "0.5 w\n"; # border color red
1495 $str .= "1.0 0.0 0.0 RG\n"; # border color red
1496 # $str .= "0.5 0.75 1.0 rg\n"; # fill color blue
1497 $str .= "1.0 1.0 1.0 rg\n"; # fill color white
1499 $str .= "$llx $lly $urx $ury re\n"; # a rectangle
1500 $str .= "B\n"; # fill (and a little more)
1501 $str .= "Q\n"; # save the graphic state
1507 END { } # module clean-up code here (global destructor)
1516 Mason James <mason@katipo.co.nz>