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) = @_;
153 # FIXME: hard coded print types
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" } );
159 push( @printtypes, { code
=> 'PATCRD', desc
=> "patron cards" } );
161 my $conf = get_layout
($layout_id);
162 my $active_printtype = $conf->{'printingtype'};
164 # lop thru layout, insert selected to hash
166 foreach my $printtype (@printtypes) {
167 if ( $printtype->{'code'} eq $active_printtype ) {
168 $printtype->{'active'} = 'MOO';
174 sub build_text_dropbox
{
177 # my @fields = get_text_fields();
178 # my $field_count = scalar @fields;
179 my $field_count = 10; # <----------- FIXME hard coded
183 ?
push( @lines, { num
=> '', selected
=> '1' } )
184 : push( @lines, { num
=> '' } );
185 for ( my $i = 1 ; $i <= $field_count ; $i++ ) {
186 my $line = { num
=> "$i" };
187 $line->{'selected'} = 1 if $i eq $order;
188 push( @lines, $line );
191 # add a blank row too
196 sub get_text_fields
{
197 my ($layout_id, $sorttype) = @_;
199 my ( $a, $b, $c, $d, $e, $f, $g, $h, $i ,$j, $k );
201 my $sortorder = get_layout
($layout_id);
208 order
=> $sortorder->{'itemtype'}
213 order
=> $sortorder->{'dewey'}
215 $c = { code
=> 'issn', desc
=> "ISSN",
216 order
=> $sortorder->{'issn'} };
217 $d = { code
=> 'isbn', desc
=> "ISBN",
218 order
=> $sortorder->{'isbn'} };
221 desc
=> "Classification",
222 order
=> $sortorder->{'class'}
227 order
=> $sortorder->{'subclass'}
232 order
=> $sortorder->{'barcode'}
235 { code
=> 'author', desc
=> "Author", order
=> $sortorder->{'author'} };
236 $i = { code
=> 'title', desc
=> "Title", order
=> $sortorder->{'title'} };
237 $j = { code
=> 'itemcallnumber', desc
=> "Call Number", order
=> $sortorder->{'itemcallnumber'} };
238 $k = { code
=> 'subtitle', desc
=> "Subtitle", order
=> $sortorder->{'subtitle'} };
240 my @text_fields = ( $a, $b, $c, $d, $e, $f, $g, $h, $i ,$j, $k );
243 foreach my $field (@text_fields) {
244 push( @new_fields, $field ) if $field->{'order'} > 0;
247 my @sorted_fields = sort by_order
@new_fields;
249 foreach my $field (@sorted_fields) {
250 $sorttype eq 'codes' ?
$active_fields .= "$field->{'code'} " :
251 $active_fields .= "$field->{'desc'} ";
253 return $active_fields;
258 $$a{order
} <=> $$b{order
};
263 add_batch($batch_type,\@batch_list);
264 if $batch_list is supplied,
265 create a new batch with those items.
266 else, return the next available batch_id.
270 my ( $batch_type,$batch_list ) = @_;
272 my $dbh = C4
::Context
->dbh;
273 my $q ="SELECT MAX(DISTINCT batch_id) FROM $batch_type";
274 my $sth = $dbh->prepare($q);
276 my ($batch_id) = $sth->fetchrow_array;
283 # TODO: let this block use $batch_type
284 if(ref($batch_list) && ($batch_type eq 'labels') ) {
285 my $sth = $dbh->prepare("INSERT INTO labels (`batch_id`,`itemnumber`) VALUES (?,?)");
286 for my $item (@
$batch_list) {
287 $sth->execute($batch_id,$item);
293 #FIXME: Needs to be ported to receive $batch_type
294 # ... this looks eerily like add_batch() ...
295 sub get_highest_batch
{
297 my $dbh = C4
::Context
->dbh;
299 "select distinct batch_id from labels order by batch_id desc limit 1";
300 my $sth = $dbh->prepare($q);
302 my $data = $sth->fetchrow_hashref;
305 if ( !$data->{'batch_id'} ) {
309 $new_batch = $data->{'batch_id'};
317 my ( $batch_type ) = @_;
318 my $dbh = C4
::Context
->dbh;
319 my $q = "SELECT batch_id, COUNT(*) AS num FROM $batch_type GROUP BY batch_id";
320 my $sth = $dbh->prepare($q);
323 while ( my $data = $sth->fetchrow_hashref ) {
324 push( @resultsloop, $data );
328 # Not sure why we are doing this rather than simply telling the user that no batches are currently defined.
329 # So I'm commenting this out and modifying label-manager.tmpl to properly inform the user as stated. -fbcit
330 # adding a dummy batch=1 value , if none exists in the db
331 # if ( !scalar(@resultsloop) ) {
332 # push( @resultsloop, { batch_id => '1' , num => '0' } );
338 my ($batch_id, $batch_type) = @_;
339 warn "Deleteing batch of type $batch_type";
340 my $dbh = C4
::Context
->dbh;
341 my $q = "DELETE FROM $batch_type WHERE batch_id = ?";
342 my $sth = $dbh->prepare($q);
343 $sth->execute($batch_id);
347 sub get_barcode_types
{
348 my ($layout_id) = @_;
349 my $layout = get_layout
($layout_id);
350 my $barcode = $layout->{'barcodetype'};
353 push( @array, { code
=> 'CODE39', desc
=> 'Code 39' } );
354 push( @array, { code
=> 'CODE39MOD', desc
=> 'Code39 + Modulo43' } );
355 push( @array, { code
=> 'CODE39MOD10', desc
=> 'Code39 + Modulo10' } );
356 push( @array, { code
=> 'ITF', desc
=> 'Interleaved 2 of 5' } );
358 foreach my $line (@array) {
359 if ( $line->{'code'} eq $barcode ) {
360 $line->{'active'} = 1;
371 $unitvalue = '1' if ( $units eq 'POINT' );
372 $unitvalue = '2.83464567' if ( $units eq 'MM' );
373 $unitvalue = '28.3464567' if ( $units eq 'CM' );
374 $unitvalue = 72 if ( $units eq 'INCH' );
378 sub GetTextWrapCols
{
379 my ( $font, $fontsize, $label_width, $left_text_margin ) = @_;
383 # my $textlimit = $label_width - ($left_text_margin);
384 my $textlimit = $label_width - ( 2* $left_text_margin);
386 while ( $strwidth < $textlimit ) {
387 $strwidth = prStrWidth
( $string, $font, $fontsize );
388 $string = $string . '0';
389 #warn "strwidth:$strwidth, textlimit:$textlimit, count:$count string:$string";
395 sub GetActiveLabelTemplate
{
396 my $dbh = C4
::Context
->dbh;
397 my $query = " SELECT * FROM labels_templates where active = 1 limit 1";
398 my $sth = $dbh->prepare($query);
400 my $active_tmpl = $sth->fetchrow_hashref;
405 sub GetSingleLabelTemplate
{
407 my $dbh = C4
::Context
->dbh;
408 my $query = " SELECT * FROM labels_templates where tmpl_id = ?";
409 my $sth = $dbh->prepare($query);
410 $sth->execute($tmpl_id);
411 my $template = $sth->fetchrow_hashref;
416 sub SetActiveTemplate
{
420 my $dbh = C4
::Context
->dbh;
421 my $query = " UPDATE labels_templates SET active = NULL";
422 my $sth = $dbh->prepare($query);
425 $query = "UPDATE labels_templates SET active = 1 WHERE tmpl_id = ?";
426 $sth = $dbh->prepare($query);
427 $sth->execute($tmpl_id);
431 sub set_active_layout
{
433 my ($layout_id) = @_;
434 my $dbh = C4
::Context
->dbh;
435 my $query = " UPDATE labels_conf SET active = NULL";
436 my $sth = $dbh->prepare($query);
439 $query = "UPDATE labels_conf SET active = 1 WHERE id = ?";
440 $sth = $dbh->prepare($query);
441 $sth->execute($layout_id);
447 my $dbh = C4
::Context
->dbh;
448 my $query = " DELETE FROM labels_templates where tmpl_id = ?";
449 my $sth = $dbh->prepare($query);
450 $sth->execute($tmpl_id);
456 $tmpl_id, $tmpl_code, $tmpl_desc, $page_width,
457 $page_height, $label_width, $label_height, $topmargin,
458 $leftmargin, $cols, $rows, $colgap,
459 $rowgap, $font, $fontsize, $units
461 warn "Passed \$font:$font";
462 my $dbh = C4
::Context
->dbh;
464 " UPDATE labels_templates SET tmpl_code=?, tmpl_desc=?, page_width=?,
465 page_height=?, label_width=?, label_height=?, topmargin=?,
466 leftmargin=?, cols=?, rows=?, colgap=?, rowgap=?, font=?, fontsize=?,
470 my $sth = $dbh->prepare($query);
472 $tmpl_code, $tmpl_desc, $page_width, $page_height,
473 $label_width, $label_height, $topmargin, $leftmargin,
474 $cols, $rows, $colgap, $rowgap,
475 $font, $fontsize, $units, $tmpl_id
477 my $dberror = $sth->errstr;
485 $tmpl_code, $tmpl_desc, $page_width, $page_height,
486 $label_width, $label_height, $topmargin, $leftmargin,
487 $cols, $rows, $colgap, $rowgap,
488 $font, $fontsize, $units
491 my $dbh = C4
::Context
->dbh;
493 my $query = "INSERT INTO labels_templates (tmpl_code, tmpl_desc, page_width,
494 page_height, label_width, label_height, topmargin,
495 leftmargin, cols, rows, colgap, rowgap, font, fontsize, units)
496 VALUES(?,?,?,?,?,?,?,?,?,?,?,?,?,?,?)";
498 my $sth = $dbh->prepare($query);
500 $tmpl_code, $tmpl_desc, $page_width, $page_height,
501 $label_width, $label_height, $topmargin, $leftmargin,
502 $cols, $rows, $colgap, $rowgap,
503 $font, $fontsize, $units
505 my $dberror = $sth->errstr;
510 sub GetAllLabelTemplates
{
511 my $dbh = C4
::Context
->dbh;
513 # get the actual items to be printed.
515 my $query = " Select * from labels_templates ";
516 my $sth = $dbh->prepare($query);
519 while ( my $data = $sth->fetchrow_hashref ) {
520 push( @resultsloop, $data );
524 #warn Dumper @resultsloop;
532 $barcodetype, $title, $subtitle, $isbn, $issn,
533 $itemtype, $bcn, $dcn, $classif,
534 $subclass, $itemcallnumber, $author, $tmpl_id,
535 $printingtype, $guidebox, $startlabel, $layoutname
538 my $dbh = C4
::Context
->dbh;
539 my $query2 = "update labels_conf set active = NULL";
540 my $sth2 = $dbh->prepare($query2);
542 $query2 = "INSERT INTO labels_conf
543 ( barcodetype, title, subtitle, isbn,issn, itemtype, barcode,
544 dewey, class, subclass, itemcallnumber, author, printingtype,
545 guidebox, startlabel, layoutname, active )
546 values ( ?, ?, ?, ?, ?, ?, ?, ?,?, ?, ?, ?, ?, ?,?,?, 1 )";
547 $sth2 = $dbh->prepare($query2);
549 $barcodetype, $title, $subtitle, $isbn, $issn,
551 $itemtype, $bcn, $dcn, $classif,
552 $subclass, $itemcallnumber, $author, $printingtype,
553 $guidebox, $startlabel, $layoutname
557 SetActiveTemplate
($tmpl_id);
564 $barcodetype, $title, $subtitle, $isbn, $issn,
565 $itemtype, $bcn, $dcn, $classif,
566 $subclass, $itemcallnumber, $author, $tmpl_id,
567 $printingtype, $guidebox, $startlabel, $layoutname,
573 my $dbh = C4
::Context
->dbh;
574 my $query2 = "update labels_conf set
575 barcodetype=?, title=?, subtitle=?, isbn=?,issn=?,
576 itemtype=?, barcode=?, dewey=?, class=?,
577 subclass=?, itemcallnumber=?, author=?, printingtype=?,
578 guidebox=?, startlabel=?, layoutname=? where id = ?";
579 my $sth2 = $dbh->prepare($query2);
581 $barcodetype, $title, $subtitle, $isbn, $issn,
582 $itemtype, $bcn, $dcn, $classif,
583 $subclass, $itemcallnumber, $author, $printingtype,
584 $guidebox, $startlabel, $layoutname, $layout_id
591 =item GetAllPrinterProfiles;
593 @profiles = GetAllPrinterProfiles()
595 Returns an array of references-to-hash, whos keys are .....
599 sub GetAllPrinterProfiles
{
601 my $dbh = C4
::Context
->dbh;
603 my $query = "SELECT * FROM printers_profile AS pp INNER JOIN labels_templates AS lt ON pp.tmpl_id = lt.tmpl_id; ";
604 my $sth = $dbh->prepare($query);
607 while ( my $data = $sth->fetchrow_hashref ) {
608 push( @resultsloop, $data );
615 =item GetSinglePrinterProfile;
617 $profile = GetSinglePrinterProfile()
619 Returns a hashref whos keys are...
623 sub GetSinglePrinterProfile
{
625 my $dbh = C4
::Context
->dbh;
626 my $query = " SELECT * FROM printers_profile WHERE prof_id = ?; ";
627 my $sth = $dbh->prepare($query);
628 $sth->execute($prof_id);
629 my $template = $sth->fetchrow_hashref;
636 SaveProfile('parameters')
638 When passed a set of parameters, this function updates the given profile with the new parameters.
644 $prof_id, $offset_horz, $offset_vert, $creep_horz, $creep_vert, $units
646 my $dbh = C4
::Context
->dbh;
648 " UPDATE printers_profile
649 SET offset_horz=?, offset_vert=?, creep_horz=?, creep_vert=?, unit=?
651 my $sth = $dbh->prepare($query);
653 $offset_horz, $offset_vert, $creep_horz, $creep_vert, $units, $prof_id
660 CreateProfile('parameters')
662 When passed a set of parameters, this function creates a new profile containing those parameters
663 and returns any errors.
669 $prof_id, $printername, $paper_bin, $tmpl_id, $offset_horz,
670 $offset_vert, $creep_horz, $creep_vert, $units
672 my $dbh = C4
::Context
->dbh;
674 " INSERT INTO printers_profile (prof_id, printername, paper_bin, tmpl_id,
675 offset_horz, offset_vert, creep_horz, creep_vert, unit)
676 VALUES(?,?,?,?,?,?,?,?,?) ";
677 my $sth = $dbh->prepare($query);
679 $prof_id, $printername, $paper_bin, $tmpl_id, $offset_horz,
680 $offset_vert, $creep_horz, $creep_vert, $units
682 my $error = $sth->errstr;
689 DeleteProfile(prof_id)
691 When passed a profile id, this function deletes that profile from the database and returns any errors.
697 my $dbh = C4
::Context
->dbh;
698 my $query = " DELETE FROM printers_profile WHERE prof_id = ?";
699 my $sth = $dbh->prepare($query);
700 $sth->execute($prof_id);
701 my $error = $sth->errstr;
706 =item GetAssociatedProfile;
708 $assoc_prof = GetAssociatedProfile(tmpl_id)
710 When passed a template id, this function returns the parameters from the currently associated printer profile
711 in a hashref where key=fieldname and value=fieldvalue.
715 sub GetAssociatedProfile
{
717 my $dbh = C4
::Context
->dbh;
718 # First we find out the prof_id for the associated profile...
719 my $query = "SELECT * FROM labels_profile WHERE tmpl_id = ?";
720 my $sth = $dbh->prepare($query);
721 $sth->execute($tmpl_id);
722 my $assoc_prof = $sth->fetchrow_hashref;
724 # Then we retrieve that profile and return it to the caller...
725 $assoc_prof = GetSinglePrinterProfile
($assoc_prof->{'prof_id'});
729 =item SetAssociatedProfile;
731 SetAssociatedProfile($prof_id, $tmpl_id)
733 When passed both a profile id and template id, this function establishes an association between the two. No more
734 than one profile may be associated with any given template at the same time.
738 sub SetAssociatedProfile
{
740 my ($prof_id, $tmpl_id) = @_;
742 my $dbh = C4
::Context
->dbh;
743 my $query = "INSERT INTO labels_profile (prof_id, tmpl_id) VALUES (?,?) ON DUPLICATE KEY UPDATE prof_id = ?";
744 my $sth = $dbh->prepare($query);
745 $sth->execute($prof_id, $tmpl_id, $prof_id);
751 $options = GetLabelItems()
753 Returns an array of references-to-hash, whos keys are the field from the biblio, biblioitems, items and labels tables in the Koha database.
760 my $dbh = C4
::Context
->dbh;
762 my @resultsloop = ();
768 my $query3 = "Select * from labels where batch_id = ? order by labelid ";
769 $sth = $dbh->prepare($query3);
770 $sth->execute($batch_id);
775 my $query3 = "Select * from labels";
776 $sth = $dbh->prepare($query3);
779 my $cnt = $sth->rows;
781 while ( my $data = $sth->fetchrow_hashref ) {
783 # lets get some summary info from each item
785 select i.*, bi.*, b.* from items i,biblioitems bi,biblio b
786 where itemnumber=? and i.biblioitemnumber=bi.biblioitemnumber and
787 bi.biblionumber=b.biblionumber";
789 my $sth1 = $dbh->prepare($query1);
790 $sth1->execute( $data->{'itemnumber'} );
792 my $data1 = $sth1->fetchrow_hashref();
793 $data1->{'labelno'} = $i1;
794 $data1->{'labelid'} = $data->{'labelid'};
795 $data1->{'batch_id'} = $batch_id;
796 $data1->{'summary'} =
797 "$data1->{'barcode'}, $data1->{'title'}, $data1->{'isbn'}";
799 push( @resultsloop, $data1 );
811 barcode title subtitle
812 dewey isbn issn author
class
813 itemtype subclass itemcallnumber
819 sub GetPatronCardItems
{
821 my ( $batch_id ) = @_;
824 my $dbh = C4
::Context
->dbh;
825 # my $query = "SELECT * FROM patroncards WHERE batch_id = ? ORDER BY borrowernumber";
826 my $query = "SELECT * FROM patroncards WHERE batch_id = ? ORDER BY cardid";
827 my $sth = $dbh->prepare($query);
828 $sth->execute($batch_id);
830 while ( my $data = $sth->fetchrow_hashref ) {
831 my $patron_data = GetMember
( $data->{'borrowernumber'} );
832 $patron_data->{'branchname'} = GetBranchName
( $patron_data->{'branchcode'} );
833 $patron_data->{'cardno'} = $cardno;
834 $patron_data->{'cardid'} = $data->{'cardid'};
835 $patron_data->{'batch_id'} = $batch_id;
836 push( @resultsloop, $patron_data );
844 sub deduplicate_batch
{
845 my ( $batch_id, $batch_type ) = @_;
848 batch_id," . (($batch_type eq 'labels') ?
'itemnumber' : 'borrowernumber') . ",
849 count(". (($batch_type eq 'labels') ?
'labelid' : 'cardid') . ") as count
852 GROUP BY " . (($batch_type eq 'labels') ?
'itemnumber' : 'borrowernumber') . ",batch_id
856 my $sth = C4
::Context
->dbh->prepare($query);
857 $sth->execute($batch_id);
858 warn $sth->errstr if $sth->errstr;
859 $sth->rows or return undef, $sth->errstr;
865 AND " . (($batch_type eq 'labels') ?
'itemnumber' : 'borrowernumber') . " = ?
866 ORDER BY timestamp ASC
869 while (my $data = $sth->fetchrow_hashref()) {
870 my $itemnumber = $data->{(($batch_type eq 'labels') ?
'itemnumber' : 'borrowernumber')} or next;
871 my $limit = $data->{count
} - 1 or next;
872 my $sth2 = C4
::Context
->dbh->prepare("$del_query LIMIT $limit");
873 # die sprintf "$del_query LIMIT %s\n (%s, %s)", $limit, $batch_id, $itemnumber;
874 # $sth2->execute($batch_id, C4::Context->dbh->quote($data->{itemnumber}), $data->{count} - 1)
875 $sth2->execute($batch_id, $itemnumber) and
876 $killed += ($data->{count
} - 1);
877 warn $sth2->errstr if $sth2->errstr;
879 return $killed, undef;
884 my ( $x_pos, $y_pos, $label_height, $label_width, $fontname, $fontsize, $left_text_margin,
885 $text_wrap_cols, $item, $conf_data, $printingtype )
887 # hack to fix column name mismatch betwen labels_conf.class, and bibitems.classification
888 $$item->{'class'} = $$item->{'classification'};
890 $Text::Wrap
::columns
= $text_wrap_cols;
891 $Text::Wrap
::separator
= "\n";
895 my $top_text_margin = ( $fontsize + 3 ); #FIXME: This should be a template parameter and passed in...
896 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.).
898 # add your printable fields manually in here
900 my $layout_id = $$conf_data->{'id'};
902 # my @fields = GetItemFields();
904 my $str_fields = get_text_fields
($layout_id, 'codes' );
905 my @fields = split(/ /, $str_fields);
906 #warn Dumper(@fields);
908 my $vPos = ( $y_pos + ( $label_height - $top_text_margin ) );
909 my $font = prFont
($fontname);
911 # warn Dumper $conf_data;
914 foreach my $field (@fields) {
917 # $$item->{"$field"} = $field . ": " . $$item->{"$field"};
919 # if the display option for this field is selected in the DB,
920 # and the item record has some values for this field, display it.
921 if ( $$conf_data->{"$field"} && $$item->{"$field"} ) {
923 # warn "CONF_TYPE = $field";
926 $str = $$item->{"$field"};
927 # strip out naughty existing nl/cr's
930 # wrap lines based on call number dividers '/'
933 while ( $str =~ /\// ) {
934 $str =~ /^(.*)\/(.*)$/;
937 unshift @strings, $2;
941 unshift @strings, $str;
943 # strip out division slashes
945 #warn "\$str after striping division marks: $str";
946 # chop the string up into _upto_ 12 chunks
947 # and seperate the chunks with newlines
949 #$str = wrap( "", "", "$str" );
950 #$str = wrap( "", "", "$str" );
952 # split the chunks between newline's, into an array
953 #my @strings = split /\n/, $str;
955 # then loop for each string line
956 foreach my $str (@strings) {
958 if ( $printingtype eq 'BIB' ) { #FIXME: This is a hack and needs to be implimented as a text justification option in the template...
959 # some code to try and center each line on the label based on font size and string point width...
960 my $stringwidth = prStrWidth
($str, $fontname, $fontsize);
961 my $whitespace = ( $label_width - ( $stringwidth + (2 * $left_text_margin) ) );
962 $hPos = ( ( $whitespace / 2 ) + $x_pos + $left_text_margin );
963 #warn "\$label_width=$label_width \$stringwidth=$stringwidth \$whitespace=$whitespace \$left_text_margin=$left_text_margin for $str\n";
965 $hPos = ( $x_pos + $left_text_margin );
967 PrintText
( $hPos, $vPos, $font, $fontsize, $str );
968 $vPos = $vPos - $line_spacer;
976 my ( $hPos, $vPos, $font, $fontsize, $text ) = @_;
977 my $str = "BT /$font $fontsize Tf $hPos $vPos Td ($text) Tj ET";
982 sub DrawPatronCardText
{
984 my ( $x_pos, $y_pos, $label_height, $label_width, $fontname, $fontsize, $left_text_margin,
985 $text_wrap_cols, $text, $printingtype )
988 my $top_text_margin = 25; #FIXME: This should be a template parameter and passed in...
990 my $vPos = ( $y_pos + ( $label_height - $top_text_margin ) );
991 my $font = prFont
($fontname);
995 foreach my $line (keys %$text) {
996 warn "Current text is \"$line\" and font size for \"$line\" is $text->{$line} points";
997 # some code to try and center each line on the label based on font size and string point width...
998 my $stringwidth = prStrWidth
($line, $fontname, $text->{$line});
999 my $whitespace = ( $label_width - ( $stringwidth + (2 * $left_text_margin) ) );
1000 $hPos = ( ( $whitespace / 2 ) + $x_pos + $left_text_margin );
1002 PrintText
( $hPos, $vPos, $font, $text->{$line}, $line );
1003 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.).
1004 $vPos = $vPos - ($line_spacer + $text->{$line}); # Linefeed equiv: leading + font size
1008 # Not used anywhere.
1012 # my ($fontsize) = @_;
1014 # my $str = "BT/F13 30 Tf288 720 Td( AAAAAAAAAA ) TjET";
1020 # x and y are from the top-left :)
1021 my ( $x_pos, $y_pos, $height, $width, $barcode, $barcodetype ) = @_;
1022 my $num_of_bars = length($barcode);
1023 my $bar_width = $width * .8; # %80 of length of label width
1026 my $guard_length = 10;
1029 if ( $barcodetype eq 'CODE39' ) {
1030 $bar_length = '17.5';
1032 ( $bar_length * $num_of_bars ) + ( $guard_length * 2 );
1033 $xsize_ratio = ( $bar_width / $tot_bar_length );
1035 PDF
::Reuse
::Barcode
::Code39
(
1036 x
=> ( $x_pos + ( $width / 10 ) ),
1037 y
=> ( $y_pos + ( $height / 10 ) ),
1038 value
=> "*$barcode*",
1039 ySize
=> ( .02 * $height ),
1040 xSize
=> $xsize_ratio,
1045 warn "$barcodetype, $barcode FAILED:$@";
1049 elsif ( $barcodetype eq 'CODE39MOD' ) {
1051 # get modulo43 checksum
1052 my $c39 = CheckDigits
('code_39');
1053 $barcode = $c39->complete($barcode);
1057 ( $bar_length * $num_of_bars ) + ( $guard_length * 2 );
1058 $xsize_ratio = ( $bar_width / $tot_bar_length );
1060 PDF
::Reuse
::Barcode
::Code39
(
1061 x
=> ( $x_pos + ( $width / 10 ) ),
1062 y
=> ( $y_pos + ( $height / 10 ) ),
1063 value
=> "*$barcode*",
1064 ySize
=> ( .02 * $height ),
1065 xSize
=> $xsize_ratio,
1071 warn "$barcodetype, $barcode FAILED:$@";
1074 elsif ( $barcodetype eq 'CODE39MOD10' ) {
1076 # get modulo43 checksum
1077 my $c39_10 = CheckDigits
('visa');
1078 $barcode = $c39_10->complete($barcode);
1082 ( $bar_length * $num_of_bars ) + ( $guard_length * 2 );
1083 $xsize_ratio = ( $bar_width / $tot_bar_length );
1085 PDF
::Reuse
::Barcode
::Code39
(
1086 x
=> ( $x_pos + ( $width / 10 ) ),
1087 y
=> ( $y_pos + ( $height / 10 ) ),
1088 value
=> "*$barcode*",
1089 ySize
=> ( .02 * $height ),
1090 xSize
=> $xsize_ratio,
1097 warn "$barcodetype, $barcode FAILED:$@";
1102 elsif ( $barcodetype eq 'COOP2OF5' ) {
1103 $bar_length = '9.43333333333333';
1105 ( $bar_length * $num_of_bars ) + ( $guard_length * 2 );
1106 $xsize_ratio = ( $bar_width / $tot_bar_length ) * .9;
1108 PDF
::Reuse
::Barcode
::COOP2of5
(
1109 x
=> ( $x_pos + ( $width / 10 ) ),
1110 y
=> ( $y_pos + ( $height / 10 ) ),
1112 ySize
=> ( .02 * $height ),
1113 xSize
=> $xsize_ratio,
1117 warn "$barcodetype, $barcode FAILED:$@";
1121 elsif ( $barcodetype eq 'INDUSTRIAL2OF5' ) {
1122 $bar_length = '13.1333333333333';
1124 ( $bar_length * $num_of_bars ) + ( $guard_length * 2 );
1125 $xsize_ratio = ( $bar_width / $tot_bar_length ) * .9;
1127 PDF
::Reuse
::Barcode
::Industrial2of5
(
1128 x
=> ( $x_pos + ( $width / 10 ) ),
1129 y
=> ( $y_pos + ( $height / 10 ) ),
1131 ySize
=> ( .02 * $height ),
1132 xSize
=> $xsize_ratio,
1136 warn "$barcodetype, $barcode FAILED:$@";
1140 my $moo2 = $tot_bar_length * $xsize_ratio;
1142 warn "$x_pos, $y_pos, $barcode, $barcodetype" if $DEBUG;
1143 warn "BAR_WDTH = $bar_width, TOT.BAR.LGHT=$tot_bar_length R*TOT.BAR =$moo2" if $DEBUG;
1146 =item build_circ_barcode;
1148 build_circ_barcode( $x_pos, $y_pos, $barcode,
1149 $barcodetype, \$item);
1151 $item is the result of a previous call to GetLabelItems();
1156 sub build_circ_barcode
{
1157 my ( $x_pos_circ, $y_pos, $value, $barcodetype, $item ) = @_;
1159 #warn Dumper \$item;
1161 #warn "value = $value\n";
1165 if ( $barcodetype eq 'EAN13' ) {
1167 #testing EAN13 barcodes hack
1168 $value = $value . '000000000';
1170 $value = substr( $value, 0, 12 );
1174 PDF
::Reuse
::Barcode
::EAN13
(
1175 x
=> ( $x_pos_circ + 27 ),
1176 y
=> ( $y_pos + 15 ),
1184 # added for xpdf compat. doesnt use type3 fonts., but increases filesize from 20k to 200k
1185 # i think its embedding extra fonts in the pdf file.
1186 # mode => 'graphic',
1190 $item->{'barcodeerror'} = 1;
1192 #warn "EAN13BARCODE FAILED:$@";
1198 elsif ( $barcodetype eq 'Code39' ) {
1201 PDF
::Reuse
::Barcode
::Code39
(
1202 x
=> ( $x_pos_circ + 9 ),
1203 y
=> ( $y_pos + 15 ),
1213 $item->{'barcodeerror'} = 1;
1215 #warn "CODE39BARCODE $value FAILED:$@";
1222 elsif ( $barcodetype eq 'Matrix2of5' ) {
1224 #warn "MATRIX ELSE:";
1226 #testing MATRIX25 barcodes hack
1227 # $value = $value.'000000000';
1230 # $value = substr( $value, 0, 12 );
1234 PDF
::Reuse
::Barcode
::Matrix2of5
(
1235 x
=> ( $x_pos_circ + 27 ),
1236 y
=> ( $y_pos + 15 ),
1246 $item->{'barcodeerror'} = 1;
1248 #warn "BARCODE FAILED:$@";
1255 elsif ( $barcodetype eq 'EAN8' ) {
1257 #testing ean8 barcodes hack
1258 $value = $value . '000000000';
1260 $value = substr( $value, 0, 8 );
1264 #warn "EAN8 ELSEIF";
1266 PDF
::Reuse
::Barcode
::EAN8
(
1267 x
=> ( $x_pos_circ + 42 ),
1268 y
=> ( $y_pos + 15 ),
1278 $item->{'barcodeerror'} = 1;
1280 #warn "BARCODE FAILED:$@";
1287 elsif ( $barcodetype eq 'UPC-E' ) {
1289 PDF
::Reuse
::Barcode
::UPCE
(
1290 x
=> ( $x_pos_circ + 27 ),
1291 y
=> ( $y_pos + 15 ),
1301 $item->{'barcodeerror'} = 1;
1303 #warn "BARCODE FAILED:$@";
1309 elsif ( $barcodetype eq 'NW7' ) {
1311 PDF
::Reuse
::Barcode
::NW7
(
1312 x
=> ( $x_pos_circ + 27 ),
1313 y
=> ( $y_pos + 15 ),
1323 $item->{'barcodeerror'} = 1;
1325 #warn "BARCODE FAILED:$@";
1331 elsif ( $barcodetype eq 'ITF' ) {
1333 PDF
::Reuse
::Barcode
::ITF
(
1334 x
=> ( $x_pos_circ + 27 ),
1335 y
=> ( $y_pos + 15 ),
1345 $item->{'barcodeerror'} = 1;
1347 #warn "BARCODE FAILED:$@";
1353 elsif ( $barcodetype eq 'Industrial2of5' ) {
1355 PDF
::Reuse
::Barcode
::Industrial2of5
(
1356 x
=> ( $x_pos_circ + 27 ),
1357 y
=> ( $y_pos + 15 ),
1366 $item->{'barcodeerror'} = 1;
1368 #warn "BARCODE FAILED:$@";
1374 elsif ( $barcodetype eq 'IATA2of5' ) {
1376 PDF
::Reuse
::Barcode
::IATA2of5
(
1377 x
=> ( $x_pos_circ + 27 ),
1378 y
=> ( $y_pos + 15 ),
1387 $item->{'barcodeerror'} = 1;
1389 #warn "BARCODE FAILED:$@";
1396 elsif ( $barcodetype eq 'COOP2of5' ) {
1398 PDF
::Reuse
::Barcode
::COOP2of5
(
1399 x
=> ( $x_pos_circ + 27 ),
1400 y
=> ( $y_pos + 15 ),
1409 $item->{'barcodeerror'} = 1;
1411 #warn "BARCODE FAILED:$@";
1417 elsif ( $barcodetype eq 'UPC-A' ) {
1420 PDF
::Reuse
::Barcode
::UPCA
(
1421 x
=> ( $x_pos_circ + 27 ),
1422 y
=> ( $y_pos + 15 ),
1431 $item->{'barcodeerror'} = 1;
1433 #warn "BARCODE FAILED:$@";
1442 =item draw_boundaries
1444 sub draw_boundaries ($x_pos_spine, $x_pos_circ1, $x_pos_circ2,
1445 $y_pos, $spine_width, $label_height, $circ_width)
1447 This sub draws boundary lines where the label outlines are, to aid in printer testing, and debugging.
1452 sub draw_boundaries
{
1455 $x_pos_spine, $x_pos_circ1, $x_pos_circ2, $y_pos,
1456 $spine_width, $label_height, $circ_width
1459 my $y_pos_initial = ( ( 792 - 36 ) - 90 );
1460 $y_pos = $y_pos_initial; # FIXME - why are we ignoring the y_pos parameter by redefining it?
1463 for ( $i = 1 ; $i <= 8 ; $i++ ) {
1465 &drawbox
( $x_pos_spine, $y_pos, ($spine_width), ($label_height) );
1467 #warn "OLD BOXES x=$x_pos_spine, y=$y_pos, w=$spine_width, h=$label_height";
1468 &drawbox
( $x_pos_circ1, $y_pos, ($circ_width), ($label_height) );
1469 &drawbox
( $x_pos_circ2, $y_pos, ($circ_width), ($label_height) );
1471 $y_pos = ( $y_pos - $label_height );
1478 sub drawbox { $lower_left_x, $lower_left_y,
1479 $upper_right_x, $upper_right_y )
1481 this is a low level sub, that draws a pdf box, it is called by draw_boxes
1483 FYI: the $upper_right_x and $upper_right_y values are RELATIVE to $lower_left_x and $lower_left_y
1485 and $lower_left_x, $lower_left_y are ABSOLUTE, this caught me out!
1491 my ( $llx, $lly, $urx, $ury ) = @_;
1493 # warn "llx,y= $llx,$lly , urx,y=$urx,$ury \n";
1495 my $str = "q\n"; # save the graphic state
1496 $str .= "0.5 w\n"; # border color red
1497 $str .= "1.0 0.0 0.0 RG\n"; # border color red
1498 # $str .= "0.5 0.75 1.0 rg\n"; # fill color blue
1499 $str .= "1.0 1.0 1.0 rg\n"; # fill color white
1501 $str .= "$llx $lly $urx $ury re\n"; # a rectangle
1502 $str .= "B\n"; # fill (and a little more)
1503 $str .= "Q\n"; # save the graphic state
1509 END { } # module clean-up code here (global destructor)
1518 Mason James <mason@katipo.co.nz>