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;
32 # use Smart::Comments;
39 &get_label_options &GetLabelItems
40 &build_circ_barcode &draw_boundaries
41 &drawbox &GetActiveLabelTemplate
42 &GetAllLabelTemplates &DeleteTemplate
43 &GetSingleLabelTemplate &SaveTemplate
44 &CreateTemplate &SetActiveTemplate
45 &SaveConf &DrawSpineText &GetTextWrapCols
46 &GetUnitsValue &DrawBarcode &DrawPatronCardText
47 &get_printingtypes &GetPatronCardItems
50 &get_batches &delete_batch
54 get_layout &save_layout &add_layout
57 &delete_layout &get_active_layout
60 &GetAllPrinterProfiles &GetSinglePrinterProfile
61 &SaveProfile &CreateProfile &DeleteProfile
62 &GetAssociatedProfile &SetAssociatedProfile
69 C4::Labels - Functions for printing spine labels and barcodes in Koha
75 =item get_label_options;
77 $options = get_label_options()
79 Return a pointer on a hash list containing info from labels_conf table in Koha DB.
84 sub get_label_options {
85 my $query2 = " SELECT * FROM labels_conf where active = 1"; # FIXME: exact same as get_active_layout
86 my $sth = C4::Context->dbh->prepare($query2);
88 return $sth->fetchrow_hashref;
93 ## FIXME: this if/else could be compacted...
94 my $dbh = C4::Context->dbh;
96 my $query = " Select * from labels_conf";
97 my $sth = $dbh->prepare($query);
100 while ( my $data = $sth->fetchrow_hashref ) {
102 $data->{'fieldlist'} = get_text_fields( $data->{'id'} );
103 push( @resultsloop, $data );
113 my ($layout_id) = @_;
114 my $dbh = C4::Context->dbh;
116 # get the actual items to be printed.
117 my $query = " Select * from labels_conf where id = ?";
118 my $sth = $dbh->prepare($query);
119 $sth->execute($layout_id);
120 my $data = $sth->fetchrow_hashref;
125 sub get_active_layout {
126 my $query = " Select * from labels_conf where active = 1"; # FIXME: exact same as get_label_options
127 my $sth = C4::Context->dbh->prepare($query);
129 return $sth->fetchrow_hashref;
133 my ($layout_id) = @_;
134 my $dbh = C4::Context->dbh;
136 # get the actual items to be printed.
137 my $query = "delete from labels_conf where id = ?";
138 my $sth = $dbh->prepare($query);
139 $sth->execute($layout_id);
143 sub get_printingtypes {
144 my ($layout_id) = @_;
146 # FIXME: hard coded print types
147 push( @printtypes, { code => 'BAR', desc => "barcode only" } );
148 push( @printtypes, { code => 'BIB', desc => "biblio only" } );
149 push( @printtypes, { code => 'BARBIB', desc => "barcode / biblio" } );
150 push( @printtypes, { code => 'BIBBAR', desc => "biblio / barcode" } );
151 push( @printtypes, { code => 'ALT', desc => "alternating labels" } );
152 push( @printtypes, { code => 'CSV', desc => "csv output" } );
153 push( @printtypes, { code => 'PATCRD', desc => "patron cards" } );
155 my $conf = get_layout($layout_id);
156 my $active_printtype = $conf->{'printingtype'};
158 # lop thru layout, insert selected to hash
160 foreach my $printtype (@printtypes) {
161 if ( $printtype->{'code'} eq $active_printtype ) {
162 $printtype->{'active'} = 1;
168 # this sub (build_text_dropbox) is deprecated and should be deleted.
171 sub build_text_dropbox {
174 # my @fields = get_text_fields();
175 # my $field_count = scalar @fields;
176 my $field_count = 10; # <----------- FIXME hard coded
180 ? push( @lines, { num => '', selected => '1' } )
181 : push( @lines, { num => '' } );
182 for ( my $i = 1 ; $i <= $field_count ; $i++ ) {
183 my $line = { num => "$i" };
184 $line->{'selected'} = 1 if $i eq $order;
185 push( @lines, $line );
188 # add a blank row too
193 sub get_text_fields {
194 my ($layout_id, $sorttype) = @_;
197 my $sortorder = get_layout($layout_id);
198 if( $sortorder->{formatstring}) {
200 return $sortorder->{formatstring} ;
202 my $csv = Text::CSV_XS->new( { allow_whitespace => 1 } ) ;
203 my $line= $sortorder->{formatstring} ;
204 my $status = $csv->parse( $line );
205 @sorted_fields = map {{ 'code' => $_ , desc => $_ } } $csv->fields() ;
206 $error = $csv->error_input();
207 warn $error if $error ; # TODO - do more with this.
210 # These fields are hardcoded based on the template for label-edit-layout.pl
215 order => $sortorder->{'itemtype'}
220 order => $sortorder->{'dewey'}
225 order => $sortorder->{'issn'}
230 order => $sortorder->{'isbn'}
234 desc => "Classification",
235 order => $sortorder->{'class'}
240 order => $sortorder->{'subclass'}
245 order => $sortorder->{'barcode'}
250 order => $sortorder->{'author'}
255 order => $sortorder->{'title'}
258 code => 'itemcallnumber',
259 desc => "Call Number",
260 order => $sortorder->{'itemcallnumber'}
265 order => $sortorder->{'subtitle'}
271 foreach my $field (@text_fields) {
272 push( @new_fields, $field ) if $field->{'order'} > 0;
275 @sorted_fields = sort { $$a{order} <=> $$b{order} } @new_fields;
277 # if we have a 'formatstring', then we ignore these hardcoded fields.
280 if ($sorttype eq 'codes') { # FIXME: This sub should really always return the array of hashrefs and let the caller take what he wants from that -fbcit
281 return @sorted_fields;
283 foreach my $field (@sorted_fields) {
284 $active_fields .= "$field->{'desc'} ";
286 return $active_fields;
293 add_batch($batch_type,\@batch_list);
294 if $batch_list is supplied,
295 create a new batch with those items.
296 else, return the next available batch_id.
300 my ( $batch_type,$batch_list ) = @_;
302 my $dbh = C4::Context->dbh;
303 my $q ="SELECT MAX(DISTINCT batch_id) FROM $batch_type";
304 my $sth = $dbh->prepare($q);
306 my ($batch_id) = $sth->fetchrow_array;
313 # TODO: let this block use $batch_type
314 if(ref($batch_list) && ($batch_type eq 'labels') ) {
315 my $sth = $dbh->prepare("INSERT INTO labels (`batch_id`,`itemnumber`) VALUES (?,?)");
316 for my $item (@$batch_list) {
317 $sth->execute($batch_id,$item);
323 #FIXME: Needs to be ported to receive $batch_type
324 # ... this looks eerily like add_batch() ...
325 sub get_highest_batch {
327 my $dbh = C4::Context->dbh;
329 "select distinct batch_id from labels order by batch_id desc limit 1";
330 my $sth = $dbh->prepare($q);
332 my $data = $sth->fetchrow_hashref;
335 if ( !$data->{'batch_id'} ) {
339 $new_batch = $data->{'batch_id'};
347 # my $q = "SELECT batch_id, COUNT(*) AS num FROM " . shift . " GROUP BY batch_id";
348 # FIXEDME: There is only ONE table with batch_id, so why try to select a different one?
349 # get_batches() was frequently being called w/ no args, crashing DBD
350 my $q = "SELECT batch_id, COUNT(*) AS num FROM labels GROUP BY batch_id";
351 my $sth = C4::Context->dbh->prepare($q);
353 my $batches = $sth->fetchall_arrayref({});
358 my ($batch_id, $batch_type) = @_;
359 warn "Deleteing batch of type $batch_type";
360 my $dbh = C4::Context->dbh;
361 my $q = "DELETE FROM $batch_type WHERE batch_id = ?";
362 my $sth = $dbh->prepare($q);
363 $sth->execute($batch_id);
367 sub get_barcode_types {
368 my ($layout_id) = @_;
369 my $layout = get_layout($layout_id);
370 my $barcode = $layout->{'barcodetype'};
373 push( @array, { code => 'CODE39', desc => 'Code 39' } );
374 push( @array, { code => 'CODE39MOD', desc => 'Code39 + Modulo43' } );
375 push( @array, { code => 'CODE39MOD10', desc => 'Code39 + Modulo10' } );
376 push( @array, { code => 'ITF', desc => 'Interleaved 2 of 5' } );
378 foreach my $line (@array) {
379 if ( $line->{'code'} eq $barcode ) {
380 $line->{'active'} = 1;
391 $unitvalue = '1' if ( $units eq 'POINT' );
392 $unitvalue = '2.83464567' if ( $units eq 'MM' );
393 $unitvalue = '28.3464567' if ( $units eq 'CM' );
394 $unitvalue = 72 if ( $units eq 'INCH' );
398 sub GetTextWrapCols {
399 my ( $font, $fontsize, $label_width, $left_text_margin ) = @_;
403 # my $textlimit = $label_width - ($left_text_margin);
404 my $textlimit = $label_width - ( 3 * $left_text_margin);
406 while ( $strwidth < $textlimit ) {
407 $strwidth = prStrWidth( $string, $font, $fontsize );
408 $string = $string . '0';
409 #warn "strwidth:$strwidth, textlimit:$textlimit, count:$count string:$string";
415 sub GetActiveLabelTemplate {
416 my $dbh = C4::Context->dbh;
417 my $query = " SELECT * FROM labels_templates where active = 1 limit 1";
418 my $sth = $dbh->prepare($query);
420 my $active_tmpl = $sth->fetchrow_hashref;
425 sub GetSingleLabelTemplate {
427 my $dbh = C4::Context->dbh;
428 my $query = " SELECT * FROM labels_templates where tmpl_id = ?";
429 my $sth = $dbh->prepare($query);
430 $sth->execute($tmpl_id);
431 my $template = $sth->fetchrow_hashref;
436 sub SetActiveTemplate {
440 my $dbh = C4::Context->dbh;
441 my $query = " UPDATE labels_templates SET active = NULL";
442 my $sth = $dbh->prepare($query);
445 $query = "UPDATE labels_templates SET active = 1 WHERE tmpl_id = ?";
446 $sth = $dbh->prepare($query);
447 $sth->execute($tmpl_id);
451 sub set_active_layout {
453 my ($layout_id) = @_;
454 my $dbh = C4::Context->dbh;
455 my $query = " UPDATE labels_conf SET active = NULL";
456 my $sth = $dbh->prepare($query);
459 $query = "UPDATE labels_conf SET active = 1 WHERE id = ?";
460 $sth = $dbh->prepare($query);
461 $sth->execute($layout_id);
467 my $dbh = C4::Context->dbh;
468 my $query = " DELETE FROM labels_templates where tmpl_id = ?";
469 my $sth = $dbh->prepare($query);
470 $sth->execute($tmpl_id);
476 $tmpl_id, $tmpl_code, $tmpl_desc, $page_width,
477 $page_height, $label_width, $label_height, $topmargin,
478 $leftmargin, $cols, $rows, $colgap,
479 $rowgap, $font, $fontsize, $units
481 $debug and warn "Passed \$font:$font";
482 my $dbh = C4::Context->dbh;
484 " UPDATE labels_templates SET tmpl_code=?, tmpl_desc=?, page_width=?,
485 page_height=?, label_width=?, label_height=?, topmargin=?,
486 leftmargin=?, cols=?, rows=?, colgap=?, rowgap=?, font=?, fontsize=?,
490 my $sth = $dbh->prepare($query);
492 $tmpl_code, $tmpl_desc, $page_width, $page_height,
493 $label_width, $label_height, $topmargin, $leftmargin,
494 $cols, $rows, $colgap, $rowgap,
495 $font, $fontsize, $units, $tmpl_id
497 my $dberror = $sth->errstr;
505 $tmpl_code, $tmpl_desc, $page_width, $page_height,
506 $label_width, $label_height, $topmargin, $leftmargin,
507 $cols, $rows, $colgap, $rowgap,
508 $font, $fontsize, $units
511 my $dbh = C4::Context->dbh;
513 my $query = "INSERT INTO labels_templates (tmpl_code, tmpl_desc, page_width,
514 page_height, label_width, label_height, topmargin,
515 leftmargin, cols, rows, colgap, rowgap, font, fontsize, units)
516 VALUES(?,?,?,?,?,?,?,?,?,?,?,?,?,?,?)";
518 my $sth = $dbh->prepare($query);
520 $tmpl_code, $tmpl_desc, $page_width, $page_height,
521 $label_width, $label_height, $topmargin, $leftmargin,
522 $cols, $rows, $colgap, $rowgap,
523 $font, $fontsize, $units
525 my $dberror = $sth->errstr;
530 sub GetAllLabelTemplates {
531 my $dbh = C4::Context->dbh;
533 # get the actual items to be printed.
535 my $query = " Select * from labels_templates ";
536 my $sth = $dbh->prepare($query);
539 while ( my $data = $sth->fetchrow_hashref ) {
540 push( @resultsloop, $data );
544 #warn Dumper @resultsloop;
552 $barcodetype, $title, $subtitle, $isbn, $issn,
553 $itemtype, $bcn, $dcn, $classif,
554 $subclass, $itemcallnumber, $author, $tmpl_id,
555 $printingtype, $guidebox, $startlabel, $layoutname, $formatstring
558 my $dbh = C4::Context->dbh;
559 my $query2 = "update labels_conf set active = NULL";
560 my $sth2 = $dbh->prepare($query2);
562 $query2 = "INSERT INTO labels_conf
563 ( barcodetype, title, subtitle, isbn,issn, itemtype, barcode,
564 dewey, classification, subclass, itemcallnumber, author, printingtype,
565 guidebox, startlabel, layoutname, formatstring, active )
566 values ( ?, ?,?, ?, ?, ?, ?, ?, ?,?, ?, ?, ?, ?, ?,?,?, 1 )";
567 $sth2 = $dbh->prepare($query2);
569 $barcodetype, $title, $subtitle, $isbn, $issn,
571 $itemtype, $bcn, $dcn, $classif,
572 $subclass, $itemcallnumber, $author, $printingtype,
573 $guidebox, $startlabel, $layoutname, $formatstring
577 SetActiveTemplate($tmpl_id);
584 $barcodetype, $title, $subtitle, $isbn, $issn,
585 $itemtype, $bcn, $dcn, $classif,
586 $subclass, $itemcallnumber, $author, $tmpl_id,
587 $printingtype, $guidebox, $startlabel, $layoutname, $formatstring,
593 my $dbh = C4::Context->dbh;
594 my $query2 = "update labels_conf set
595 barcodetype=?, title=?, subtitle=?, isbn=?,issn=?,
596 itemtype=?, barcode=?, dewey=?, classification=?,
597 subclass=?, itemcallnumber=?, author=?, printingtype=?,
598 guidebox=?, startlabel=?, layoutname=?, formatstring=? where id = ?";
599 my $sth2 = $dbh->prepare($query2);
601 $barcodetype, $title, $subtitle, $isbn, $issn,
602 $itemtype, $bcn, $dcn, $classif,
603 $subclass, $itemcallnumber, $author, $printingtype,
604 $guidebox, $startlabel, $layoutname, $formatstring, $layout_id
611 =item GetAllPrinterProfiles;
613 @profiles = GetAllPrinterProfiles()
615 Returns an array of references-to-hash, whos keys are .....
619 sub GetAllPrinterProfiles {
621 my $dbh = C4::Context->dbh;
623 my $query = "SELECT * FROM printers_profile AS pp INNER JOIN labels_templates AS lt ON pp.tmpl_id = lt.tmpl_id; ";
624 my $sth = $dbh->prepare($query);
627 while ( my $data = $sth->fetchrow_hashref ) {
628 push( @resultsloop, $data );
635 =item GetSinglePrinterProfile;
637 $profile = GetSinglePrinterProfile()
639 Returns a hashref whos keys are...
643 sub GetSinglePrinterProfile {
645 my $dbh = C4::Context->dbh;
646 my $query = " SELECT * FROM printers_profile WHERE prof_id = ?; ";
647 my $sth = $dbh->prepare($query);
648 $sth->execute($prof_id);
649 my $template = $sth->fetchrow_hashref;
656 SaveProfile('parameters')
658 When passed a set of parameters, this function updates the given profile with the new parameters.
664 $prof_id, $offset_horz, $offset_vert, $creep_horz, $creep_vert, $units
666 my $dbh = C4::Context->dbh;
668 " UPDATE printers_profile
669 SET offset_horz=?, offset_vert=?, creep_horz=?, creep_vert=?, unit=?
671 my $sth = $dbh->prepare($query);
673 $offset_horz, $offset_vert, $creep_horz, $creep_vert, $units, $prof_id
680 CreateProfile('parameters')
682 When passed a set of parameters, this function creates a new profile containing those parameters
683 and returns any errors.
689 $prof_id, $printername, $paper_bin, $tmpl_id, $offset_horz,
690 $offset_vert, $creep_horz, $creep_vert, $units
692 my $dbh = C4::Context->dbh;
694 " INSERT INTO printers_profile (prof_id, printername, paper_bin, tmpl_id,
695 offset_horz, offset_vert, creep_horz, creep_vert, unit)
696 VALUES(?,?,?,?,?,?,?,?,?) ";
697 my $sth = $dbh->prepare($query);
699 $prof_id, $printername, $paper_bin, $tmpl_id, $offset_horz,
700 $offset_vert, $creep_horz, $creep_vert, $units
702 my $error = $sth->errstr;
709 DeleteProfile(prof_id)
711 When passed a profile id, this function deletes that profile from the database and returns any errors.
717 my $dbh = C4::Context->dbh;
718 my $query = " DELETE FROM printers_profile WHERE prof_id = ?";
719 my $sth = $dbh->prepare($query);
720 $sth->execute($prof_id);
721 my $error = $sth->errstr;
726 =item GetAssociatedProfile;
728 $assoc_prof = GetAssociatedProfile(tmpl_id)
730 When passed a template id, this function returns the parameters from the currently associated printer profile
731 in a hashref where key=fieldname and value=fieldvalue.
735 sub GetAssociatedProfile {
737 my $dbh = C4::Context->dbh;
738 # First we find out the prof_id for the associated profile...
739 my $query = "SELECT * FROM labels_profile WHERE tmpl_id = ?";
740 my $sth = $dbh->prepare($query);
741 $sth->execute($tmpl_id);
742 my $assoc_prof = $sth->fetchrow_hashref;
744 # Then we retrieve that profile and return it to the caller...
745 $assoc_prof = GetSinglePrinterProfile($assoc_prof->{'prof_id'});
749 =item SetAssociatedProfile;
751 SetAssociatedProfile($prof_id, $tmpl_id)
753 When passed both a profile id and template id, this function establishes an association between the two. No more
754 than one profile may be associated with any given template at the same time.
758 sub SetAssociatedProfile {
760 my ($prof_id, $tmpl_id) = @_;
762 my $dbh = C4::Context->dbh;
763 my $query = "INSERT INTO labels_profile (prof_id, tmpl_id) VALUES (?,?) ON DUPLICATE KEY UPDATE prof_id = ?";
764 my $sth = $dbh->prepare($query);
765 $sth->execute($prof_id, $tmpl_id, $prof_id);
771 $options = GetLabelItems()
773 Returns an array of references-to-hash, whos keys are the field from the biblio, biblioitems, items and labels tables in the Koha database.
780 my $dbh = C4::Context->dbh;
782 my @resultsloop = ();
788 my $query3 = "Select * from labels where batch_id = ? order by labelid ";
789 $sth = $dbh->prepare($query3);
790 $sth->execute($batch_id);
795 my $query3 = "Select * from labels";
796 $sth = $dbh->prepare($query3);
799 my $cnt = $sth->rows;
801 while ( my $data = $sth->fetchrow_hashref ) {
803 # lets get some summary info from each item
805 select i.*, bi.*, b.* from items i,biblioitems bi,biblio b
806 where itemnumber=? and i.biblioitemnumber=bi.biblioitemnumber and
807 bi.biblionumber=b.biblionumber";
809 my $sth1 = $dbh->prepare($query1);
810 $sth1->execute( $data->{'itemnumber'} );
812 my $data1 = $sth1->fetchrow_hashref();
813 $data1->{'labelno'} = $i1;
814 $data1->{'labelid'} = $data->{'labelid'};
815 $data1->{'batch_id'} = $batch_id;
816 $data1->{'summary'} =
817 "$data1->{'barcode'}, $data1->{'title'}, $data1->{'isbn'}";
819 push( @resultsloop, $data1 );
831 barcode title subtitle
832 dewey isbn issn author class
833 itemtype subclass itemcallnumber
842 Parse labels_conf.formatstring value
843 (one value of the csv, which has already been split)
844 and return string from koha tables or MARC record.
849 my ($f,$item,$record) = @_;
850 my $kohatables= &_descKohaTables();
853 my $match_kohatable = join('|', (@{$kohatables->{biblio}},@{$kohatables->{biblioitems}},@{$kohatables->{items}}) );
855 if( $f =~ /^'(.*)'.*/ ) {
856 # single quotes indicate a static text string.
859 } elsif ( $f =~ /^($match_kohatable).*/ ) {
860 # grep /$f/, (@$kohatables->{biblio},@$kohatables->{biblioitems},@$kohatables->{items}) ) {
861 $datastring .= $item->{$f};
863 } elsif ( $f =~ /^([0-9a-z]{3})(\w)(\W*).*/ ) {
864 $datastring .= $record->subfield($1,$2) . $3 if($record->subfield($1,$2)) ;
867 last if ( $f eq $last_f ); # failed to match
873 Return a hashref of an array of hashes,
877 sub _descKohaTables {
878 my $dbh = C4::Context->dbh();
880 for my $table ( 'biblio','biblioitems','items' ) {
881 my $sth = $dbh->column_info(undef,undef,$table,'%');
882 while (my $info = $sth->fetchrow_hashref()){
883 push @{$kohatables->{$table}} , $info->{'COLUMN_NAME'} ;
890 sub GetPatronCardItems {
892 my ( $batch_id ) = @_;
895 my $dbh = C4::Context->dbh;
896 # my $query = "SELECT * FROM patroncards WHERE batch_id = ? ORDER BY borrowernumber";
897 my $query = "SELECT * FROM patroncards WHERE batch_id = ? ORDER BY cardid";
898 my $sth = $dbh->prepare($query);
899 $sth->execute($batch_id);
901 while ( my $data = $sth->fetchrow_hashref ) {
902 my $patron_data = GetMember( $data->{'borrowernumber'} );
903 $patron_data->{'branchname'} = GetBranchName( $patron_data->{'branchcode'} );
904 $patron_data->{'cardno'} = $cardno;
905 $patron_data->{'cardid'} = $data->{'cardid'};
906 $patron_data->{'batch_id'} = $batch_id;
907 push( @resultsloop, $patron_data );
915 sub deduplicate_batch {
916 my ( $batch_id, $batch_type ) = @_;
919 batch_id," . (($batch_type eq 'labels') ? 'itemnumber' : 'borrowernumber') . ",
920 count(". (($batch_type eq 'labels') ? 'labelid' : 'cardid') . ") as count
923 GROUP BY " . (($batch_type eq 'labels') ? 'itemnumber' : 'borrowernumber') . ",batch_id
927 my $sth = C4::Context->dbh->prepare($query);
928 $sth->execute($batch_id);
929 warn $sth->errstr if $sth->errstr;
930 $sth->rows or return undef, $sth->errstr;
936 AND " . (($batch_type eq 'labels') ? 'itemnumber' : 'borrowernumber') . " = ?
937 ORDER BY timestamp ASC
940 while (my $data = $sth->fetchrow_hashref()) {
941 my $itemnumber = $data->{(($batch_type eq 'labels') ? 'itemnumber' : 'borrowernumber')} or next;
942 my $limit = $data->{count} - 1 or next;
943 my $sth2 = C4::Context->dbh->prepare("$del_query LIMIT $limit");
944 # die sprintf "$del_query LIMIT %s\n (%s, %s)", $limit, $batch_id, $itemnumber;
945 # $sth2->execute($batch_id, C4::Context->dbh->quote($data->{itemnumber}), $data->{count} - 1)
946 $sth2->execute($batch_id, $itemnumber) and
947 $killed += ($data->{count} - 1);
948 warn $sth2->errstr if $sth2->errstr;
950 return $killed, undef;
955 my ( $x_pos, $y_pos, $label_height, $label_width, $fontname, $fontsize, $left_text_margin,
956 $text_wrap_cols, $item, $conf_data, $printingtype, $nowrap ) = @_;
958 # Replaced item's itemtype with the more user-friendly description...
959 my $dbh = C4::Context->dbh;
961 my $sth = $dbh->prepare("SELECT itemtype,description FROM itemtypes");
963 while ( my $data = $sth->fetchrow_hashref ) {
964 $$item->{'itemtype'} = $data->{'description'} if ($$item->{'itemtype'} eq $data->{'itemtype'});
969 my $top_text_margin = ( $fontsize + 3 ); #FIXME: This should be a template parameter and passed in...
970 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.).
972 my $layout_id = $$conf_data->{'id'};
974 my $vPos = ( $y_pos + ( $label_height - $top_text_margin ) );
976 my @str_fields = get_text_fields($layout_id, 'codes' );
977 my $record = GetMarcBiblio($$item->{biblionumber});
978 # FIXME - returns all items, so you can't get data from an embedded holdings field.
979 # TODO - add a GetMarcBiblio1item(bibnum,itemnum) or a GetMarcItem(itemnum).
981 my $old_fontname = $fontname; # We need to keep track of the original font passed in...
983 for my $field (@str_fields) {
984 $field->{'code'} or warn "get_text_fields($layout_id, 'codes') element missing 'code' field";
985 if ($$conf_data->{'formatstring'}) {
986 $field->{'data'} = GetBarcodeData($field->{'code'},$$item,$record) ;
988 $field->{data} = $$item->{$field->{'code'}} ;
991 # This allows us to print the title in italic (oblique) type... (Times Roman has a different nomenclature.)
992 # It seems there should be a better way to handle fonts in the label/patron card tool altogether -fbcit
993 ($field->{code} eq 'title') ? (($old_fontname =~ /T/) ? ($fontname = 'TI') : ($fontname = ($old_fontname . 'O'))) : ($fontname = $old_fontname);
994 my $font = prFont($fontname);
995 # if the display option for this field is selected in the DB,
996 # and the item record has some values for this field, display it.
997 if ( ($$conf_data->{'formatstring'}) || ( $$conf_data->{$field->{code}} && $$item->{$field->{code}} ) ) {
999 my $str = $field->{data} ;
1000 # strip out naughty existing nl/cr's
1004 if ($field->{code} eq 'itemcallnumber') { # If the field contains the call number, we do some special processing on it here...
1005 if (($nowrap == 0) || (!$nowrap)) { # wrap lines based on segmentation markers: '/' (other types of segmentation markers can be added as needed here or this could be added as a syspref.)
1006 while ( $str =~ /\// ) {
1007 $str =~ /^(.*)\/(.*)$/;
1008 unshift @strings, $2;
1011 unshift @strings, $str;
1013 push @strings, $str; # if $nowrap == 1 do not wrap or remove segmentation markers...
1016 $str =~ s/\/$//g; # Here we will strip out all trailing '/' in fields other than the call number...
1017 if ( length($str) > $text_wrap_cols ) { # wrap lines greater than $text_wrap_cols width...
1018 my $wrap = substr($str, ($text_wrap_cols - length($str)), $text_wrap_cols, "");
1019 push @strings, $str;
1020 push @strings, $wrap;
1022 push @strings, $str;
1025 # loop for each string line
1026 foreach my $str (@strings) {
1028 if ( $printingtype eq 'BIB' ) { #FIXME: This is a hack and needs to be implimented as a text justification option in the template...
1029 # some code to try and center each line on the label based on font size and string point width...
1030 my $stringwidth = prStrWidth($str, $fontname, $fontsize);
1031 my $whitespace = ( $label_width - ( $stringwidth + (2 * $left_text_margin) ) );
1032 $hPos = ( ( $whitespace / 2 ) + $x_pos + $left_text_margin );
1033 #warn "\$label_width=$label_width \$stringwidth=$stringwidth \$whitespace=$whitespace \$left_text_margin=$left_text_margin for $str\n";
1035 $hPos = ( $x_pos + $left_text_margin );
1037 PrintText( $hPos, $vPos, $font, $fontsize, $str );
1038 $vPos = $vPos - $line_spacer;
1045 my ( $hPos, $vPos, $font, $fontsize, $text ) = @_;
1046 my $str = "BT /$font $fontsize Tf $hPos $vPos Td ($text) Tj ET";
1050 sub DrawPatronCardText {
1052 my ( $x_pos, $y_pos, $label_height, $label_width, $fontname, $fontsize, $left_text_margin,
1053 $text_wrap_cols, $text, $printingtype )
1056 my $top_text_margin = 25; #FIXME: This should be a template parameter and passed in...
1058 my $vPos = ( $y_pos + ( $label_height - $top_text_margin ) );
1059 my $font = prFont($fontname);
1063 foreach my $line (keys %$text) {
1064 $debug and warn "Current text is \"$line\" and font size for \"$line\" is $text->{$line} points";
1065 # some code to try and center each line on the label based on font size and string point width...
1066 my $stringwidth = prStrWidth($line, $fontname, $text->{$line});
1067 my $whitespace = ( $label_width - ( $stringwidth + (2 * $left_text_margin) ) );
1068 $hPos = ( ( $whitespace / 2 ) + $x_pos + $left_text_margin );
1070 PrintText( $hPos, $vPos, $font, $text->{$line}, $line );
1071 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.).
1072 $vPos = $vPos - ($line_spacer + $text->{$line}); # Linefeed equiv: leading + font size
1076 # Not used anywhere.
1080 # my ($fontsize) = @_;
1082 # my $str = "BT/F13 30 Tf288 720 Td( AAAAAAAAAA ) TjET";
1088 # x and y are from the top-left :)
1089 my ( $x_pos, $y_pos, $height, $width, $barcode, $barcodetype ) = @_;
1090 my $num_of_bars = length($barcode);
1091 my $bar_width = $width * .8; # %80 of length of label width
1094 my $guard_length = 10;
1097 if ( $barcodetype eq 'CODE39' ) {
1098 $bar_length = '17.5';
1100 ( $bar_length * $num_of_bars ) + ( $guard_length * 2 );
1101 $xsize_ratio = ( $bar_width / $tot_bar_length );
1103 PDF::Reuse::Barcode::Code39(
1104 x => ( $x_pos + ( $width / 10 ) ),
1105 y => ( $y_pos + ( $height / 10 ) ),
1106 value => "*$barcode*",
1107 ySize => ( .02 * $height ),
1108 xSize => $xsize_ratio,
1113 warn "$barcodetype, $barcode FAILED:$@";
1117 elsif ( $barcodetype eq 'CODE39MOD' ) {
1119 # get modulo43 checksum
1120 my $c39 = CheckDigits('code_39');
1121 $barcode = $c39->complete($barcode);
1125 ( $bar_length * $num_of_bars ) + ( $guard_length * 2 );
1126 $xsize_ratio = ( $bar_width / $tot_bar_length );
1128 PDF::Reuse::Barcode::Code39(
1129 x => ( $x_pos + ( $width / 10 ) ),
1130 y => ( $y_pos + ( $height / 10 ) ),
1131 value => "*$barcode*",
1132 ySize => ( .02 * $height ),
1133 xSize => $xsize_ratio,
1139 warn "$barcodetype, $barcode FAILED:$@";
1142 elsif ( $barcodetype eq 'CODE39MOD10' ) {
1144 # get modulo43 checksum
1145 my $c39_10 = CheckDigits('visa');
1146 $barcode = $c39_10->complete($barcode);
1150 ( $bar_length * $num_of_bars ) + ( $guard_length * 2 );
1151 $xsize_ratio = ( $bar_width / $tot_bar_length );
1153 PDF::Reuse::Barcode::Code39(
1154 x => ( $x_pos + ( $width / 10 ) ),
1155 y => ( $y_pos + ( $height / 10 ) ),
1156 value => "*$barcode*",
1157 ySize => ( .02 * $height ),
1158 xSize => $xsize_ratio,
1165 warn "$barcodetype, $barcode FAILED:$@";
1170 elsif ( $barcodetype eq 'COOP2OF5' ) {
1171 $bar_length = '9.43333333333333';
1173 ( $bar_length * $num_of_bars ) + ( $guard_length * 2 );
1174 $xsize_ratio = ( $bar_width / $tot_bar_length ) * .9;
1176 PDF::Reuse::Barcode::COOP2of5(
1177 x => ( $x_pos + ( $width / 10 ) ),
1178 y => ( $y_pos + ( $height / 10 ) ),
1180 ySize => ( .02 * $height ),
1181 xSize => $xsize_ratio,
1185 warn "$barcodetype, $barcode FAILED:$@";
1189 elsif ( $barcodetype eq 'INDUSTRIAL2OF5' ) {
1190 $bar_length = '13.1333333333333';
1192 ( $bar_length * $num_of_bars ) + ( $guard_length * 2 );
1193 $xsize_ratio = ( $bar_width / $tot_bar_length ) * .9;
1195 PDF::Reuse::Barcode::Industrial2of5(
1196 x => ( $x_pos + ( $width / 10 ) ),
1197 y => ( $y_pos + ( $height / 10 ) ),
1199 ySize => ( .02 * $height ),
1200 xSize => $xsize_ratio,
1204 warn "$barcodetype, $barcode FAILED:$@";
1208 my $moo2 = $tot_bar_length * $xsize_ratio;
1210 warn "$x_pos, $y_pos, $barcode, $barcodetype" if $debug;
1211 warn "BAR_WDTH = $bar_width, TOT.BAR.LGHT=$tot_bar_length R*TOT.BAR =$moo2" if $debug;
1214 =item build_circ_barcode;
1216 build_circ_barcode( $x_pos, $y_pos, $barcode,
1217 $barcodetype, \$item);
1219 $item is the result of a previous call to GetLabelItems();
1224 sub build_circ_barcode {
1225 my ( $x_pos_circ, $y_pos, $value, $barcodetype, $item ) = @_;
1227 #warn Dumper \$item;
1229 #warn "value = $value\n";
1233 if ( $barcodetype eq 'EAN13' ) {
1235 #testing EAN13 barcodes hack
1236 $value = $value . '000000000';
1238 $value = substr( $value, 0, 12 );
1242 PDF::Reuse::Barcode::EAN13(
1243 x => ( $x_pos_circ + 27 ),
1244 y => ( $y_pos + 15 ),
1252 # added for xpdf compat. doesnt use type3 fonts., but increases filesize from 20k to 200k
1253 # i think its embedding extra fonts in the pdf file.
1254 # mode => 'graphic',
1258 $item->{'barcodeerror'} = 1;
1260 #warn "EAN13BARCODE FAILED:$@";
1266 elsif ( $barcodetype eq 'Code39' ) {
1269 PDF::Reuse::Barcode::Code39(
1270 x => ( $x_pos_circ + 9 ),
1271 y => ( $y_pos + 15 ),
1281 $item->{'barcodeerror'} = 1;
1283 #warn "CODE39BARCODE $value FAILED:$@";
1290 elsif ( $barcodetype eq 'Matrix2of5' ) {
1292 #warn "MATRIX ELSE:";
1294 #testing MATRIX25 barcodes hack
1295 # $value = $value.'000000000';
1298 # $value = substr( $value, 0, 12 );
1302 PDF::Reuse::Barcode::Matrix2of5(
1303 x => ( $x_pos_circ + 27 ),
1304 y => ( $y_pos + 15 ),
1314 $item->{'barcodeerror'} = 1;
1316 #warn "BARCODE FAILED:$@";
1323 elsif ( $barcodetype eq 'EAN8' ) {
1325 #testing ean8 barcodes hack
1326 $value = $value . '000000000';
1328 $value = substr( $value, 0, 8 );
1332 #warn "EAN8 ELSEIF";
1334 PDF::Reuse::Barcode::EAN8(
1335 x => ( $x_pos_circ + 42 ),
1336 y => ( $y_pos + 15 ),
1346 $item->{'barcodeerror'} = 1;
1348 #warn "BARCODE FAILED:$@";
1355 elsif ( $barcodetype eq 'UPC-E' ) {
1357 PDF::Reuse::Barcode::UPCE(
1358 x => ( $x_pos_circ + 27 ),
1359 y => ( $y_pos + 15 ),
1369 $item->{'barcodeerror'} = 1;
1371 #warn "BARCODE FAILED:$@";
1377 elsif ( $barcodetype eq 'NW7' ) {
1379 PDF::Reuse::Barcode::NW7(
1380 x => ( $x_pos_circ + 27 ),
1381 y => ( $y_pos + 15 ),
1391 $item->{'barcodeerror'} = 1;
1393 #warn "BARCODE FAILED:$@";
1399 elsif ( $barcodetype eq 'ITF' ) {
1401 PDF::Reuse::Barcode::ITF(
1402 x => ( $x_pos_circ + 27 ),
1403 y => ( $y_pos + 15 ),
1413 $item->{'barcodeerror'} = 1;
1415 #warn "BARCODE FAILED:$@";
1421 elsif ( $barcodetype eq 'Industrial2of5' ) {
1423 PDF::Reuse::Barcode::Industrial2of5(
1424 x => ( $x_pos_circ + 27 ),
1425 y => ( $y_pos + 15 ),
1434 $item->{'barcodeerror'} = 1;
1436 #warn "BARCODE FAILED:$@";
1442 elsif ( $barcodetype eq 'IATA2of5' ) {
1444 PDF::Reuse::Barcode::IATA2of5(
1445 x => ( $x_pos_circ + 27 ),
1446 y => ( $y_pos + 15 ),
1455 $item->{'barcodeerror'} = 1;
1457 #warn "BARCODE FAILED:$@";
1464 elsif ( $barcodetype eq 'COOP2of5' ) {
1466 PDF::Reuse::Barcode::COOP2of5(
1467 x => ( $x_pos_circ + 27 ),
1468 y => ( $y_pos + 15 ),
1477 $item->{'barcodeerror'} = 1;
1479 #warn "BARCODE FAILED:$@";
1485 elsif ( $barcodetype eq 'UPC-A' ) {
1488 PDF::Reuse::Barcode::UPCA(
1489 x => ( $x_pos_circ + 27 ),
1490 y => ( $y_pos + 15 ),
1499 $item->{'barcodeerror'} = 1;
1501 #warn "BARCODE FAILED:$@";
1510 =item draw_boundaries
1512 sub draw_boundaries ($x_pos_spine, $x_pos_circ1, $x_pos_circ2,
1513 $y_pos, $spine_width, $label_height, $circ_width)
1515 This sub draws boundary lines where the label outlines are, to aid in printer testing, and debugging.
1520 sub draw_boundaries {
1523 $x_pos_spine, $x_pos_circ1, $x_pos_circ2, $y_pos,
1524 $spine_width, $label_height, $circ_width
1527 my $y_pos_initial = ( ( 792 - 36 ) - 90 );
1528 $y_pos = $y_pos_initial; # FIXME - why are we ignoring the y_pos parameter by redefining it?
1531 for ( $i = 1 ; $i <= 8 ; $i++ ) {
1533 &drawbox( $x_pos_spine, $y_pos, ($spine_width), ($label_height) );
1535 #warn "OLD BOXES x=$x_pos_spine, y=$y_pos, w=$spine_width, h=$label_height";
1536 &drawbox( $x_pos_circ1, $y_pos, ($circ_width), ($label_height) );
1537 &drawbox( $x_pos_circ2, $y_pos, ($circ_width), ($label_height) );
1539 $y_pos = ( $y_pos - $label_height );
1546 sub drawbox { $lower_left_x, $lower_left_y,
1547 $upper_right_x, $upper_right_y )
1549 this is a low level sub, that draws a pdf box, it is called by draw_boxes
1551 FYI: the $upper_right_x and $upper_right_y values are RELATIVE to $lower_left_x and $lower_left_y
1553 and $lower_left_x, $lower_left_y are ABSOLUTE, this caught me out!
1559 my ( $llx, $lly, $urx, $ury ) = @_;
1561 # warn "llx,y= $llx,$lly , urx,y=$urx,$ury \n";
1563 my $str = "q\n"; # save the graphic state
1564 $str .= "0.5 w\n"; # border color red
1565 $str .= "1.0 0.0 0.0 RG\n"; # border color red
1566 # $str .= "0.5 0.75 1.0 rg\n"; # fill color blue
1567 $str .= "1.0 1.0 1.0 rg\n"; # fill color white
1569 $str .= "$llx $lly $urx $ury re\n"; # a rectangle
1570 $str .= "B\n"; # fill (and a little more)
1571 $str .= "Q\n"; # save the graphic state
1577 END { } # module clean-up code here (global destructor)
1586 Mason James <mason@katipo.co.nz>