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 $dbh = C4::Context->dbh;
86 my $query2 = " SELECT * FROM labels_conf where active = 1";
87 my $sth = $dbh->prepare($query2);
89 my $conf_data = $sth->fetchrow_hashref;
96 ## FIXME: this if/else could be compacted...
97 my $dbh = C4::Context->dbh;
99 my $query = " Select * from labels_conf";
100 my $sth = $dbh->prepare($query);
103 while ( my $data = $sth->fetchrow_hashref ) {
105 $data->{'fieldlist'} = get_text_fields( $data->{'id'} );
106 push( @resultsloop, $data );
116 my ($layout_id) = @_;
117 my $dbh = C4::Context->dbh;
119 # get the actual items to be printed.
120 my $query = " Select * from labels_conf where id = ?";
121 my $sth = $dbh->prepare($query);
122 $sth->execute($layout_id);
123 my $data = $sth->fetchrow_hashref;
128 sub get_active_layout {
129 my ($layout_id) = @_;
130 my $dbh = C4::Context->dbh;
132 # get the actual items to be printed.
133 my $query = " Select * from labels_conf where active = 1";
134 my $sth = $dbh->prepare($query);
136 my $data = $sth->fetchrow_hashref;
142 my ($layout_id) = @_;
143 my $dbh = C4::Context->dbh;
145 # get the actual items to be printed.
146 my $query = "delete from labels_conf where id = ?";
147 my $sth = $dbh->prepare($query);
148 $sth->execute($layout_id);
152 sub get_printingtypes {
153 my ($layout_id) = @_;
155 # FIXME: hard coded print types
156 push( @printtypes, { code => 'BAR', desc => "barcode only" } );
157 push( @printtypes, { code => 'BIB', desc => "biblio only" } );
158 push( @printtypes, { code => 'BARBIB', desc => "barcode / biblio" } );
159 push( @printtypes, { code => 'BIBBAR', desc => "biblio / barcode" } );
160 push( @printtypes, { code => 'ALT', desc => "alternating labels" } );
161 push( @printtypes, { code => 'CSV', desc => "csv output" } );
162 push( @printtypes, { code => 'PATCRD', desc => "patron cards" } );
164 my $conf = get_layout($layout_id);
165 my $active_printtype = $conf->{'printingtype'};
167 # lop thru layout, insert selected to hash
169 foreach my $printtype (@printtypes) {
170 if ( $printtype->{'code'} eq $active_printtype ) {
171 $printtype->{'active'} = 1;
177 # this sub (build_text_dropbox) is deprecated and should be deleted.
180 sub build_text_dropbox {
183 # my @fields = get_text_fields();
184 # my $field_count = scalar @fields;
185 my $field_count = 10; # <----------- FIXME hard coded
189 ? push( @lines, { num => '', selected => '1' } )
190 : push( @lines, { num => '' } );
191 for ( my $i = 1 ; $i <= $field_count ; $i++ ) {
192 my $line = { num => "$i" };
193 $line->{'selected'} = 1 if $i eq $order;
194 push( @lines, $line );
197 # add a blank row too
202 sub get_text_fields {
203 my ($layout_id, $sorttype) = @_;
206 my $sortorder = get_layout($layout_id);
207 if( $sortorder->{formatstring}) {
209 return $sortorder->{formatstring} ;
211 my $csv = Text::CSV_XS->new( { allow_whitespace => 1 } ) ;
212 my $line= $sortorder->{formatstring} ;
213 my $status = $csv->parse( $line );
214 @sorted_fields = map {{ 'code' => $_ , desc => $_ } } $csv->fields() ;
215 $error = $csv->error_input();
216 warn $error if $error ; # TODO - do more with this.
219 # These fields are hardcoded based on the template for label-edit-layout.pl
224 order => $sortorder->{'itemtype'}
229 order => $sortorder->{'dewey'}
234 order => $sortorder->{'issn'}
239 order => $sortorder->{'isbn'}
243 desc => "Classification",
244 order => $sortorder->{'class'}
249 order => $sortorder->{'subclass'}
254 order => $sortorder->{'barcode'}
259 order => $sortorder->{'author'}
264 order => $sortorder->{'title'}
267 code => 'itemcallnumber',
268 desc => "Call Number",
269 order => $sortorder->{'itemcallnumber'}
274 order => $sortorder->{'subtitle'}
280 foreach my $field (@text_fields) {
281 push( @new_fields, $field ) if $field->{'order'} > 0;
284 @sorted_fields = sort { $$a{order} <=> $$b{order} } @new_fields;
286 # if we have a 'formatstring', then we ignore these hardcoded fields.
289 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
290 return @sorted_fields;
292 foreach my $field (@sorted_fields) {
293 $active_fields .= "$field->{'desc'} ";
295 return $active_fields;
302 add_batch($batch_type,\@batch_list);
303 if $batch_list is supplied,
304 create a new batch with those items.
305 else, return the next available batch_id.
309 my ( $batch_type,$batch_list ) = @_;
311 my $dbh = C4::Context->dbh;
312 my $q ="SELECT MAX(DISTINCT batch_id) FROM $batch_type";
313 my $sth = $dbh->prepare($q);
315 my ($batch_id) = $sth->fetchrow_array;
322 # TODO: let this block use $batch_type
323 if(ref($batch_list) && ($batch_type eq 'labels') ) {
324 my $sth = $dbh->prepare("INSERT INTO labels (`batch_id`,`itemnumber`) VALUES (?,?)");
325 for my $item (@$batch_list) {
326 $sth->execute($batch_id,$item);
332 #FIXME: Needs to be ported to receive $batch_type
333 # ... this looks eerily like add_batch() ...
334 sub get_highest_batch {
336 my $dbh = C4::Context->dbh;
338 "select distinct batch_id from labels order by batch_id desc limit 1";
339 my $sth = $dbh->prepare($q);
341 my $data = $sth->fetchrow_hashref;
344 if ( !$data->{'batch_id'} ) {
348 $new_batch = $data->{'batch_id'};
356 my ( $batch_type ) = @_;
357 my $dbh = C4::Context->dbh;
358 my $q = "SELECT batch_id, COUNT(*) AS num FROM $batch_type GROUP BY batch_id";
359 my $sth = $dbh->prepare($q);
362 while ( my $data = $sth->fetchrow_hashref ) {
363 push( @resultsloop, $data );
367 # Not sure why we are doing this rather than simply telling the user that no batches are currently defined.
368 # So I'm commenting this out and modifying label-manager.tmpl to properly inform the user as stated. -fbcit
369 # adding a dummy batch=1 value , if none exists in the db
370 # if ( !scalar(@resultsloop) ) {
371 # push( @resultsloop, { batch_id => '1' , num => '0' } );
377 my ($batch_id, $batch_type) = @_;
378 warn "Deleteing batch of type $batch_type";
379 my $dbh = C4::Context->dbh;
380 my $q = "DELETE FROM $batch_type WHERE batch_id = ?";
381 my $sth = $dbh->prepare($q);
382 $sth->execute($batch_id);
386 sub get_barcode_types {
387 my ($layout_id) = @_;
388 my $layout = get_layout($layout_id);
389 my $barcode = $layout->{'barcodetype'};
392 push( @array, { code => 'CODE39', desc => 'Code 39' } );
393 push( @array, { code => 'CODE39MOD', desc => 'Code39 + Modulo43' } );
394 push( @array, { code => 'CODE39MOD10', desc => 'Code39 + Modulo10' } );
395 push( @array, { code => 'ITF', desc => 'Interleaved 2 of 5' } );
397 foreach my $line (@array) {
398 if ( $line->{'code'} eq $barcode ) {
399 $line->{'active'} = 1;
410 $unitvalue = '1' if ( $units eq 'POINT' );
411 $unitvalue = '2.83464567' if ( $units eq 'MM' );
412 $unitvalue = '28.3464567' if ( $units eq 'CM' );
413 $unitvalue = 72 if ( $units eq 'INCH' );
417 sub GetTextWrapCols {
418 my ( $font, $fontsize, $label_width, $left_text_margin ) = @_;
422 # my $textlimit = $label_width - ($left_text_margin);
423 my $textlimit = $label_width - ( 3 * $left_text_margin);
425 while ( $strwidth < $textlimit ) {
426 $strwidth = prStrWidth( $string, $font, $fontsize );
427 $string = $string . '0';
428 #warn "strwidth:$strwidth, textlimit:$textlimit, count:$count string:$string";
434 sub GetActiveLabelTemplate {
435 my $dbh = C4::Context->dbh;
436 my $query = " SELECT * FROM labels_templates where active = 1 limit 1";
437 my $sth = $dbh->prepare($query);
439 my $active_tmpl = $sth->fetchrow_hashref;
444 sub GetSingleLabelTemplate {
446 my $dbh = C4::Context->dbh;
447 my $query = " SELECT * FROM labels_templates where tmpl_id = ?";
448 my $sth = $dbh->prepare($query);
449 $sth->execute($tmpl_id);
450 my $template = $sth->fetchrow_hashref;
455 sub SetActiveTemplate {
459 my $dbh = C4::Context->dbh;
460 my $query = " UPDATE labels_templates SET active = NULL";
461 my $sth = $dbh->prepare($query);
464 $query = "UPDATE labels_templates SET active = 1 WHERE tmpl_id = ?";
465 $sth = $dbh->prepare($query);
466 $sth->execute($tmpl_id);
470 sub set_active_layout {
472 my ($layout_id) = @_;
473 my $dbh = C4::Context->dbh;
474 my $query = " UPDATE labels_conf SET active = NULL";
475 my $sth = $dbh->prepare($query);
478 $query = "UPDATE labels_conf SET active = 1 WHERE id = ?";
479 $sth = $dbh->prepare($query);
480 $sth->execute($layout_id);
486 my $dbh = C4::Context->dbh;
487 my $query = " DELETE FROM labels_templates where tmpl_id = ?";
488 my $sth = $dbh->prepare($query);
489 $sth->execute($tmpl_id);
495 $tmpl_id, $tmpl_code, $tmpl_desc, $page_width,
496 $page_height, $label_width, $label_height, $topmargin,
497 $leftmargin, $cols, $rows, $colgap,
498 $rowgap, $font, $fontsize, $units
500 warn "Passed \$font:$font";
501 my $dbh = C4::Context->dbh;
503 " UPDATE labels_templates SET tmpl_code=?, tmpl_desc=?, page_width=?,
504 page_height=?, label_width=?, label_height=?, topmargin=?,
505 leftmargin=?, cols=?, rows=?, colgap=?, rowgap=?, font=?, fontsize=?,
509 my $sth = $dbh->prepare($query);
511 $tmpl_code, $tmpl_desc, $page_width, $page_height,
512 $label_width, $label_height, $topmargin, $leftmargin,
513 $cols, $rows, $colgap, $rowgap,
514 $font, $fontsize, $units, $tmpl_id
516 my $dberror = $sth->errstr;
524 $tmpl_code, $tmpl_desc, $page_width, $page_height,
525 $label_width, $label_height, $topmargin, $leftmargin,
526 $cols, $rows, $colgap, $rowgap,
527 $font, $fontsize, $units
530 my $dbh = C4::Context->dbh;
532 my $query = "INSERT INTO labels_templates (tmpl_code, tmpl_desc, page_width,
533 page_height, label_width, label_height, topmargin,
534 leftmargin, cols, rows, colgap, rowgap, font, fontsize, units)
535 VALUES(?,?,?,?,?,?,?,?,?,?,?,?,?,?,?)";
537 my $sth = $dbh->prepare($query);
539 $tmpl_code, $tmpl_desc, $page_width, $page_height,
540 $label_width, $label_height, $topmargin, $leftmargin,
541 $cols, $rows, $colgap, $rowgap,
542 $font, $fontsize, $units
544 my $dberror = $sth->errstr;
549 sub GetAllLabelTemplates {
550 my $dbh = C4::Context->dbh;
552 # get the actual items to be printed.
554 my $query = " Select * from labels_templates ";
555 my $sth = $dbh->prepare($query);
558 while ( my $data = $sth->fetchrow_hashref ) {
559 push( @resultsloop, $data );
563 #warn Dumper @resultsloop;
571 $barcodetype, $title, $subtitle, $isbn, $issn,
572 $itemtype, $bcn, $dcn, $classif,
573 $subclass, $itemcallnumber, $author, $tmpl_id,
574 $printingtype, $guidebox, $startlabel, $layoutname, $formatstring
577 my $dbh = C4::Context->dbh;
578 my $query2 = "update labels_conf set active = NULL";
579 my $sth2 = $dbh->prepare($query2);
581 $query2 = "INSERT INTO labels_conf
582 ( barcodetype, title, subtitle, isbn,issn, itemtype, barcode,
583 dewey, classification, subclass, itemcallnumber, author, printingtype,
584 guidebox, startlabel, layoutname, formatstring, active )
585 values ( ?, ?,?, ?, ?, ?, ?, ?, ?,?, ?, ?, ?, ?, ?,?,?, 1 )";
586 $sth2 = $dbh->prepare($query2);
588 $barcodetype, $title, $subtitle, $isbn, $issn,
590 $itemtype, $bcn, $dcn, $classif,
591 $subclass, $itemcallnumber, $author, $printingtype,
592 $guidebox, $startlabel, $layoutname, $formatstring
596 SetActiveTemplate($tmpl_id);
603 $barcodetype, $title, $subtitle, $isbn, $issn,
604 $itemtype, $bcn, $dcn, $classif,
605 $subclass, $itemcallnumber, $author, $tmpl_id,
606 $printingtype, $guidebox, $startlabel, $layoutname, $formatstring,
612 my $dbh = C4::Context->dbh;
613 my $query2 = "update labels_conf set
614 barcodetype=?, title=?, subtitle=?, isbn=?,issn=?,
615 itemtype=?, barcode=?, dewey=?, classification=?,
616 subclass=?, itemcallnumber=?, author=?, printingtype=?,
617 guidebox=?, startlabel=?, layoutname=?, formatstring=? where id = ?";
618 my $sth2 = $dbh->prepare($query2);
620 $barcodetype, $title, $subtitle, $isbn, $issn,
621 $itemtype, $bcn, $dcn, $classif,
622 $subclass, $itemcallnumber, $author, $printingtype,
623 $guidebox, $startlabel, $layoutname, $formatstring, $layout_id
630 =item GetAllPrinterProfiles;
632 @profiles = GetAllPrinterProfiles()
634 Returns an array of references-to-hash, whos keys are .....
638 sub GetAllPrinterProfiles {
640 my $dbh = C4::Context->dbh;
642 my $query = "SELECT * FROM printers_profile AS pp INNER JOIN labels_templates AS lt ON pp.tmpl_id = lt.tmpl_id; ";
643 my $sth = $dbh->prepare($query);
646 while ( my $data = $sth->fetchrow_hashref ) {
647 push( @resultsloop, $data );
654 =item GetSinglePrinterProfile;
656 $profile = GetSinglePrinterProfile()
658 Returns a hashref whos keys are...
662 sub GetSinglePrinterProfile {
664 my $dbh = C4::Context->dbh;
665 my $query = " SELECT * FROM printers_profile WHERE prof_id = ?; ";
666 my $sth = $dbh->prepare($query);
667 $sth->execute($prof_id);
668 my $template = $sth->fetchrow_hashref;
675 SaveProfile('parameters')
677 When passed a set of parameters, this function updates the given profile with the new parameters.
683 $prof_id, $offset_horz, $offset_vert, $creep_horz, $creep_vert, $units
685 my $dbh = C4::Context->dbh;
687 " UPDATE printers_profile
688 SET offset_horz=?, offset_vert=?, creep_horz=?, creep_vert=?, unit=?
690 my $sth = $dbh->prepare($query);
692 $offset_horz, $offset_vert, $creep_horz, $creep_vert, $units, $prof_id
699 CreateProfile('parameters')
701 When passed a set of parameters, this function creates a new profile containing those parameters
702 and returns any errors.
708 $prof_id, $printername, $paper_bin, $tmpl_id, $offset_horz,
709 $offset_vert, $creep_horz, $creep_vert, $units
711 my $dbh = C4::Context->dbh;
713 " INSERT INTO printers_profile (prof_id, printername, paper_bin, tmpl_id,
714 offset_horz, offset_vert, creep_horz, creep_vert, unit)
715 VALUES(?,?,?,?,?,?,?,?,?) ";
716 my $sth = $dbh->prepare($query);
718 $prof_id, $printername, $paper_bin, $tmpl_id, $offset_horz,
719 $offset_vert, $creep_horz, $creep_vert, $units
721 my $error = $sth->errstr;
728 DeleteProfile(prof_id)
730 When passed a profile id, this function deletes that profile from the database and returns any errors.
736 my $dbh = C4::Context->dbh;
737 my $query = " DELETE FROM printers_profile WHERE prof_id = ?";
738 my $sth = $dbh->prepare($query);
739 $sth->execute($prof_id);
740 my $error = $sth->errstr;
745 =item GetAssociatedProfile;
747 $assoc_prof = GetAssociatedProfile(tmpl_id)
749 When passed a template id, this function returns the parameters from the currently associated printer profile
750 in a hashref where key=fieldname and value=fieldvalue.
754 sub GetAssociatedProfile {
756 my $dbh = C4::Context->dbh;
757 # First we find out the prof_id for the associated profile...
758 my $query = "SELECT * FROM labels_profile WHERE tmpl_id = ?";
759 my $sth = $dbh->prepare($query);
760 $sth->execute($tmpl_id);
761 my $assoc_prof = $sth->fetchrow_hashref;
763 # Then we retrieve that profile and return it to the caller...
764 $assoc_prof = GetSinglePrinterProfile($assoc_prof->{'prof_id'});
768 =item SetAssociatedProfile;
770 SetAssociatedProfile($prof_id, $tmpl_id)
772 When passed both a profile id and template id, this function establishes an association between the two. No more
773 than one profile may be associated with any given template at the same time.
777 sub SetAssociatedProfile {
779 my ($prof_id, $tmpl_id) = @_;
781 my $dbh = C4::Context->dbh;
782 my $query = "INSERT INTO labels_profile (prof_id, tmpl_id) VALUES (?,?) ON DUPLICATE KEY UPDATE prof_id = ?";
783 my $sth = $dbh->prepare($query);
784 $sth->execute($prof_id, $tmpl_id, $prof_id);
790 $options = GetLabelItems()
792 Returns an array of references-to-hash, whos keys are the field from the biblio, biblioitems, items and labels tables in the Koha database.
799 my $dbh = C4::Context->dbh;
801 my @resultsloop = ();
807 my $query3 = "Select * from labels where batch_id = ? order by labelid ";
808 $sth = $dbh->prepare($query3);
809 $sth->execute($batch_id);
814 my $query3 = "Select * from labels";
815 $sth = $dbh->prepare($query3);
818 my $cnt = $sth->rows;
820 while ( my $data = $sth->fetchrow_hashref ) {
822 # lets get some summary info from each item
824 select i.*, bi.*, b.* from items i,biblioitems bi,biblio b
825 where itemnumber=? and i.biblioitemnumber=bi.biblioitemnumber and
826 bi.biblionumber=b.biblionumber";
828 my $sth1 = $dbh->prepare($query1);
829 $sth1->execute( $data->{'itemnumber'} );
831 my $data1 = $sth1->fetchrow_hashref();
832 $data1->{'labelno'} = $i1;
833 $data1->{'labelid'} = $data->{'labelid'};
834 $data1->{'batch_id'} = $batch_id;
835 $data1->{'summary'} =
836 "$data1->{'barcode'}, $data1->{'title'}, $data1->{'isbn'}";
838 push( @resultsloop, $data1 );
850 barcode title subtitle
851 dewey isbn issn author class
852 itemtype subclass itemcallnumber
861 Parse labels_conf.formatstring value
862 (one value of the csv, which has already been split)
863 and return string from koha tables or MARC record.
868 my ($f,$item,$record) = @_;
869 my $kohatables= &_descKohaTables();
872 my $match_kohatable = join('|', (@{$kohatables->{biblio}},@{$kohatables->{biblioitems}},@{$kohatables->{items}}) );
874 if( $f =~ /^'(.*)'.*/ ) {
875 # single quotes indicate a static text string.
878 } elsif ( $f =~ /^($match_kohatable).*/ ) {
879 # grep /$f/, (@$kohatables->{biblio},@$kohatables->{biblioitems},@$kohatables->{items}) ) {
880 $datastring .= $item->{$f};
882 } elsif ( $f =~ /^([0-9a-z]{3})(\w)(\W*).*/ ) {
883 $datastring .= $record->subfield($1,$2) . $3 if($record->subfield($1,$2)) ;
886 last if ( $f eq $last_f ); # failed to match
892 Return a hashref of an array of hashes,
896 sub _descKohaTables {
897 my $dbh = C4::Context->dbh();
899 for my $table ( 'biblio','biblioitems','items' ) {
900 my $sth = $dbh->column_info(undef,undef,$table,'%');
901 while (my $info = $sth->fetchrow_hashref()){
902 push @{$kohatables->{$table}} , $info->{'COLUMN_NAME'} ;
909 sub GetPatronCardItems {
911 my ( $batch_id ) = @_;
914 my $dbh = C4::Context->dbh;
915 # my $query = "SELECT * FROM patroncards WHERE batch_id = ? ORDER BY borrowernumber";
916 my $query = "SELECT * FROM patroncards WHERE batch_id = ? ORDER BY cardid";
917 my $sth = $dbh->prepare($query);
918 $sth->execute($batch_id);
920 while ( my $data = $sth->fetchrow_hashref ) {
921 my $patron_data = GetMember( $data->{'borrowernumber'} );
922 $patron_data->{'branchname'} = GetBranchName( $patron_data->{'branchcode'} );
923 $patron_data->{'cardno'} = $cardno;
924 $patron_data->{'cardid'} = $data->{'cardid'};
925 $patron_data->{'batch_id'} = $batch_id;
926 push( @resultsloop, $patron_data );
934 sub deduplicate_batch {
935 my ( $batch_id, $batch_type ) = @_;
938 batch_id," . (($batch_type eq 'labels') ? 'itemnumber' : 'borrowernumber') . ",
939 count(". (($batch_type eq 'labels') ? 'labelid' : 'cardid') . ") as count
942 GROUP BY " . (($batch_type eq 'labels') ? 'itemnumber' : 'borrowernumber') . ",batch_id
946 my $sth = C4::Context->dbh->prepare($query);
947 $sth->execute($batch_id);
948 warn $sth->errstr if $sth->errstr;
949 $sth->rows or return undef, $sth->errstr;
955 AND " . (($batch_type eq 'labels') ? 'itemnumber' : 'borrowernumber') . " = ?
956 ORDER BY timestamp ASC
959 while (my $data = $sth->fetchrow_hashref()) {
960 my $itemnumber = $data->{(($batch_type eq 'labels') ? 'itemnumber' : 'borrowernumber')} or next;
961 my $limit = $data->{count} - 1 or next;
962 my $sth2 = C4::Context->dbh->prepare("$del_query LIMIT $limit");
963 # die sprintf "$del_query LIMIT %s\n (%s, %s)", $limit, $batch_id, $itemnumber;
964 # $sth2->execute($batch_id, C4::Context->dbh->quote($data->{itemnumber}), $data->{count} - 1)
965 $sth2->execute($batch_id, $itemnumber) and
966 $killed += ($data->{count} - 1);
967 warn $sth2->errstr if $sth2->errstr;
969 return $killed, undef;
974 my ( $x_pos, $y_pos, $label_height, $label_width, $fontname, $fontsize, $left_text_margin,
975 $text_wrap_cols, $item, $conf_data, $printingtype, $nowrap ) = @_;
977 # Replaced item's itemtype with the more user-friendly description...
978 my $dbh = C4::Context->dbh;
980 my $sth = $dbh->prepare("SELECT itemtype,description FROM itemtypes");
982 while ( my $data = $sth->fetchrow_hashref ) {
983 $$item->{'itemtype'} = $data->{'description'} if ($$item->{'itemtype'} eq $data->{'itemtype'});
988 my $top_text_margin = ( $fontsize + 3 ); #FIXME: This should be a template parameter and passed in...
989 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.).
991 my $layout_id = $$conf_data->{'id'};
993 my $vPos = ( $y_pos + ( $label_height - $top_text_margin ) );
995 my @str_fields = get_text_fields($layout_id, 'codes' );
996 my $record = GetMarcBiblio($$item->{biblionumber});
997 # FIXME - returns all items, so you can't get data from an embedded holdings field.
998 # TODO - add a GetMarcBiblio1item(bibnum,itemnum) or a GetMarcItem(itemnum).
1000 my $old_fontname = $fontname; # We need to keep track of the original font passed in...
1002 for my $field (@str_fields) {
1004 if ($$conf_data->{'formatstring'}) {
1005 $field->{'data'} = GetBarcodeData($field->{'code'},$$item,$record) ;
1007 $field->{data} = $$item{$field->{'code'}} ;
1010 # This allows us to print the title in italic (oblique) type... (Times Roman has a different nomenclature.)
1011 # It seems there should be a better way to handle fonts in the label/patron card tool altogether -fbcit
1012 ($field->{code} eq 'title') ? (($old_fontname =~ /T/) ? ($fontname = 'TI') : ($fontname = ($old_fontname . 'O'))) : ($fontname = $old_fontname);
1013 my $font = prFont($fontname);
1014 # if the display option for this field is selected in the DB,
1015 # and the item record has some values for this field, display it.
1016 if ( ($$conf_data->{'formatstring'}) || ( $$conf_data->{$field->{code}} && $$item->{$field->{code}} ) ) {
1018 my $str = $field->{data} ;
1019 # strip out naughty existing nl/cr's
1023 if ($field->{code} eq 'itemcallnumber') { # If the field contains the call number, we do some special processing on it here...
1024 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.)
1025 while ( $str =~ /\// ) {
1026 $str =~ /^(.*)\/(.*)$/;
1027 unshift @strings, $2;
1030 unshift @strings, $str;
1032 push @strings, $str; # if $nowrap == 1 do not wrap or remove segmentation markers...
1035 $str =~ s/\/$//g; # Here we will strip out all trailing '/' in fields other than the call number...
1036 if ( length($str) > $text_wrap_cols ) { # wrap lines greater than $text_wrap_cols width...
1037 my $wrap = substr($str, ($text_wrap_cols - length($str)), $text_wrap_cols, "");
1038 push @strings, $str;
1039 push @strings, $wrap;
1041 push @strings, $str;
1044 # loop for each string line
1045 foreach my $str (@strings) {
1047 if ( $printingtype eq 'BIB' ) { #FIXME: This is a hack and needs to be implimented as a text justification option in the template...
1048 # some code to try and center each line on the label based on font size and string point width...
1049 my $stringwidth = prStrWidth($str, $fontname, $fontsize);
1050 my $whitespace = ( $label_width - ( $stringwidth + (2 * $left_text_margin) ) );
1051 $hPos = ( ( $whitespace / 2 ) + $x_pos + $left_text_margin );
1052 #warn "\$label_width=$label_width \$stringwidth=$stringwidth \$whitespace=$whitespace \$left_text_margin=$left_text_margin for $str\n";
1054 $hPos = ( $x_pos + $left_text_margin );
1056 PrintText( $hPos, $vPos, $font, $fontsize, $str );
1057 $vPos = $vPos - $line_spacer;
1064 my ( $hPos, $vPos, $font, $fontsize, $text ) = @_;
1065 my $str = "BT /$font $fontsize Tf $hPos $vPos Td ($text) Tj ET";
1069 sub DrawPatronCardText {
1071 my ( $x_pos, $y_pos, $label_height, $label_width, $fontname, $fontsize, $left_text_margin,
1072 $text_wrap_cols, $text, $printingtype )
1075 my $top_text_margin = 25; #FIXME: This should be a template parameter and passed in...
1077 my $vPos = ( $y_pos + ( $label_height - $top_text_margin ) );
1078 my $font = prFont($fontname);
1082 foreach my $line (keys %$text) {
1083 warn "Current text is \"$line\" and font size for \"$line\" is $text->{$line} points";
1084 # some code to try and center each line on the label based on font size and string point width...
1085 my $stringwidth = prStrWidth($line, $fontname, $text->{$line});
1086 my $whitespace = ( $label_width - ( $stringwidth + (2 * $left_text_margin) ) );
1087 $hPos = ( ( $whitespace / 2 ) + $x_pos + $left_text_margin );
1089 PrintText( $hPos, $vPos, $font, $text->{$line}, $line );
1090 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.).
1091 $vPos = $vPos - ($line_spacer + $text->{$line}); # Linefeed equiv: leading + font size
1095 # Not used anywhere.
1099 # my ($fontsize) = @_;
1101 # my $str = "BT/F13 30 Tf288 720 Td( AAAAAAAAAA ) TjET";
1107 # x and y are from the top-left :)
1108 my ( $x_pos, $y_pos, $height, $width, $barcode, $barcodetype ) = @_;
1109 my $num_of_bars = length($barcode);
1110 my $bar_width = $width * .8; # %80 of length of label width
1113 my $guard_length = 10;
1116 if ( $barcodetype eq 'CODE39' ) {
1117 $bar_length = '17.5';
1119 ( $bar_length * $num_of_bars ) + ( $guard_length * 2 );
1120 $xsize_ratio = ( $bar_width / $tot_bar_length );
1122 PDF::Reuse::Barcode::Code39(
1123 x => ( $x_pos + ( $width / 10 ) ),
1124 y => ( $y_pos + ( $height / 10 ) ),
1125 value => "*$barcode*",
1126 ySize => ( .02 * $height ),
1127 xSize => $xsize_ratio,
1132 warn "$barcodetype, $barcode FAILED:$@";
1136 elsif ( $barcodetype eq 'CODE39MOD' ) {
1138 # get modulo43 checksum
1139 my $c39 = CheckDigits('code_39');
1140 $barcode = $c39->complete($barcode);
1144 ( $bar_length * $num_of_bars ) + ( $guard_length * 2 );
1145 $xsize_ratio = ( $bar_width / $tot_bar_length );
1147 PDF::Reuse::Barcode::Code39(
1148 x => ( $x_pos + ( $width / 10 ) ),
1149 y => ( $y_pos + ( $height / 10 ) ),
1150 value => "*$barcode*",
1151 ySize => ( .02 * $height ),
1152 xSize => $xsize_ratio,
1158 warn "$barcodetype, $barcode FAILED:$@";
1161 elsif ( $barcodetype eq 'CODE39MOD10' ) {
1163 # get modulo43 checksum
1164 my $c39_10 = CheckDigits('visa');
1165 $barcode = $c39_10->complete($barcode);
1169 ( $bar_length * $num_of_bars ) + ( $guard_length * 2 );
1170 $xsize_ratio = ( $bar_width / $tot_bar_length );
1172 PDF::Reuse::Barcode::Code39(
1173 x => ( $x_pos + ( $width / 10 ) ),
1174 y => ( $y_pos + ( $height / 10 ) ),
1175 value => "*$barcode*",
1176 ySize => ( .02 * $height ),
1177 xSize => $xsize_ratio,
1184 warn "$barcodetype, $barcode FAILED:$@";
1189 elsif ( $barcodetype eq 'COOP2OF5' ) {
1190 $bar_length = '9.43333333333333';
1192 ( $bar_length * $num_of_bars ) + ( $guard_length * 2 );
1193 $xsize_ratio = ( $bar_width / $tot_bar_length ) * .9;
1195 PDF::Reuse::Barcode::COOP2of5(
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 elsif ( $barcodetype eq 'INDUSTRIAL2OF5' ) {
1209 $bar_length = '13.1333333333333';
1211 ( $bar_length * $num_of_bars ) + ( $guard_length * 2 );
1212 $xsize_ratio = ( $bar_width / $tot_bar_length ) * .9;
1214 PDF::Reuse::Barcode::Industrial2of5(
1215 x => ( $x_pos + ( $width / 10 ) ),
1216 y => ( $y_pos + ( $height / 10 ) ),
1218 ySize => ( .02 * $height ),
1219 xSize => $xsize_ratio,
1223 warn "$barcodetype, $barcode FAILED:$@";
1227 my $moo2 = $tot_bar_length * $xsize_ratio;
1229 warn "$x_pos, $y_pos, $barcode, $barcodetype" if $debug;
1230 warn "BAR_WDTH = $bar_width, TOT.BAR.LGHT=$tot_bar_length R*TOT.BAR =$moo2" if $debug;
1233 =item build_circ_barcode;
1235 build_circ_barcode( $x_pos, $y_pos, $barcode,
1236 $barcodetype, \$item);
1238 $item is the result of a previous call to GetLabelItems();
1243 sub build_circ_barcode {
1244 my ( $x_pos_circ, $y_pos, $value, $barcodetype, $item ) = @_;
1246 #warn Dumper \$item;
1248 #warn "value = $value\n";
1252 if ( $barcodetype eq 'EAN13' ) {
1254 #testing EAN13 barcodes hack
1255 $value = $value . '000000000';
1257 $value = substr( $value, 0, 12 );
1261 PDF::Reuse::Barcode::EAN13(
1262 x => ( $x_pos_circ + 27 ),
1263 y => ( $y_pos + 15 ),
1271 # added for xpdf compat. doesnt use type3 fonts., but increases filesize from 20k to 200k
1272 # i think its embedding extra fonts in the pdf file.
1273 # mode => 'graphic',
1277 $item->{'barcodeerror'} = 1;
1279 #warn "EAN13BARCODE FAILED:$@";
1285 elsif ( $barcodetype eq 'Code39' ) {
1288 PDF::Reuse::Barcode::Code39(
1289 x => ( $x_pos_circ + 9 ),
1290 y => ( $y_pos + 15 ),
1300 $item->{'barcodeerror'} = 1;
1302 #warn "CODE39BARCODE $value FAILED:$@";
1309 elsif ( $barcodetype eq 'Matrix2of5' ) {
1311 #warn "MATRIX ELSE:";
1313 #testing MATRIX25 barcodes hack
1314 # $value = $value.'000000000';
1317 # $value = substr( $value, 0, 12 );
1321 PDF::Reuse::Barcode::Matrix2of5(
1322 x => ( $x_pos_circ + 27 ),
1323 y => ( $y_pos + 15 ),
1333 $item->{'barcodeerror'} = 1;
1335 #warn "BARCODE FAILED:$@";
1342 elsif ( $barcodetype eq 'EAN8' ) {
1344 #testing ean8 barcodes hack
1345 $value = $value . '000000000';
1347 $value = substr( $value, 0, 8 );
1351 #warn "EAN8 ELSEIF";
1353 PDF::Reuse::Barcode::EAN8(
1354 x => ( $x_pos_circ + 42 ),
1355 y => ( $y_pos + 15 ),
1365 $item->{'barcodeerror'} = 1;
1367 #warn "BARCODE FAILED:$@";
1374 elsif ( $barcodetype eq 'UPC-E' ) {
1376 PDF::Reuse::Barcode::UPCE(
1377 x => ( $x_pos_circ + 27 ),
1378 y => ( $y_pos + 15 ),
1388 $item->{'barcodeerror'} = 1;
1390 #warn "BARCODE FAILED:$@";
1396 elsif ( $barcodetype eq 'NW7' ) {
1398 PDF::Reuse::Barcode::NW7(
1399 x => ( $x_pos_circ + 27 ),
1400 y => ( $y_pos + 15 ),
1410 $item->{'barcodeerror'} = 1;
1412 #warn "BARCODE FAILED:$@";
1418 elsif ( $barcodetype eq 'ITF' ) {
1420 PDF::Reuse::Barcode::ITF(
1421 x => ( $x_pos_circ + 27 ),
1422 y => ( $y_pos + 15 ),
1432 $item->{'barcodeerror'} = 1;
1434 #warn "BARCODE FAILED:$@";
1440 elsif ( $barcodetype eq 'Industrial2of5' ) {
1442 PDF::Reuse::Barcode::Industrial2of5(
1443 x => ( $x_pos_circ + 27 ),
1444 y => ( $y_pos + 15 ),
1453 $item->{'barcodeerror'} = 1;
1455 #warn "BARCODE FAILED:$@";
1461 elsif ( $barcodetype eq 'IATA2of5' ) {
1463 PDF::Reuse::Barcode::IATA2of5(
1464 x => ( $x_pos_circ + 27 ),
1465 y => ( $y_pos + 15 ),
1474 $item->{'barcodeerror'} = 1;
1476 #warn "BARCODE FAILED:$@";
1483 elsif ( $barcodetype eq 'COOP2of5' ) {
1485 PDF::Reuse::Barcode::COOP2of5(
1486 x => ( $x_pos_circ + 27 ),
1487 y => ( $y_pos + 15 ),
1496 $item->{'barcodeerror'} = 1;
1498 #warn "BARCODE FAILED:$@";
1504 elsif ( $barcodetype eq 'UPC-A' ) {
1507 PDF::Reuse::Barcode::UPCA(
1508 x => ( $x_pos_circ + 27 ),
1509 y => ( $y_pos + 15 ),
1518 $item->{'barcodeerror'} = 1;
1520 #warn "BARCODE FAILED:$@";
1529 =item draw_boundaries
1531 sub draw_boundaries ($x_pos_spine, $x_pos_circ1, $x_pos_circ2,
1532 $y_pos, $spine_width, $label_height, $circ_width)
1534 This sub draws boundary lines where the label outlines are, to aid in printer testing, and debugging.
1539 sub draw_boundaries {
1542 $x_pos_spine, $x_pos_circ1, $x_pos_circ2, $y_pos,
1543 $spine_width, $label_height, $circ_width
1546 my $y_pos_initial = ( ( 792 - 36 ) - 90 );
1547 $y_pos = $y_pos_initial; # FIXME - why are we ignoring the y_pos parameter by redefining it?
1550 for ( $i = 1 ; $i <= 8 ; $i++ ) {
1552 &drawbox( $x_pos_spine, $y_pos, ($spine_width), ($label_height) );
1554 #warn "OLD BOXES x=$x_pos_spine, y=$y_pos, w=$spine_width, h=$label_height";
1555 &drawbox( $x_pos_circ1, $y_pos, ($circ_width), ($label_height) );
1556 &drawbox( $x_pos_circ2, $y_pos, ($circ_width), ($label_height) );
1558 $y_pos = ( $y_pos - $label_height );
1565 sub drawbox { $lower_left_x, $lower_left_y,
1566 $upper_right_x, $upper_right_y )
1568 this is a low level sub, that draws a pdf box, it is called by draw_boxes
1570 FYI: the $upper_right_x and $upper_right_y values are RELATIVE to $lower_left_x and $lower_left_y
1572 and $lower_left_x, $lower_left_y are ABSOLUTE, this caught me out!
1578 my ( $llx, $lly, $urx, $ury ) = @_;
1580 # warn "llx,y= $llx,$lly , urx,y=$urx,$ury \n";
1582 my $str = "q\n"; # save the graphic state
1583 $str .= "0.5 w\n"; # border color red
1584 $str .= "1.0 0.0 0.0 RG\n"; # border color red
1585 # $str .= "0.5 0.75 1.0 rg\n"; # fill color blue
1586 $str .= "1.0 1.0 1.0 rg\n"; # fill color white
1588 $str .= "$llx $lly $urx $ury re\n"; # a rectangle
1589 $str .= "B\n"; # fill (and a little more)
1590 $str .= "Q\n"; # save the graphic state
1596 END { } # module clean-up code here (global destructor)
1605 Mason James <mason@katipo.co.nz>