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, $text_justify, $callnum_split,
513 $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 text_justify, callnum_split, 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, $text_justify, $callnum_split,
531 $itemcallnumber, $author, $printingtype,
532 $guidebox, $startlabel, $layoutname, $formatstring
536 SetActiveTemplate($tmpl_id);
543 $barcodetype, $title, $subtitle, $isbn, $issn,
544 $itemtype, $bcn, $text_justify, $callnum_split,
545 $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=?, text_justify=?, callnum_split=?,
556 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, $text_justify, $callnum_split,
562 $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 = ();
752 $sth = $dbh->prepare($query3);
753 $sth->execute($batch_id);
759 $sth = $dbh->prepare($query3);
762 my $cnt = $sth->rows;
764 while ( my $data = $sth->fetchrow_hashref ) {
766 # lets get some summary info from each item
768 # FIXME This makes for a very bulky data structure; data from tables w/duplicate col names also gets overwritten.
769 # Something like this, perhaps, but this also causes problems because we need more fields sometimes.
770 # SELECT i.barcode, i.itemcallnumber, i.itype, bi.isbn, bi.issn, b.title, b.author
771 "SELECT bi.*, i.*, b.*
772 FROM items AS i, biblioitems AS bi ,biblio AS b
773 WHERE itemnumber=? AND i.biblioitemnumber=bi.biblioitemnumber AND bi.biblionumber=b.biblionumber";
774 my $sth1 = $dbh->prepare($query1);
775 $sth1->execute( $data->{'itemnumber'} );
777 my $data1 = $sth1->fetchrow_hashref();
778 $data1->{'labelno'} = $i1;
779 $data1->{'labelid'} = $data->{'labelid'};
780 $data1->{'batch_id'} = $batch_id;
781 $data1->{'summary'} = "$data1->{'barcode'}, $data1->{'title'}, $data1->{'isbn'}";
783 push( @resultsloop, $data1 );
806 Parse labels_conf.formatstring value
807 (one value of the csv, which has already been split)
808 and return string from koha tables or MARC record.
813 my ( $f, $item, $record ) = @_;
814 my $kohatables = &_descKohaTables();
816 warn Dumper($kohatables);
818 my $match_kohatable = join(
821 @{ $kohatables->{biblio} },
822 @{ $kohatables->{biblioitems} },
823 @{ $kohatables->{items} }
826 while ($f) { warn $f;
828 if ( $f =~ /^'(.*)'.*/ ) {
829 # single quotes indicate a static text string.
833 elsif ( $f =~ /^($match_kohatable).*/ ) {
834 $datastring .= $item->{$f};
837 elsif ( $f =~ /^([0-9a-z]{3})(\w)(\W?).*?/ ) {
839 $datastring .= $record->subfield($1,$2) . $3 if($record->subfield($1,$2)) ;
840 foreach my $subfield ($record->field($marc_field)) {
841 if ( $subfield->subfield('9') eq $item->{'itemnumber'} ) {
842 $datastring .= $subfield->subfield($2 ) . $3;
849 warn "failed to parse label formatstring: $f";
850 last; # Failed to match
857 Return a hashref of an array of hashes,
861 sub _descKohaTables {
862 my $dbh = C4::Context->dbh();
864 for my $table ( 'biblio','biblioitems','items' ) {
865 my $sth = $dbh->column_info(undef,undef,$table,'%');
866 while (my $info = $sth->fetchrow_hashref()){
867 push @{$kohatables->{$table}} , $info->{'COLUMN_NAME'} ;
874 sub GetPatronCardItems {
876 my ( $batch_id ) = @_;
879 my $dbh = C4::Context->dbh;
880 # my $query = "SELECT * FROM patroncards WHERE batch_id = ? ORDER BY borrowernumber";
881 my $query = "SELECT * FROM patroncards WHERE batch_id = ? ORDER BY cardid";
882 my $sth = $dbh->prepare($query);
883 $sth->execute($batch_id);
885 while ( my $data = $sth->fetchrow_hashref ) {
886 my $patron_data = GetMember( $data->{'borrowernumber'} );
887 $patron_data->{'branchname'} = GetBranchName( $patron_data->{'branchcode'} );
888 $patron_data->{'cardno'} = $cardno;
889 $patron_data->{'cardid'} = $data->{'cardid'};
890 $patron_data->{'batch_id'} = $batch_id;
891 push( @resultsloop, $patron_data );
899 sub deduplicate_batch {
900 my ( $batch_id, $batch_type ) = @_;
903 batch_id," . (($batch_type eq 'labels') ? 'itemnumber' : 'borrowernumber') . ",
904 count(". (($batch_type eq 'labels') ? 'labelid' : 'cardid') . ") as count
907 GROUP BY " . (($batch_type eq 'labels') ? 'itemnumber' : 'borrowernumber') . ",batch_id
911 my $sth = C4::Context->dbh->prepare($query);
912 $sth->execute($batch_id);
913 warn $sth->errstr if $sth->errstr;
914 $sth->rows or return undef, $sth->errstr;
920 AND " . (($batch_type eq 'labels') ? 'itemnumber' : 'borrowernumber') . " = ?
921 ORDER BY timestamp ASC
924 while (my $data = $sth->fetchrow_hashref()) {
925 my $itemnumber = $data->{(($batch_type eq 'labels') ? 'itemnumber' : 'borrowernumber')} or next;
926 my $limit = $data->{count} - 1 or next;
927 my $sth2 = C4::Context->dbh->prepare("$del_query LIMIT $limit");
928 # die sprintf "$del_query LIMIT %s\n (%s, %s)", $limit, $batch_id, $itemnumber;
929 # $sth2->execute($batch_id, C4::Context->dbh->quote($data->{itemnumber}), $data->{count} - 1)
930 $sth2->execute($batch_id, $itemnumber) and
931 $killed += ($data->{count} - 1);
932 warn $sth2->errstr if $sth2->errstr;
934 return $killed, undef;
939 my ($ll, $wnl, $dec, $cutter, $pubdate) = (0, 0, 0, 0, 0);
941 # lccn example 'HE8700.7 .P6T44 1983';
944 ([0-9]+\.*[0-9]*) # 8700.7
946 (\.*[a-zA-Z0-9]*) # P6T44
951 # strip something occuring spaces too
952 $splits[0] =~ s/\s+$//;
953 $splits[1] =~ s/\s+$//;
954 $splits[2] =~ s/\s+$//;
961 $ddcn =~ s/\///g; # in theory we should be able to simply remove all segmentation markers and arrive at the correct call number...
963 # ddcn example R220.3 H2793Z H32 c.2
964 my @splits = m/^([A-Z]{0,3}) # R (OS, REF, etc. up do three letters)
965 ([0-9]+\.[0-9]*) # 220.3
966 \s? # space (not requiring anything beyond the call number)
967 ([a-zA-Z0-9]*\.?[a-zA-Z0-9])# cutter number... maybe, but if so it is in this position (Z indicates literary criticism)
968 \s? # space if it exists
969 ([a-zA-Z]*\.?[0-9]*) # other indicators such as cutter for author of literary criticism in this example if it exists
970 \s? # space if ie exists
971 ([a-zA-Z]*\.?[0-9]*) # other indicators such as volume number, copy number, edition date, etc. if it exists
979 # Split fiction call numbers based on spaces
982 if ($fcn =~ m/([A-Za-z0-9]+)(\W?).*?/x) {
983 push (@fcn_split, $1);
987 last SPLIT_FCN; # No match, break out of the loop
995 my ( $x_pos, $y_pos, $label_height, $label_width, $fontname, $fontsize, $left_text_margin,
996 $text_wrap_cols, $item, $conf_data, $printingtype ) = @_;
998 # Replaced item's itemtype with the more user-friendly description...
999 my $dbh = C4::Context->dbh;
1000 my $sth = $dbh->prepare("SELECT itemtype,description FROM itemtypes");
1002 while ( my $data = $sth->fetchrow_hashref ) {
1003 $$item->{'itemtype'} = $data->{'description'} if ($$item->{'itemtype'} eq $data->{'itemtype'});
1004 $$item->{'itype'} = $data->{'description'} if ($$item->{'itype'} eq $data->{'itemtype'});
1009 my $top_text_margin = ( $fontsize + 3 ); #FIXME: This should be a template parameter and passed in...
1010 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.).
1012 my $layout_id = $$conf_data->{'id'};
1014 my $vPos = ( $y_pos + ( $label_height - $top_text_margin ) );
1016 my @str_fields = get_text_fields($layout_id, 'codes' );
1017 my $record = GetMarcBiblio($$item->{biblionumber});
1018 # FIXME - returns all items, so you can't get data from an embedded holdings field.
1019 # TODO - add a GetMarcBiblio1item(bibnum,itemnum) or a GetMarcItem(itemnum).
1021 my $old_fontname = $fontname; # We need to keep track of the original font passed in...
1023 # Grab the cn_source and if that is NULL, the DefaultClassificationSource syspref
1024 my $cn_source = ($$item->{'cn_source'} ? $$item->{'cn_source'} : C4::Context->preference('DefaultClassificationSource'));
1025 for my $field (@str_fields) {
1026 $field->{'code'} or warn "get_text_fields($layout_id, 'codes') element missing 'code' field";
1027 if ($field->{'code'} eq 'itemtype') {
1028 $field->{'data'} = C4::Context->preference('item-level_itypes') ? $$item->{'itype'} : $$item->{'itemtype'};
1030 elsif ($$conf_data->{'formatstring'}) {
1031 # if labels_conf.formatstring has a value, then it overrides the hardcoded option.
1032 $field->{'data'} = GetBarcodeData($field->{'code'},$$item,$record) ;
1035 $field->{data} = $$item->{$field->{'code'}} ;
1037 # This allows us to print the title in italic (oblique) type... (Times Roman has a different nomenclature.)
1038 # It seems there should be a better way to handle fonts in the label/patron card tool altogether -fbcit
1039 ($field->{code} eq 'title') ? (($old_fontname =~ /T/) ? ($fontname = 'TI') : ($fontname = ($old_fontname . 'O'))) : ($fontname = $old_fontname);
1040 my $font = prFont($fontname);
1041 # if the display option for this field is selected in the DB,
1042 # and the item record has some values for this field, display it.
1043 # Or if there is a csv list of fields to display, display them.
1044 if ( ($$conf_data->{'formatstring'}) || ( $$conf_data->{$field->{code}} && $$item->{$field->{code}} ) ) {
1046 my $str = $field->{data} ;
1047 # strip out naughty existing nl/cr's
1051 my @callnumber_list = ('itemcallnumber', '050a', '050b', '082a', '952o'); # Fields which hold call number data ( 060? 090? 092? 099? )
1052 if ((grep {$field->{code} =~ m/$_/} @callnumber_list) and ($printingtype eq 'BIB') and ($$conf_data->{'callnum_split'})) { # If the field contains the call number, we do some sp
1053 if ($cn_source eq 'lcc') {
1054 @strings = split_lccn($str);
1055 @strings = split_fcn($str) if !@strings; # If it was not a true lccn, try it as a fiction call number
1056 push (@strings, $str) if !@strings; # If it was not that, send it on unsplit
1057 } elsif ($cn_source eq 'ddc') {
1058 @strings = split_ddcn($str);
1059 @strings = split_fcn($str) if !@strings;
1060 push (@strings, $str) if !@strings;
1062 # FIXME Need error trapping here; something to be informative to the user perhaps -crn
1063 push @strings, $str;
1066 $str =~ s/\/$//g; # Here we will strip out all trailing '/' in fields other than the call number...
1067 $str =~ s/\(/\\\(/g; # Escape '(' and ')' for the postscript stream...
1068 $str =~ s/\)/\\\)/g;
1069 # Wrap text lines exceeding $text_wrap_cols length...
1070 $Text::Wrap::columns = $text_wrap_cols;
1071 my @line = split(/\n/ ,wrap('', '', $str));
1072 # If this is a title field, limit to two lines; all others limit to one...
1073 if ($field->{code} eq 'title' && scalar(@line) >= 2) {
1074 while (scalar(@line) > 2) {
1078 while (scalar(@line) > 1) {
1082 push(@strings, @line);
1084 # loop for each string line
1085 foreach my $str (@strings) {
1087 my $stringwidth = prStrWidth($str, $fontname, $fontsize);
1088 if ( $$conf_data->{'text_justify'} eq 'R' ) {
1089 $hPos = $x_pos + $label_width - ( $left_text_margin + $stringwidth );
1090 } elsif($$conf_data->{'text_justify'} eq 'C') {
1091 # some code to try and center each line on the label based on font size and string point width...
1092 my $whitespace = ( $label_width - ( $stringwidth + (2 * $left_text_margin) ) );
1093 $hPos = ( ( $whitespace / 2 ) + $x_pos + $left_text_margin );
1094 #warn "\$label_width=$label_width \$stringwidth=$stringwidth \$whitespace=$whitespace \$left_text_margin=$left_text_margin for $str\n";
1096 $hPos = ( $x_pos + $left_text_margin );
1098 PrintText( $hPos, $vPos, $font, $fontsize, $str );
1099 $vPos = $vPos - $line_spacer;
1106 my ( $hPos, $vPos, $font, $fontsize, $text ) = @_;
1107 my $str = "BT /$font $fontsize Tf $hPos $vPos Td ($text) Tj ET";
1111 sub DrawPatronCardText {
1113 my ( $x_pos, $y_pos, $label_height, $label_width, $fontname, $fontsize, $left_text_margin,
1114 $text_wrap_cols, $text, $printingtype )
1117 my $top_text_margin = 25; #FIXME: This should be a template parameter and passed in...
1119 my $vPos = ( $y_pos + ( $label_height - $top_text_margin ) );
1120 my $font = prFont($fontname);
1124 foreach my $line (keys %$text) {
1125 $debug and warn "Current text is \"$line\" and font size for \"$line\" is $text->{$line} points";
1126 # some code to try and center each line on the label based on font size and string point width...
1127 my $stringwidth = prStrWidth($line, $fontname, $text->{$line});
1128 my $whitespace = ( $label_width - ( $stringwidth + (2 * $left_text_margin) ) );
1129 $hPos = ( ( $whitespace / 2 ) + $x_pos + $left_text_margin );
1131 PrintText( $hPos, $vPos, $font, $text->{$line}, $line );
1132 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.).
1133 $vPos = $vPos - ($line_spacer + $text->{$line}); # Linefeed equiv: leading + font size
1137 # Not used anywhere.
1141 # my ($fontsize) = @_;
1143 # my $str = "BT/F13 30 Tf288 720 Td( AAAAAAAAAA ) TjET";
1149 # x and y are from the top-left :)
1150 my ( $x_pos, $y_pos, $height, $width, $barcode, $barcodetype ) = @_;
1151 my $num_of_bars = length($barcode);
1152 my $bar_width = $width * .8; # %80 of length of label width
1153 my $tot_bar_length = 0;
1155 my $guard_length = 10;
1156 my $xsize_ratio = 0;
1158 if ( $barcodetype eq 'CODE39' ) {
1159 $bar_length = '17.5';
1161 ( $bar_length * $num_of_bars ) + ( $guard_length * 2 );
1162 $xsize_ratio = ( $bar_width / $tot_bar_length );
1164 PDF::Reuse::Barcode::Code39(
1165 x => ( $x_pos + ( $width / 10 ) ),
1166 y => ( $y_pos + ( $height / 10 ) ),
1167 value => "*$barcode*",
1168 ySize => ( .02 * $height ),
1169 xSize => $xsize_ratio,
1174 warn "$barcodetype, $barcode FAILED:$@";
1178 elsif ( $barcodetype eq 'CODE39MOD' ) {
1180 # get modulo43 checksum
1181 my $c39 = CheckDigits('code_39');
1182 $barcode = $c39->complete($barcode);
1186 ( $bar_length * $num_of_bars ) + ( $guard_length * 2 );
1187 $xsize_ratio = ( $bar_width / $tot_bar_length );
1189 PDF::Reuse::Barcode::Code39(
1190 x => ( $x_pos + ( $width / 10 ) ),
1191 y => ( $y_pos + ( $height / 10 ) ),
1192 value => "*$barcode*",
1193 ySize => ( .02 * $height ),
1194 xSize => $xsize_ratio,
1200 warn "$barcodetype, $barcode FAILED:$@";
1203 elsif ( $barcodetype eq 'CODE39MOD10' ) {
1205 # get modulo43 checksum
1206 my $c39_10 = CheckDigits('visa');
1207 $barcode = $c39_10->complete($barcode);
1211 ( $bar_length * $num_of_bars ) + ( $guard_length * 2 );
1212 $xsize_ratio = ( $bar_width / $tot_bar_length );
1214 PDF::Reuse::Barcode::Code39(
1215 x => ( $x_pos + ( $width / 10 ) ),
1216 y => ( $y_pos + ( $height / 10 ) ),
1217 value => "*$barcode*",
1218 ySize => ( .02 * $height ),
1219 xSize => $xsize_ratio,
1226 warn "$barcodetype, $barcode FAILED:$@";
1231 elsif ( $barcodetype eq 'COOP2OF5' ) {
1232 $bar_length = '9.43333333333333';
1234 ( $bar_length * $num_of_bars ) + ( $guard_length * 2 );
1235 $xsize_ratio = ( $bar_width / $tot_bar_length ) * .9;
1237 PDF::Reuse::Barcode::COOP2of5(
1238 x => ( $x_pos + ( $width / 10 ) ),
1239 y => ( $y_pos + ( $height / 10 ) ),
1241 ySize => ( .02 * $height ),
1242 xSize => $xsize_ratio,
1246 warn "$barcodetype, $barcode FAILED:$@";
1250 elsif ( $barcodetype eq 'INDUSTRIAL2OF5' ) {
1251 $bar_length = '13.1333333333333';
1253 ( $bar_length * $num_of_bars ) + ( $guard_length * 2 );
1254 $xsize_ratio = ( $bar_width / $tot_bar_length ) * .9;
1256 PDF::Reuse::Barcode::Industrial2of5(
1257 x => ( $x_pos + ( $width / 10 ) ),
1258 y => ( $y_pos + ( $height / 10 ) ),
1260 ySize => ( .02 * $height ),
1261 xSize => $xsize_ratio,
1265 warn "$barcodetype, $barcode FAILED:$@";
1269 my $moo2 = $tot_bar_length * $xsize_ratio;
1271 warn "$x_pos, $y_pos, $barcode, $barcodetype" if $debug;
1272 warn "BAR_WDTH = $bar_width, TOT.BAR.LGHT=$tot_bar_length R*TOT.BAR =$moo2" if $debug;
1275 =item build_circ_barcode;
1277 build_circ_barcode( $x_pos, $y_pos, $barcode,
1278 $barcodetype, \$item);
1280 $item is the result of a previous call to GetLabelItems();
1285 sub build_circ_barcode {
1286 my ( $x_pos_circ, $y_pos, $value, $barcodetype, $item ) = @_;
1288 #warn Dumper \$item;
1290 #warn "value = $value\n";
1294 if ( $barcodetype eq 'EAN13' ) {
1296 #testing EAN13 barcodes hack
1297 $value = $value . '000000000';
1299 $value = substr( $value, 0, 12 );
1303 PDF::Reuse::Barcode::EAN13(
1304 x => ( $x_pos_circ + 27 ),
1305 y => ( $y_pos + 15 ),
1313 # added for xpdf compat. doesnt use type3 fonts., but increases filesize from 20k to 200k
1314 # i think its embedding extra fonts in the pdf file.
1315 # mode => 'graphic',
1319 $item->{'barcodeerror'} = 1;
1321 #warn "EAN13BARCODE FAILED:$@";
1327 elsif ( $barcodetype eq 'Code39' ) {
1330 PDF::Reuse::Barcode::Code39(
1331 x => ( $x_pos_circ + 9 ),
1332 y => ( $y_pos + 15 ),
1342 $item->{'barcodeerror'} = 1;
1344 #warn "CODE39BARCODE $value FAILED:$@";
1351 elsif ( $barcodetype eq 'Matrix2of5' ) {
1353 #warn "MATRIX ELSE:";
1355 #testing MATRIX25 barcodes hack
1356 # $value = $value.'000000000';
1359 # $value = substr( $value, 0, 12 );
1363 PDF::Reuse::Barcode::Matrix2of5(
1364 x => ( $x_pos_circ + 27 ),
1365 y => ( $y_pos + 15 ),
1375 $item->{'barcodeerror'} = 1;
1377 #warn "BARCODE FAILED:$@";
1384 elsif ( $barcodetype eq 'EAN8' ) {
1386 #testing ean8 barcodes hack
1387 $value = $value . '000000000';
1389 $value = substr( $value, 0, 8 );
1393 #warn "EAN8 ELSEIF";
1395 PDF::Reuse::Barcode::EAN8(
1396 x => ( $x_pos_circ + 42 ),
1397 y => ( $y_pos + 15 ),
1407 $item->{'barcodeerror'} = 1;
1409 #warn "BARCODE FAILED:$@";
1416 elsif ( $barcodetype eq 'UPC-E' ) {
1418 PDF::Reuse::Barcode::UPCE(
1419 x => ( $x_pos_circ + 27 ),
1420 y => ( $y_pos + 15 ),
1430 $item->{'barcodeerror'} = 1;
1432 #warn "BARCODE FAILED:$@";
1438 elsif ( $barcodetype eq 'NW7' ) {
1440 PDF::Reuse::Barcode::NW7(
1441 x => ( $x_pos_circ + 27 ),
1442 y => ( $y_pos + 15 ),
1452 $item->{'barcodeerror'} = 1;
1454 #warn "BARCODE FAILED:$@";
1460 elsif ( $barcodetype eq 'ITF' ) {
1462 PDF::Reuse::Barcode::ITF(
1463 x => ( $x_pos_circ + 27 ),
1464 y => ( $y_pos + 15 ),
1474 $item->{'barcodeerror'} = 1;
1476 #warn "BARCODE FAILED:$@";
1482 elsif ( $barcodetype eq 'Industrial2of5' ) {
1484 PDF::Reuse::Barcode::Industrial2of5(
1485 x => ( $x_pos_circ + 27 ),
1486 y => ( $y_pos + 15 ),
1495 $item->{'barcodeerror'} = 1;
1497 #warn "BARCODE FAILED:$@";
1503 elsif ( $barcodetype eq 'IATA2of5' ) {
1505 PDF::Reuse::Barcode::IATA2of5(
1506 x => ( $x_pos_circ + 27 ),
1507 y => ( $y_pos + 15 ),
1516 $item->{'barcodeerror'} = 1;
1518 #warn "BARCODE FAILED:$@";
1525 elsif ( $barcodetype eq 'COOP2of5' ) {
1527 PDF::Reuse::Barcode::COOP2of5(
1528 x => ( $x_pos_circ + 27 ),
1529 y => ( $y_pos + 15 ),
1538 $item->{'barcodeerror'} = 1;
1540 #warn "BARCODE FAILED:$@";
1546 elsif ( $barcodetype eq 'UPC-A' ) {
1549 PDF::Reuse::Barcode::UPCA(
1550 x => ( $x_pos_circ + 27 ),
1551 y => ( $y_pos + 15 ),
1560 $item->{'barcodeerror'} = 1;
1562 #warn "BARCODE FAILED:$@";
1571 =item draw_boundaries
1573 sub draw_boundaries ($x_pos_spine, $x_pos_circ1, $x_pos_circ2,
1574 $y_pos, $spine_width, $label_height, $circ_width)
1576 This sub draws boundary lines where the label outlines are, to aid in printer testing, and debugging.
1581 sub draw_boundaries {
1584 $x_pos_spine, $x_pos_circ1, $x_pos_circ2, $y_pos,
1585 $spine_width, $label_height, $circ_width
1588 my $y_pos_initial = ( ( 792 - 36 ) - 90 );
1589 $y_pos = $y_pos_initial; # FIXME - why are we ignoring the y_pos parameter by redefining it?
1592 for ( $i = 1 ; $i <= 8 ; $i++ ) {
1594 &drawbox( $x_pos_spine, $y_pos, ($spine_width), ($label_height) );
1596 #warn "OLD BOXES x=$x_pos_spine, y=$y_pos, w=$spine_width, h=$label_height";
1597 &drawbox( $x_pos_circ1, $y_pos, ($circ_width), ($label_height) );
1598 &drawbox( $x_pos_circ2, $y_pos, ($circ_width), ($label_height) );
1600 $y_pos = ( $y_pos - $label_height );
1607 sub drawbox { $lower_left_x, $lower_left_y,
1608 $upper_right_x, $upper_right_y )
1610 this is a low level sub, that draws a pdf box, it is called by draw_boxes
1612 FYI: the $upper_right_x and $upper_right_y values are RELATIVE to $lower_left_x and $lower_left_y
1614 and $lower_left_x, $lower_left_y are ABSOLUTE, this caught me out!
1620 my ( $llx, $lly, $urx, $ury ) = @_;
1622 # warn "llx,y= $llx,$lly , urx,y=$urx,$ury \n";
1624 my $str = "q\n"; # save the graphic state
1625 $str .= "0.5 w\n"; # border color red
1626 $str .= "1.0 0.0 0.0 RG\n"; # border color red
1627 # $str .= "0.5 0.75 1.0 rg\n"; # fill color blue
1628 $str .= "1.0 1.0 1.0 rg\n"; # fill color white
1630 $str .= "$llx $lly $urx $ury re\n"; # a rectangle
1631 $str .= "B\n"; # fill (and a little more)
1632 $str .= "Q\n"; # save the graphic state
1638 END { } # module clean-up code here (global destructor)
1647 Mason James <mason@katipo.co.nz>