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;
38 &get_label_options &GetLabelItems
39 &build_circ_barcode &draw_boundaries
40 &drawbox &GetActiveLabelTemplate
41 &GetAllLabelTemplates &DeleteTemplate
42 &GetSingleLabelTemplate &SaveTemplate
43 &CreateTemplate &SetActiveTemplate
44 &SaveConf &DrawSpineText &GetTextWrapCols
45 &GetUnitsValue &DrawBarcode &DrawPatronCardText
46 &get_printingtypes &GetPatronCardItems
49 &get_batches &delete_batch
53 get_layout &save_layout &add_layout
56 &delete_layout &get_active_layout
59 &GetAllPrinterProfiles &GetSinglePrinterProfile
60 &SaveProfile &CreateProfile &DeleteProfile
61 &GetAssociatedProfile &SetAssociatedProfile
68 C4::Labels - Functions for printing spine labels and barcodes in Koha
74 =item get_label_options;
76 $options = get_label_options()
78 Return a pointer on a hash list containing info from labels_conf table in Koha DB.
82 sub get_label_options {
83 my $query2 = " SELECT * FROM labels_conf where active = 1"; # FIXME: exact same as get_active_layout
84 my $sth = C4::Context->dbh->prepare($query2);
86 return $sth->fetchrow_hashref;
90 my $dbh = C4::Context->dbh;
92 my $query = " Select * from labels_conf";
93 my $sth = $dbh->prepare($query);
96 while ( my $data = $sth->fetchrow_hashref ) {
98 $data->{'fieldlist'} = get_text_fields( $data->{'id'} );
99 push( @resultsloop, $data );
106 my ($layout_id) = @_;
107 my $dbh = C4::Context->dbh;
109 # get the actual items to be printed.
110 my $query = " Select * from labels_conf where id = ?";
111 my $sth = $dbh->prepare($query);
112 $sth->execute($layout_id);
113 my $data = $sth->fetchrow_hashref;
118 sub get_active_layout {
119 my $query = " Select * from labels_conf where active = 1"; # FIXME: exact same as get_label_options
120 my $sth = C4::Context->dbh->prepare($query);
122 return $sth->fetchrow_hashref;
126 my ($layout_id) = @_;
127 my $dbh = C4::Context->dbh;
129 # get the actual items to be printed.
130 my $query = "delete from labels_conf where id = ?";
131 my $sth = $dbh->prepare($query);
132 $sth->execute($layout_id);
136 sub get_printingtypes {
137 my ($layout_id) = @_;
139 # FIXME hard coded print types
140 push( @printtypes, { code => 'BAR', desc => "barcode only" } );
141 push( @printtypes, { code => 'BIB', desc => "biblio only" } );
142 push( @printtypes, { code => 'BARBIB', desc => "barcode / biblio" } );
143 push( @printtypes, { code => 'BIBBAR', desc => "biblio / barcode" } );
144 push( @printtypes, { code => 'ALT', desc => "alternating labels" } );
145 push( @printtypes, { code => 'CSV', desc => "csv output" } );
146 push( @printtypes, { code => 'PATCRD', desc => "patron cards" } );
148 my $conf = get_layout($layout_id);
149 my $active_printtype = $conf->{'printingtype'};
151 # lop thru layout, insert selected to hash
153 foreach my $printtype (@printtypes) {
154 if ( $printtype->{'code'} eq $active_printtype ) {
155 $printtype->{'active'} = 1;
161 # this sub (build_text_dropbox) is deprecated and should be deleted.
164 sub build_text_dropbox {
166 my $field_count = 7; # <----------- FIXME hard coded
169 ? push( @lines, { num => '', selected => '1' } )
170 : push( @lines, { num => '' } );
171 for ( my $i = 1 ; $i <= $field_count ; $i++ ) {
172 my $line = { num => "$i" };
173 $line->{'selected'} = 1 if $i eq $order;
174 push( @lines, $line );
179 sub get_text_fields {
180 my ( $layout_id, $sorttype ) = @_;
183 my $sortorder = get_layout($layout_id);
184 if ( $sortorder->{formatstring} ) {
186 return $sortorder->{formatstring};
189 my $csv = Text::CSV_XS->new( { allow_whitespace => 1 } );
190 my $line = $sortorder->{formatstring};
191 my $status = $csv->parse($line);
193 map { { 'code' => $_, desc => $_ } } $csv->fields();
194 $error = $csv->error_input();
195 warn $error if $error; # TODO - do more with this.
200 # These fields are hardcoded based on the template for label-edit-layout.pl
205 order => $sortorder->{'itemtype'}
210 order => $sortorder->{'issn'}
215 order => $sortorder->{'isbn'}
220 order => $sortorder->{'barcode'}
225 order => $sortorder->{'author'}
230 order => $sortorder->{'title'}
233 code => 'itemcallnumber',
234 desc => "Call Number",
235 order => $sortorder->{'itemcallnumber'}
240 foreach my $field (@text_fields) {
241 push( @new_fields, $field ) if $field->{'order'} > 0;
244 @sorted_fields = sort { $$a{order} <=> $$b{order} } @new_fields;
247 # if we have a 'formatstring', then we ignore these hardcoded fields.
250 if ( $sorttype eq 'codes' )
251 { # FIXME: This sub should really always return the array of hashrefs and let the caller take what he wants from that -fbcit
252 return @sorted_fields;
255 foreach my $field (@sorted_fields) {
256 $active_fields .= "$field->{'desc'} ";
258 return $active_fields;
265 add_batch($batch_type,\@batch_list);
266 if $batch_list is supplied,
267 create a new batch with those items.
268 else, return the next available batch_id.
272 sub add_batch ($;$) {
273 my $table = (@_ and 'patroncards' eq shift) ? 'patroncards' : 'labels';
274 my $batch_list = (@_) ? shift : undef;
275 my $dbh = C4::Context->dbh;
276 my $q ="SELECT MAX(DISTINCT batch_id) FROM $table";
277 my $sth = $dbh->prepare($q);
279 my ($batch_id) = $sth->fetchrow_array || 0;
282 if ($table eq 'patroncards') {
283 $sth = $dbh->prepare("INSERT INTO $table (`batch_id`,`borrowernumber`) VALUES (?,?)");
285 $sth = $dbh->prepare("INSERT INTO $table (`batch_id`,`itemnumber` ) VALUES (?,?)");
288 $sth->execute($batch_id,$_);
294 #FIXME: Needs to be ported to receive $batch_type
295 # ... this looks eerily like add_batch() ...
296 sub get_highest_batch {
297 my $table = (@_ and 'patroncards' eq shift) ? 'patroncards' : 'labels';
299 "select distinct batch_id from $table order by batch_id desc limit 1";
300 my $sth = C4::Context->dbh->prepare($q);
302 my $data = $sth->fetchrow_hashref or return 1;
303 return ($data->{'batch_id'} || 1);
307 sub get_batches (;$) {
308 my $table = (@_ and 'patroncards' eq shift) ? 'patroncards' : 'labels';
309 my $q = "SELECT batch_id, COUNT(*) AS num FROM $table GROUP BY batch_id";
310 my $sth = C4::Context->dbh->prepare($q);
312 my $batches = $sth->fetchall_arrayref({});
317 my ($batch_id, $batch_type) = @_;
318 warn "Deleteing batch of type $batch_type";
319 my $dbh = C4::Context->dbh;
320 my $q = "DELETE FROM $batch_type WHERE batch_id = ?";
321 my $sth = $dbh->prepare($q);
322 $sth->execute($batch_id);
326 sub get_barcode_types {
327 my ($layout_id) = @_;
328 my $layout = get_layout($layout_id);
329 my $barcode = $layout->{'barcodetype'};
332 push( @array, { code => 'CODE39', desc => 'Code 39' } );
333 push( @array, { code => 'CODE39MOD', desc => 'Code39 + Modulo43' } );
334 push( @array, { code => 'CODE39MOD10', desc => 'Code39 + Modulo10' } );
335 push( @array, { code => 'ITF', desc => 'Interleaved 2 of 5' } );
337 foreach my $line (@array) {
338 if ( $line->{'code'} eq $barcode ) {
339 $line->{'active'} = 1;
350 $unitvalue = '1' if ( $units eq 'POINT' );
351 $unitvalue = '2.83464567' if ( $units eq 'MM' );
352 $unitvalue = '28.3464567' if ( $units eq 'CM' );
353 $unitvalue = 72 if ( $units eq 'INCH' );
357 sub GetTextWrapCols {
358 my ( $font, $fontsize, $label_width, $left_text_margin ) = @_;
362 # my $textlimit = $label_width - ($left_text_margin);
363 my $textlimit = $label_width - ( 3 * $left_text_margin);
365 while ( $strwidth < $textlimit ) {
366 $strwidth = prStrWidth( $string, $font, $fontsize );
367 $string = $string . '0';
368 #warn "strwidth:$strwidth, textlimit:$textlimit, count:$count string:$string";
374 sub GetActiveLabelTemplate {
375 my $dbh = C4::Context->dbh;
376 my $query = " SELECT * FROM labels_templates where active = 1 limit 1";
377 my $sth = $dbh->prepare($query);
379 my $active_tmpl = $sth->fetchrow_hashref;
384 sub GetSingleLabelTemplate {
386 my $dbh = C4::Context->dbh;
387 my $query = " SELECT * FROM labels_templates where tmpl_id = ?";
388 my $sth = $dbh->prepare($query);
389 $sth->execute($tmpl_id);
390 my $template = $sth->fetchrow_hashref;
395 sub SetActiveTemplate {
399 my $dbh = C4::Context->dbh;
400 my $query = " UPDATE labels_templates SET active = NULL";
401 my $sth = $dbh->prepare($query);
404 $query = "UPDATE labels_templates SET active = 1 WHERE tmpl_id = ?";
405 $sth = $dbh->prepare($query);
406 $sth->execute($tmpl_id);
410 sub set_active_layout {
412 my ($layout_id) = @_;
413 my $dbh = C4::Context->dbh;
414 my $query = " UPDATE labels_conf SET active = NULL";
415 my $sth = $dbh->prepare($query);
418 $query = "UPDATE labels_conf SET active = 1 WHERE id = ?";
419 $sth = $dbh->prepare($query);
420 $sth->execute($layout_id);
426 my $dbh = C4::Context->dbh;
427 my $query = " DELETE FROM labels_templates where tmpl_id = ?";
428 my $sth = $dbh->prepare($query);
429 $sth->execute($tmpl_id);
435 $tmpl_id, $tmpl_code, $tmpl_desc, $page_width,
436 $page_height, $label_width, $label_height, $topmargin,
437 $leftmargin, $cols, $rows, $colgap,
438 $rowgap, $font, $fontsize, $units
440 $debug and warn "Passed \$font:$font";
441 my $dbh = C4::Context->dbh;
443 " UPDATE labels_templates SET tmpl_code=?, tmpl_desc=?, page_width=?,
444 page_height=?, label_width=?, label_height=?, topmargin=?,
445 leftmargin=?, cols=?, rows=?, colgap=?, rowgap=?, font=?, fontsize=?,
449 my $sth = $dbh->prepare($query);
451 $tmpl_code, $tmpl_desc, $page_width, $page_height,
452 $label_width, $label_height, $topmargin, $leftmargin,
453 $cols, $rows, $colgap, $rowgap,
454 $font, $fontsize, $units, $tmpl_id
456 my $dberror = $sth->errstr;
464 $tmpl_code, $tmpl_desc, $page_width, $page_height,
465 $label_width, $label_height, $topmargin, $leftmargin,
466 $cols, $rows, $colgap, $rowgap,
467 $font, $fontsize, $units
470 my $dbh = C4::Context->dbh;
472 my $query = "INSERT INTO labels_templates (tmpl_code, tmpl_desc, page_width,
473 page_height, label_width, label_height, topmargin,
474 leftmargin, cols, rows, colgap, rowgap, font, fontsize, units)
475 VALUES(?,?,?,?,?,?,?,?,?,?,?,?,?,?,?)";
477 my $sth = $dbh->prepare($query);
479 $tmpl_code, $tmpl_desc, $page_width, $page_height,
480 $label_width, $label_height, $topmargin, $leftmargin,
481 $cols, $rows, $colgap, $rowgap,
482 $font, $fontsize, $units
484 my $dberror = $sth->errstr;
489 sub GetAllLabelTemplates {
490 my $dbh = C4::Context->dbh;
492 # get the actual items to be printed.
494 my $query = " Select * from labels_templates ";
495 my $sth = $dbh->prepare($query);
498 while ( my $data = $sth->fetchrow_hashref ) {
499 push( @resultsloop, $data );
503 #warn Dumper @resultsloop;
511 $barcodetype, $title, $subtitle, $isbn, $issn,
512 $itemtype, $bcn, $dcn, $classif,
513 $subclass, $itemcallnumber, $author, $tmpl_id,
514 $printingtype, $guidebox, $startlabel, $layoutname, $formatstring
517 my $dbh = C4::Context->dbh;
518 my $query2 = "update labels_conf set active = NULL";
519 my $sth2 = $dbh->prepare($query2);
521 $query2 = "INSERT INTO labels_conf
522 ( barcodetype, title, subtitle, isbn,issn, itemtype, barcode,
523 dewey, classification, subclass, itemcallnumber, author, printingtype,
524 guidebox, startlabel, layoutname, formatstring, active )
525 values ( ?, ?,?, ?, ?, ?, ?, ?, ?,?, ?, ?, ?, ?, ?,?,?, 1 )";
526 $sth2 = $dbh->prepare($query2);
528 $barcodetype, $title, $subtitle, $isbn, $issn,
530 $itemtype, $bcn, $dcn, $classif,
531 $subclass, $itemcallnumber, $author, $printingtype,
532 $guidebox, $startlabel, $layoutname, $formatstring
536 SetActiveTemplate($tmpl_id);
543 $barcodetype, $title, $subtitle, $isbn, $issn,
544 $itemtype, $bcn, $dcn, $classif,
545 $subclass, $itemcallnumber, $author, $tmpl_id,
546 $printingtype, $guidebox, $startlabel, $layoutname, $formatstring,
552 my $dbh = C4::Context->dbh;
553 my $query2 = "update labels_conf set
554 barcodetype=?, title=?, subtitle=?, isbn=?,issn=?,
555 itemtype=?, barcode=?, dewey=?, classification=?,
556 subclass=?, itemcallnumber=?, author=?, printingtype=?,
557 guidebox=?, startlabel=?, layoutname=?, formatstring=? where id = ?";
558 my $sth2 = $dbh->prepare($query2);
560 $barcodetype, $title, $subtitle, $isbn, $issn,
561 $itemtype, $bcn, $dcn, $classif,
562 $subclass, $itemcallnumber, $author, $printingtype,
563 $guidebox, $startlabel, $layoutname, $formatstring, $layout_id
570 =item GetAllPrinterProfiles;
572 @profiles = GetAllPrinterProfiles()
574 Returns an array of references-to-hash, whos keys are .....
578 sub GetAllPrinterProfiles {
580 my $dbh = C4::Context->dbh;
582 my $query = "SELECT * FROM printers_profile AS pp INNER JOIN labels_templates AS lt ON pp.tmpl_id = lt.tmpl_id; ";
583 my $sth = $dbh->prepare($query);
586 while ( my $data = $sth->fetchrow_hashref ) {
587 push( @resultsloop, $data );
594 =item GetSinglePrinterProfile;
596 $profile = GetSinglePrinterProfile()
598 Returns a hashref whos keys are...
602 sub GetSinglePrinterProfile {
604 my $dbh = C4::Context->dbh;
605 my $query = " SELECT * FROM printers_profile WHERE prof_id = ?; ";
606 my $sth = $dbh->prepare($query);
607 $sth->execute($prof_id);
608 my $template = $sth->fetchrow_hashref;
615 SaveProfile('parameters')
617 When passed a set of parameters, this function updates the given profile with the new parameters.
623 $prof_id, $offset_horz, $offset_vert, $creep_horz, $creep_vert, $units
625 my $dbh = C4::Context->dbh;
627 " UPDATE printers_profile
628 SET offset_horz=?, offset_vert=?, creep_horz=?, creep_vert=?, unit=?
630 my $sth = $dbh->prepare($query);
632 $offset_horz, $offset_vert, $creep_horz, $creep_vert, $units, $prof_id
639 CreateProfile('parameters')
641 When passed a set of parameters, this function creates a new profile containing those parameters
642 and returns any errors.
648 $prof_id, $printername, $paper_bin, $tmpl_id, $offset_horz,
649 $offset_vert, $creep_horz, $creep_vert, $units
651 my $dbh = C4::Context->dbh;
653 " INSERT INTO printers_profile (prof_id, printername, paper_bin, tmpl_id,
654 offset_horz, offset_vert, creep_horz, creep_vert, unit)
655 VALUES(?,?,?,?,?,?,?,?,?) ";
656 my $sth = $dbh->prepare($query);
658 $prof_id, $printername, $paper_bin, $tmpl_id, $offset_horz,
659 $offset_vert, $creep_horz, $creep_vert, $units
661 my $error = $sth->errstr;
668 DeleteProfile(prof_id)
670 When passed a profile id, this function deletes that profile from the database and returns any errors.
676 my $dbh = C4::Context->dbh;
677 my $query = " DELETE FROM printers_profile WHERE prof_id = ?";
678 my $sth = $dbh->prepare($query);
679 $sth->execute($prof_id);
680 my $error = $sth->errstr;
685 =item GetAssociatedProfile;
687 $assoc_prof = GetAssociatedProfile(tmpl_id)
689 When passed a template id, this function returns the parameters from the currently associated printer profile
690 in a hashref where key=fieldname and value=fieldvalue.
694 sub GetAssociatedProfile {
696 my $dbh = C4::Context->dbh;
697 # First we find out the prof_id for the associated profile...
698 my $query = "SELECT * FROM labels_profile WHERE tmpl_id = ?";
699 my $sth = $dbh->prepare($query);
700 $sth->execute($tmpl_id);
701 my $assoc_prof = $sth->fetchrow_hashref;
703 # Then we retrieve that profile and return it to the caller...
704 $assoc_prof = GetSinglePrinterProfile($assoc_prof->{'prof_id'});
708 =item SetAssociatedProfile;
710 SetAssociatedProfile($prof_id, $tmpl_id)
712 When passed both a profile id and template id, this function establishes an association between the two. No more
713 than one profile may be associated with any given template at the same time.
717 sub SetAssociatedProfile {
719 my ($prof_id, $tmpl_id) = @_;
721 my $dbh = C4::Context->dbh;
722 my $query = "INSERT INTO labels_profile (prof_id, tmpl_id) VALUES (?,?) ON DUPLICATE KEY UPDATE prof_id = ?";
723 my $sth = $dbh->prepare($query);
724 $sth->execute($prof_id, $tmpl_id, $prof_id);
731 $options = GetLabelItems()
733 Returns an array of references-to-hash, whos keys are the fields from the biblio, biblioitems, items and labels tables in the Koha database.
739 my $dbh = C4::Context->dbh;
741 my @resultsloop = ();
747 my $query3 = "SELECT *
751 $sth = $dbh->prepare($query3);
752 $sth->execute($batch_id);
755 my $query3 = "Select * from labels";
756 $sth = $dbh->prepare($query3);
759 my $cnt = $sth->rows;
761 while ( my $data = $sth->fetchrow_hashref ) {
763 # lets get some summary info from each item
765 select i.*, bi.*, b.* from items i,biblioitems bi,biblio b
766 where itemnumber=? and i.biblioitemnumber=bi.biblioitemnumber and
767 bi.biblionumber=b.biblionumber";
769 my $sth1 = $dbh->prepare($query1);
770 $sth1->execute( $data->{'itemnumber'} );
772 my $data1 = $sth1->fetchrow_hashref();
773 $data1->{'labelno'} = $i1;
774 $data1->{'labelid'} = $data->{'labelid'};
775 $data1->{'batch_id'} = $batch_id;
776 $data1->{'summary'} = "$data1->{'barcode'}, $data1->{'title'}, $data1->{'isbn'}";
778 push( @resultsloop, $data1 );
790 barcode title subtitle
791 dewey isbn issn author class
792 itemtype subclass itemcallnumber
800 Parse labels_conf.formatstring value
801 (one value of the csv, which has already been split)
802 and return string from koha tables or MARC record.
807 my ($f,$item,$record) = @_;
808 my $kohatables= &_descKohaTables();
811 my $match_kohatable = join('|', (@{$kohatables->{biblio}},@{$kohatables->{biblioitems}},@{$kohatables->{items}}) );
813 if( $f =~ /^'(.*)'.*/ ) {
814 # single quotes indicate a static text string.
817 } elsif ( $f =~ /^($match_kohatable).*/ ) {
818 # grep /$f/, (@$kohatables->{biblio},@$kohatables->{biblioitems},@$kohatables->{items}) ) {
819 $datastring .= $item->{$f};
821 } elsif ( $f =~ /^([0-9a-z]{3})(\w)(\W*).*/ ) {
822 $datastring .= $record->subfield($1,$2) . $3 if($record->subfield($1,$2)) ;
825 last if ( $f eq $last_f ); # failed to match
831 Return a hashref of an array of hashes,
835 sub _descKohaTables {
836 my $dbh = C4::Context->dbh();
838 for my $table ( 'biblio','biblioitems','items' ) {
839 my $sth = $dbh->column_info(undef,undef,$table,'%');
840 while (my $info = $sth->fetchrow_hashref()){
841 push @{$kohatables->{$table}} , $info->{'COLUMN_NAME'} ;
848 sub GetPatronCardItems {
850 my ( $batch_id ) = @_;
853 my $dbh = C4::Context->dbh;
854 # my $query = "SELECT * FROM patroncards WHERE batch_id = ? ORDER BY borrowernumber";
855 my $query = "SELECT * FROM patroncards WHERE batch_id = ? ORDER BY cardid";
856 my $sth = $dbh->prepare($query);
857 $sth->execute($batch_id);
859 while ( my $data = $sth->fetchrow_hashref ) {
860 my $patron_data = GetMember( $data->{'borrowernumber'} );
861 $patron_data->{'branchname'} = GetBranchName( $patron_data->{'branchcode'} );
862 $patron_data->{'cardno'} = $cardno;
863 $patron_data->{'cardid'} = $data->{'cardid'};
864 $patron_data->{'batch_id'} = $batch_id;
865 push( @resultsloop, $patron_data );
873 sub deduplicate_batch {
874 my ( $batch_id, $batch_type ) = @_;
877 batch_id," . (($batch_type eq 'labels') ? 'itemnumber' : 'borrowernumber') . ",
878 count(". (($batch_type eq 'labels') ? 'labelid' : 'cardid') . ") as count
881 GROUP BY " . (($batch_type eq 'labels') ? 'itemnumber' : 'borrowernumber') . ",batch_id
885 my $sth = C4::Context->dbh->prepare($query);
886 $sth->execute($batch_id);
887 warn $sth->errstr if $sth->errstr;
888 $sth->rows or return undef, $sth->errstr;
894 AND " . (($batch_type eq 'labels') ? 'itemnumber' : 'borrowernumber') . " = ?
895 ORDER BY timestamp ASC
898 while (my $data = $sth->fetchrow_hashref()) {
899 my $itemnumber = $data->{(($batch_type eq 'labels') ? 'itemnumber' : 'borrowernumber')} or next;
900 my $limit = $data->{count} - 1 or next;
901 my $sth2 = C4::Context->dbh->prepare("$del_query LIMIT $limit");
902 # die sprintf "$del_query LIMIT %s\n (%s, %s)", $limit, $batch_id, $itemnumber;
903 # $sth2->execute($batch_id, C4::Context->dbh->quote($data->{itemnumber}), $data->{count} - 1)
904 $sth2->execute($batch_id, $itemnumber) and
905 $killed += ($data->{count} - 1);
906 warn $sth2->errstr if $sth2->errstr;
908 return $killed, undef;
913 my ( $ll, $wnl, $dec, $cutter, $pubdate);
917 # lccn example 'HE8700.7 .P6T44 1983';
920 ([0-9]+\.*[0-9]*) # 8700.7
922 (\.*[a-zA-Z0-9]*) # P6T44
927 # strip something occuring spaces too
928 $splits[0] =~ s/\s+$//;
929 $splits[1] =~ s/\s+$//;
930 $splits[2] =~ s/\s+$//;
932 # if the regex fails, then just return the whole string,
933 # better than nothing
934 # FIXME It seems we should handle all cases, have some graceful error handling, or at least inform the caller of the failure to split
935 $splits[0] = $lccn if $splits[0] eq '' ;
941 $ddcn =~ s/\///g; # in theory we should be able to simply remove all segmentation markers and arrive at the correct call number...
943 # ddcn example R220.3 H2793Z H32 c.2
944 my @splits = m/^([A-Z]{0,3}) # R (OS, REF, etc. up do three letters)
945 ([0-9]+\.[0-9]*) # 220.3
946 \s? # space (not requiring anything beyond the call number)
947 ([a-zA-Z0-9]*\.?[a-zA-Z0-9])# cutter number... maybe, but if so it is in this position (Z indicates literary criticism)
948 \s? # space if it exists
949 ([a-zA-Z]*\.?[0-9]*) # other indicators such as cutter for author of literary criticism in this example if it exists
950 \s? # space if ie exists
951 ([a-zA-Z]*\.?[0-9]*) # other indicators such as volume number, copy number, edition date, etc. if it exists
958 my ( $x_pos, $y_pos, $label_height, $label_width, $fontname, $fontsize, $left_text_margin,
959 $text_wrap_cols, $item, $conf_data, $printingtype ) = @_;
961 # Replaced item's itemtype with the more user-friendly description...
962 my $dbh = C4::Context->dbh;
963 my $sth = $dbh->prepare("SELECT itemtype,description FROM itemtypes");
965 while ( my $data = $sth->fetchrow_hashref ) {
966 $$item->{'itemtype'} = $data->{'description'} if ($$item->{'itemtype'} eq $data->{'itemtype'});
967 $$item->{'itype'} = $data->{'description'} if ($$item->{'itype'} eq $data->{'itemtype'});
972 my $top_text_margin = ( $fontsize + 3 ); #FIXME: This should be a template parameter and passed in...
973 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.).
975 my $layout_id = $$conf_data->{'id'};
977 my $vPos = ( $y_pos + ( $label_height - $top_text_margin ) );
979 my @str_fields = get_text_fields($layout_id, 'codes' );
980 my $record = GetMarcBiblio($$item->{biblionumber});
981 # FIXME - returns all items, so you can't get data from an embedded holdings field.
982 # TODO - add a GetMarcBiblio1item(bibnum,itemnum) or a GetMarcItem(itemnum).
984 my $old_fontname = $fontname; # We need to keep track of the original font passed in...
985 my $cn_source = $$item->{'cn_source'};
986 for my $field (@str_fields) {
987 $field->{'code'} or warn "get_text_fields($layout_id, 'codes') element missing 'code' field";
988 if ($$conf_data->{'formatstring'}) {
989 $field->{'data'} = GetBarcodeData($field->{'code'},$$item,$record) ;
991 elsif ($field->{'code'} eq 'itemtype') {
992 $field->{'data'} = C4::Context->preference('item-level_itypes') ? $$item->{'itype'} : $$item->{'itemtype'};
995 $field->{data} = $$item->{$field->{'code'}} ;
997 # This allows us to print the title in italic (oblique) type... (Times Roman has a different nomenclature.)
998 # It seems there should be a better way to handle fonts in the label/patron card tool altogether -fbcit
999 ($field->{code} eq 'title') ? (($old_fontname =~ /T/) ? ($fontname = 'TI') : ($fontname = ($old_fontname . 'O'))) : ($fontname = $old_fontname);
1000 my $font = prFont($fontname);
1001 # if the display option for this field is selected in the DB,
1002 # and the item record has some values for this field, display it.
1003 if ( ($$conf_data->{'formatstring'}) || ( $$conf_data->{$field->{code}} && $$item->{$field->{code}} ) ) {
1005 my $str = $field->{data} ;
1006 # strip out naughty existing nl/cr's
1010 if ($field->{code} eq 'itemcallnumber' and $printingtype eq 'BIB') { # If the field contains the call number, we do some special processing on it here...
1011 if ($cn_source eq 'lcc') {
1012 @strings = split_lccn($str);
1013 } elsif ($cn_source eq 'ddc') {
1014 @strings = split_ddcn($str);
1016 # FIXME Need error trapping here; something to be informative to the user perhaps -crn
1017 push @strings, $str;
1020 $str =~ s/\/$//g; # Here we will strip out all trailing '/' in fields other than the call number...
1021 $str =~ s/\(/\\\(/g; # Escape '(' and ')' for the postscript stream...
1022 $str =~ s/\)/\\\)/g;
1023 # Wrap text lines exceeding $text_wrap_cols length...
1024 $Text::Wrap::columns = $text_wrap_cols;
1025 my @line = split(/\n/ ,wrap('', '', $str));
1026 # If this is a title field, limit to two lines; all others limit to one...
1027 if ($field->{code} eq 'title' && scalar(@line) >= 2) {
1028 while (scalar(@line) > 2) {
1032 while (scalar(@line) > 1) {
1036 push(@strings, @line);
1038 # loop for each string line
1039 foreach my $str (@strings) {
1041 if ( $printingtype eq 'BIB' ) { #FIXME: This is a hack and needs to be implimented as a text justification option in the template...
1042 # some code to try and center each line on the label based on font size and string point width...
1043 my $stringwidth = prStrWidth($str, $fontname, $fontsize);
1044 my $whitespace = ( $label_width - ( $stringwidth + (2 * $left_text_margin) ) );
1045 $hPos = ( ( $whitespace / 2 ) + $x_pos + $left_text_margin );
1046 #warn "\$label_width=$label_width \$stringwidth=$stringwidth \$whitespace=$whitespace \$left_text_margin=$left_text_margin for $str\n";
1048 $hPos = ( $x_pos + $left_text_margin );
1050 PrintText( $hPos, $vPos, $font, $fontsize, $str );
1051 $vPos = $vPos - $line_spacer;
1058 my ( $hPos, $vPos, $font, $fontsize, $text ) = @_;
1059 my $str = "BT /$font $fontsize Tf $hPos $vPos Td ($text) Tj ET";
1063 sub DrawPatronCardText {
1065 my ( $x_pos, $y_pos, $label_height, $label_width, $fontname, $fontsize, $left_text_margin,
1066 $text_wrap_cols, $text, $printingtype )
1069 my $top_text_margin = 25; #FIXME: This should be a template parameter and passed in...
1071 my $vPos = ( $y_pos + ( $label_height - $top_text_margin ) );
1072 my $font = prFont($fontname);
1076 foreach my $line (keys %$text) {
1077 $debug and warn "Current text is \"$line\" and font size for \"$line\" is $text->{$line} points";
1078 # some code to try and center each line on the label based on font size and string point width...
1079 my $stringwidth = prStrWidth($line, $fontname, $text->{$line});
1080 my $whitespace = ( $label_width - ( $stringwidth + (2 * $left_text_margin) ) );
1081 $hPos = ( ( $whitespace / 2 ) + $x_pos + $left_text_margin );
1083 PrintText( $hPos, $vPos, $font, $text->{$line}, $line );
1084 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.).
1085 $vPos = $vPos - ($line_spacer + $text->{$line}); # Linefeed equiv: leading + font size
1089 # Not used anywhere.
1093 # my ($fontsize) = @_;
1095 # my $str = "BT/F13 30 Tf288 720 Td( AAAAAAAAAA ) TjET";
1101 # x and y are from the top-left :)
1102 my ( $x_pos, $y_pos, $height, $width, $barcode, $barcodetype ) = @_;
1103 my $num_of_bars = length($barcode);
1104 my $bar_width = $width * .8; # %80 of length of label width
1105 my $tot_bar_length = 0;
1107 my $guard_length = 10;
1108 my $xsize_ratio = 0;
1110 if ( $barcodetype eq 'CODE39' ) {
1111 $bar_length = '17.5';
1113 ( $bar_length * $num_of_bars ) + ( $guard_length * 2 );
1114 $xsize_ratio = ( $bar_width / $tot_bar_length );
1116 PDF::Reuse::Barcode::Code39(
1117 x => ( $x_pos + ( $width / 10 ) ),
1118 y => ( $y_pos + ( $height / 10 ) ),
1119 value => "*$barcode*",
1120 ySize => ( .02 * $height ),
1121 xSize => $xsize_ratio,
1126 warn "$barcodetype, $barcode FAILED:$@";
1130 elsif ( $barcodetype eq 'CODE39MOD' ) {
1132 # get modulo43 checksum
1133 my $c39 = CheckDigits('code_39');
1134 $barcode = $c39->complete($barcode);
1138 ( $bar_length * $num_of_bars ) + ( $guard_length * 2 );
1139 $xsize_ratio = ( $bar_width / $tot_bar_length );
1141 PDF::Reuse::Barcode::Code39(
1142 x => ( $x_pos + ( $width / 10 ) ),
1143 y => ( $y_pos + ( $height / 10 ) ),
1144 value => "*$barcode*",
1145 ySize => ( .02 * $height ),
1146 xSize => $xsize_ratio,
1152 warn "$barcodetype, $barcode FAILED:$@";
1155 elsif ( $barcodetype eq 'CODE39MOD10' ) {
1157 # get modulo43 checksum
1158 my $c39_10 = CheckDigits('visa');
1159 $barcode = $c39_10->complete($barcode);
1163 ( $bar_length * $num_of_bars ) + ( $guard_length * 2 );
1164 $xsize_ratio = ( $bar_width / $tot_bar_length );
1166 PDF::Reuse::Barcode::Code39(
1167 x => ( $x_pos + ( $width / 10 ) ),
1168 y => ( $y_pos + ( $height / 10 ) ),
1169 value => "*$barcode*",
1170 ySize => ( .02 * $height ),
1171 xSize => $xsize_ratio,
1178 warn "$barcodetype, $barcode FAILED:$@";
1183 elsif ( $barcodetype eq 'COOP2OF5' ) {
1184 $bar_length = '9.43333333333333';
1186 ( $bar_length * $num_of_bars ) + ( $guard_length * 2 );
1187 $xsize_ratio = ( $bar_width / $tot_bar_length ) * .9;
1189 PDF::Reuse::Barcode::COOP2of5(
1190 x => ( $x_pos + ( $width / 10 ) ),
1191 y => ( $y_pos + ( $height / 10 ) ),
1193 ySize => ( .02 * $height ),
1194 xSize => $xsize_ratio,
1198 warn "$barcodetype, $barcode FAILED:$@";
1202 elsif ( $barcodetype eq 'INDUSTRIAL2OF5' ) {
1203 $bar_length = '13.1333333333333';
1205 ( $bar_length * $num_of_bars ) + ( $guard_length * 2 );
1206 $xsize_ratio = ( $bar_width / $tot_bar_length ) * .9;
1208 PDF::Reuse::Barcode::Industrial2of5(
1209 x => ( $x_pos + ( $width / 10 ) ),
1210 y => ( $y_pos + ( $height / 10 ) ),
1212 ySize => ( .02 * $height ),
1213 xSize => $xsize_ratio,
1217 warn "$barcodetype, $barcode FAILED:$@";
1221 my $moo2 = $tot_bar_length * $xsize_ratio;
1223 warn "$x_pos, $y_pos, $barcode, $barcodetype" if $debug;
1224 warn "BAR_WDTH = $bar_width, TOT.BAR.LGHT=$tot_bar_length R*TOT.BAR =$moo2" if $debug;
1227 =item build_circ_barcode;
1229 build_circ_barcode( $x_pos, $y_pos, $barcode,
1230 $barcodetype, \$item);
1232 $item is the result of a previous call to GetLabelItems();
1237 sub build_circ_barcode {
1238 my ( $x_pos_circ, $y_pos, $value, $barcodetype, $item ) = @_;
1240 #warn Dumper \$item;
1242 #warn "value = $value\n";
1246 if ( $barcodetype eq 'EAN13' ) {
1248 #testing EAN13 barcodes hack
1249 $value = $value . '000000000';
1251 $value = substr( $value, 0, 12 );
1255 PDF::Reuse::Barcode::EAN13(
1256 x => ( $x_pos_circ + 27 ),
1257 y => ( $y_pos + 15 ),
1265 # added for xpdf compat. doesnt use type3 fonts., but increases filesize from 20k to 200k
1266 # i think its embedding extra fonts in the pdf file.
1267 # mode => 'graphic',
1271 $item->{'barcodeerror'} = 1;
1273 #warn "EAN13BARCODE FAILED:$@";
1279 elsif ( $barcodetype eq 'Code39' ) {
1282 PDF::Reuse::Barcode::Code39(
1283 x => ( $x_pos_circ + 9 ),
1284 y => ( $y_pos + 15 ),
1294 $item->{'barcodeerror'} = 1;
1296 #warn "CODE39BARCODE $value FAILED:$@";
1303 elsif ( $barcodetype eq 'Matrix2of5' ) {
1305 #warn "MATRIX ELSE:";
1307 #testing MATRIX25 barcodes hack
1308 # $value = $value.'000000000';
1311 # $value = substr( $value, 0, 12 );
1315 PDF::Reuse::Barcode::Matrix2of5(
1316 x => ( $x_pos_circ + 27 ),
1317 y => ( $y_pos + 15 ),
1327 $item->{'barcodeerror'} = 1;
1329 #warn "BARCODE FAILED:$@";
1336 elsif ( $barcodetype eq 'EAN8' ) {
1338 #testing ean8 barcodes hack
1339 $value = $value . '000000000';
1341 $value = substr( $value, 0, 8 );
1345 #warn "EAN8 ELSEIF";
1347 PDF::Reuse::Barcode::EAN8(
1348 x => ( $x_pos_circ + 42 ),
1349 y => ( $y_pos + 15 ),
1359 $item->{'barcodeerror'} = 1;
1361 #warn "BARCODE FAILED:$@";
1368 elsif ( $barcodetype eq 'UPC-E' ) {
1370 PDF::Reuse::Barcode::UPCE(
1371 x => ( $x_pos_circ + 27 ),
1372 y => ( $y_pos + 15 ),
1382 $item->{'barcodeerror'} = 1;
1384 #warn "BARCODE FAILED:$@";
1390 elsif ( $barcodetype eq 'NW7' ) {
1392 PDF::Reuse::Barcode::NW7(
1393 x => ( $x_pos_circ + 27 ),
1394 y => ( $y_pos + 15 ),
1404 $item->{'barcodeerror'} = 1;
1406 #warn "BARCODE FAILED:$@";
1412 elsif ( $barcodetype eq 'ITF' ) {
1414 PDF::Reuse::Barcode::ITF(
1415 x => ( $x_pos_circ + 27 ),
1416 y => ( $y_pos + 15 ),
1426 $item->{'barcodeerror'} = 1;
1428 #warn "BARCODE FAILED:$@";
1434 elsif ( $barcodetype eq 'Industrial2of5' ) {
1436 PDF::Reuse::Barcode::Industrial2of5(
1437 x => ( $x_pos_circ + 27 ),
1438 y => ( $y_pos + 15 ),
1447 $item->{'barcodeerror'} = 1;
1449 #warn "BARCODE FAILED:$@";
1455 elsif ( $barcodetype eq 'IATA2of5' ) {
1457 PDF::Reuse::Barcode::IATA2of5(
1458 x => ( $x_pos_circ + 27 ),
1459 y => ( $y_pos + 15 ),
1468 $item->{'barcodeerror'} = 1;
1470 #warn "BARCODE FAILED:$@";
1477 elsif ( $barcodetype eq 'COOP2of5' ) {
1479 PDF::Reuse::Barcode::COOP2of5(
1480 x => ( $x_pos_circ + 27 ),
1481 y => ( $y_pos + 15 ),
1490 $item->{'barcodeerror'} = 1;
1492 #warn "BARCODE FAILED:$@";
1498 elsif ( $barcodetype eq 'UPC-A' ) {
1501 PDF::Reuse::Barcode::UPCA(
1502 x => ( $x_pos_circ + 27 ),
1503 y => ( $y_pos + 15 ),
1512 $item->{'barcodeerror'} = 1;
1514 #warn "BARCODE FAILED:$@";
1523 =item draw_boundaries
1525 sub draw_boundaries ($x_pos_spine, $x_pos_circ1, $x_pos_circ2,
1526 $y_pos, $spine_width, $label_height, $circ_width)
1528 This sub draws boundary lines where the label outlines are, to aid in printer testing, and debugging.
1533 sub draw_boundaries {
1536 $x_pos_spine, $x_pos_circ1, $x_pos_circ2, $y_pos,
1537 $spine_width, $label_height, $circ_width
1540 my $y_pos_initial = ( ( 792 - 36 ) - 90 );
1541 $y_pos = $y_pos_initial; # FIXME - why are we ignoring the y_pos parameter by redefining it?
1544 for ( $i = 1 ; $i <= 8 ; $i++ ) {
1546 &drawbox( $x_pos_spine, $y_pos, ($spine_width), ($label_height) );
1548 #warn "OLD BOXES x=$x_pos_spine, y=$y_pos, w=$spine_width, h=$label_height";
1549 &drawbox( $x_pos_circ1, $y_pos, ($circ_width), ($label_height) );
1550 &drawbox( $x_pos_circ2, $y_pos, ($circ_width), ($label_height) );
1552 $y_pos = ( $y_pos - $label_height );
1559 sub drawbox { $lower_left_x, $lower_left_y,
1560 $upper_right_x, $upper_right_y )
1562 this is a low level sub, that draws a pdf box, it is called by draw_boxes
1564 FYI: the $upper_right_x and $upper_right_y values are RELATIVE to $lower_left_x and $lower_left_y
1566 and $lower_left_x, $lower_left_y are ABSOLUTE, this caught me out!
1572 my ( $llx, $lly, $urx, $ury ) = @_;
1574 # warn "llx,y= $llx,$lly , urx,y=$urx,$ury \n";
1576 my $str = "q\n"; # save the graphic state
1577 $str .= "0.5 w\n"; # border color red
1578 $str .= "1.0 0.0 0.0 RG\n"; # border color red
1579 # $str .= "0.5 0.75 1.0 rg\n"; # fill color blue
1580 $str .= "1.0 1.0 1.0 rg\n"; # fill color white
1582 $str .= "$llx $lly $urx $ury re\n"; # a rectangle
1583 $str .= "B\n"; # fill (and a little more)
1584 $str .= "Q\n"; # save the graphic state
1590 END { } # module clean-up code here (global destructor)
1599 Mason James <mason@katipo.co.nz>