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 my $match_kohatable = join(
819 @{ $kohatables->{biblio} },
820 @{ $kohatables->{biblioitems} },
821 @{ $kohatables->{items} }
826 if ( $f =~ /^'(.*)'.*/ ) {
827 # single quotes indicate a static text string.
831 elsif ( $f =~ /^($match_kohatable).*/ ) {
832 $datastring .= $item->{$f};
835 elsif ( $f =~ /^([0-9a-z]{3})(\w)(\W?).*?/ ) {
836 my ($field,$subf,$ws) = ($1,$2,$3);
838 my ($itemtag, $itemsubfieldcode) = &GetMarcFromKohaField("items.itemnumber",'');
839 my @marcfield = $record->field($field);
841 if($field eq $itemtag) { # item-level data, we need to get the right item.
842 foreach my $itemfield (@marcfield) {
843 if ( $itemfield->subfield($itemsubfieldcode) eq $item->{'itemnumber'} ) {
844 $datastring .= $itemfield->subfield($subf ) . $ws;
848 } else { # bib-level data, we'll take the first matching tag/subfield.
849 $datastring .= $marcfield[0]->subfield($subf) . $ws ;
855 warn "failed to parse label formatstring: $f";
856 last; # Failed to match
863 Return a hashref of an array of hashes,
867 sub _descKohaTables {
868 my $dbh = C4::Context->dbh();
870 for my $table ( 'biblio','biblioitems','items' ) {
871 my $sth = $dbh->column_info(undef,undef,$table,'%');
872 while (my $info = $sth->fetchrow_hashref()){
873 push @{$kohatables->{$table}} , $info->{'COLUMN_NAME'} ;
880 sub GetPatronCardItems {
882 my ( $batch_id ) = @_;
885 my $dbh = C4::Context->dbh;
886 # my $query = "SELECT * FROM patroncards WHERE batch_id = ? ORDER BY borrowernumber";
887 my $query = "SELECT * FROM patroncards WHERE batch_id = ? ORDER BY cardid";
888 my $sth = $dbh->prepare($query);
889 $sth->execute($batch_id);
891 while ( my $data = $sth->fetchrow_hashref ) {
892 my $patron_data = GetMember( $data->{'borrowernumber'} );
893 $patron_data->{'branchname'} = GetBranchName( $patron_data->{'branchcode'} );
894 $patron_data->{'cardno'} = $cardno;
895 $patron_data->{'cardid'} = $data->{'cardid'};
896 $patron_data->{'batch_id'} = $batch_id;
897 push( @resultsloop, $patron_data );
905 sub deduplicate_batch {
906 my ( $batch_id, $batch_type ) = @_;
909 batch_id," . (($batch_type eq 'labels') ? 'itemnumber' : 'borrowernumber') . ",
910 count(". (($batch_type eq 'labels') ? 'labelid' : 'cardid') . ") as count
913 GROUP BY " . (($batch_type eq 'labels') ? 'itemnumber' : 'borrowernumber') . ",batch_id
917 my $sth = C4::Context->dbh->prepare($query);
918 $sth->execute($batch_id);
919 warn $sth->errstr if $sth->errstr;
920 $sth->rows or return undef, $sth->errstr;
926 AND " . (($batch_type eq 'labels') ? 'itemnumber' : 'borrowernumber') . " = ?
927 ORDER BY timestamp ASC
930 while (my $data = $sth->fetchrow_hashref()) {
931 my $itemnumber = $data->{(($batch_type eq 'labels') ? 'itemnumber' : 'borrowernumber')} or next;
932 my $limit = $data->{count} - 1 or next;
933 my $sth2 = C4::Context->dbh->prepare("$del_query LIMIT $limit");
934 # die sprintf "$del_query LIMIT %s\n (%s, %s)", $limit, $batch_id, $itemnumber;
935 # $sth2->execute($batch_id, C4::Context->dbh->quote($data->{itemnumber}), $data->{count} - 1)
936 $sth2->execute($batch_id, $itemnumber) and
937 $killed += ($data->{count} - 1);
938 warn $sth2->errstr if $sth2->errstr;
940 return $killed, undef;
945 my ($ll, $wnl, $dec, $cutter, $pubdate) = (0, 0, 0, 0, 0);
947 # lccn example 'HE8700.7 .P6T44 1983';
950 ([0-9]+\.*[0-9]*) # 8700.7
952 (\.*[a-zA-Z0-9]*) # P6T44
957 # strip something occuring spaces too
958 $splits[0] =~ s/\s+$//;
959 $splits[1] =~ s/\s+$//;
960 $splits[2] =~ s/\s+$//;
967 $ddcn =~ s/\///g; # in theory we should be able to simply remove all segmentation markers and arrive at the correct call number...
969 # ddcn example R220.3 H2793Z H32 c.2
970 my @splits = m/^([A-Z]{0,3}) # R (OS, REF, etc. up do three letters)
971 ([0-9]+\.[0-9]*) # 220.3
972 \s? # space (not requiring anything beyond the call number)
973 ([a-zA-Z0-9]*\.?[a-zA-Z0-9])# cutter number... maybe, but if so it is in this position (Z indicates literary criticism)
974 \s? # space if it exists
975 ([a-zA-Z]*\.?[0-9]*) # other indicators such as cutter for author of literary criticism in this example if it exists
976 \s? # space if ie exists
977 ([a-zA-Z]*\.?[0-9]*) # other indicators such as volume number, copy number, edition date, etc. if it exists
985 # Split fiction call numbers based on spaces
988 if ($fcn =~ m/([A-Za-z0-9]+)(\W?).*?/x) {
989 push (@fcn_split, $1);
993 last SPLIT_FCN; # No match, break out of the loop
1001 my ( $x_pos, $y_pos, $label_height, $label_width, $fontname, $fontsize, $left_text_margin,
1002 $text_wrap_cols, $item, $conf_data, $printingtype ) = @_;
1004 # Replaced item's itemtype with the more user-friendly description...
1005 my $dbh = C4::Context->dbh;
1006 my $sth = $dbh->prepare("SELECT itemtype,description FROM itemtypes");
1008 while ( my $data = $sth->fetchrow_hashref ) {
1009 $$item->{'itemtype'} = $data->{'description'} if ($$item->{'itemtype'} eq $data->{'itemtype'});
1010 $$item->{'itype'} = $data->{'description'} if ($$item->{'itype'} eq $data->{'itemtype'});
1015 my $top_text_margin = ( $fontsize + 3 ); #FIXME: This should be a template parameter and passed in...
1016 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.).
1018 my $layout_id = $$conf_data->{'id'};
1020 my $vPos = ( $y_pos + ( $label_height - $top_text_margin ) );
1022 my @str_fields = get_text_fields($layout_id, 'codes' );
1023 my $record = GetMarcBiblio($$item->{biblionumber});
1024 # FIXME - returns all items, so you can't get data from an embedded holdings field.
1025 # TODO - add a GetMarcBiblio1item(bibnum,itemnum) or a GetMarcItem(itemnum).
1027 my $old_fontname = $fontname; # We need to keep track of the original font passed in...
1029 # Grab the cn_source and if that is NULL, the DefaultClassificationSource syspref
1030 my $cn_source = ($$item->{'cn_source'} ? $$item->{'cn_source'} : C4::Context->preference('DefaultClassificationSource'));
1031 for my $field (@str_fields) {
1032 $field->{'code'} or warn "get_text_fields($layout_id, 'codes') element missing 'code' field";
1033 if ($field->{'code'} eq 'itemtype') {
1034 $field->{'data'} = C4::Context->preference('item-level_itypes') ? $$item->{'itype'} : $$item->{'itemtype'};
1036 elsif ($$conf_data->{'formatstring'}) {
1037 # if labels_conf.formatstring has a value, then it overrides the hardcoded option.
1038 $field->{'data'} = GetBarcodeData($field->{'code'},$$item,$record) ;
1041 $field->{data} = $$item->{$field->{'code'}} ;
1043 # This allows us to print the title in italic (oblique) type... (Times Roman has a different nomenclature.)
1044 # It seems there should be a better way to handle fonts in the label/patron card tool altogether -fbcit
1045 ($field->{code} eq 'title') ? (($old_fontname =~ /T/) ? ($fontname = 'TI') : ($fontname = ($old_fontname . 'O'))) : ($fontname = $old_fontname);
1046 my $font = prFont($fontname);
1047 # if the display option for this field is selected in the DB,
1048 # and the item record has some values for this field, display it.
1049 # Or if there is a csv list of fields to display, display them.
1050 if ( ($$conf_data->{'formatstring'}) || ( $$conf_data->{$field->{code}} && $$item->{$field->{code}} ) ) {
1052 my $str = $field->{data} ;
1053 # strip out naughty existing nl/cr's
1057 my @callnumber_list = ('itemcallnumber', '050a', '050b', '082a', '952o'); # Fields which hold call number data ( 060? 090? 092? 099? )
1058 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
1059 if ($cn_source eq 'lcc') {
1060 @strings = split_lccn($str);
1061 @strings = split_fcn($str) if !@strings; # If it was not a true lccn, try it as a fiction call number
1062 push (@strings, $str) if !@strings; # If it was not that, send it on unsplit
1063 } elsif ($cn_source eq 'ddc') {
1064 @strings = split_ddcn($str);
1065 @strings = split_fcn($str) if !@strings;
1066 push (@strings, $str) if !@strings;
1068 # FIXME Need error trapping here; something to be informative to the user perhaps -crn
1069 push @strings, $str;
1072 $str =~ s/\/$//g; # Here we will strip out all trailing '/' in fields other than the call number...
1073 $str =~ s/\(/\\\(/g; # Escape '(' and ')' for the postscript stream...
1074 $str =~ s/\)/\\\)/g;
1075 # Wrap text lines exceeding $text_wrap_cols length...
1076 $Text::Wrap::columns = $text_wrap_cols;
1077 my @line = split(/\n/ ,wrap('', '', $str));
1078 # If this is a title field, limit to two lines; all others limit to one...
1079 if ($field->{code} eq 'title' && scalar(@line) >= 2) {
1080 while (scalar(@line) > 2) {
1084 while (scalar(@line) > 1) {
1088 push(@strings, @line);
1090 # loop for each string line
1091 foreach my $str (@strings) {
1093 my $stringwidth = prStrWidth($str, $fontname, $fontsize);
1094 if ( $$conf_data->{'text_justify'} eq 'R' ) {
1095 $hPos = $x_pos + $label_width - ( $left_text_margin + $stringwidth );
1096 } elsif($$conf_data->{'text_justify'} eq 'C') {
1097 # some code to try and center each line on the label based on font size and string point width...
1098 my $whitespace = ( $label_width - ( $stringwidth + (2 * $left_text_margin) ) );
1099 $hPos = ( ( $whitespace / 2 ) + $x_pos + $left_text_margin );
1100 #warn "\$label_width=$label_width \$stringwidth=$stringwidth \$whitespace=$whitespace \$left_text_margin=$left_text_margin for $str\n";
1102 $hPos = ( $x_pos + $left_text_margin );
1104 PrintText( $hPos, $vPos, $font, $fontsize, $str );
1105 $vPos = $vPos - $line_spacer;
1112 my ( $hPos, $vPos, $font, $fontsize, $text ) = @_;
1113 my $str = "BT /$font $fontsize Tf $hPos $vPos Td ($text) Tj ET";
1117 sub DrawPatronCardText {
1119 my ( $x_pos, $y_pos, $label_height, $label_width, $fontname, $fontsize, $left_text_margin,
1120 $text_wrap_cols, $text, $printingtype )
1123 my $top_text_margin = 25; #FIXME: This should be a template parameter and passed in...
1125 my $vPos = ( $y_pos + ( $label_height - $top_text_margin ) );
1126 my $font = prFont($fontname);
1130 foreach my $line (keys %$text) {
1131 $debug and warn "Current text is \"$line\" and font size for \"$line\" is $text->{$line} points";
1132 # some code to try and center each line on the label based on font size and string point width...
1133 my $stringwidth = prStrWidth($line, $fontname, $text->{$line});
1134 my $whitespace = ( $label_width - ( $stringwidth + (2 * $left_text_margin) ) );
1135 $hPos = ( ( $whitespace / 2 ) + $x_pos + $left_text_margin );
1137 PrintText( $hPos, $vPos, $font, $text->{$line}, $line );
1138 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.).
1139 $vPos = $vPos - ($line_spacer + $text->{$line}); # Linefeed equiv: leading + font size
1143 # Not used anywhere.
1147 # my ($fontsize) = @_;
1149 # my $str = "BT/F13 30 Tf288 720 Td( AAAAAAAAAA ) TjET";
1155 # x and y are from the top-left :)
1156 my ( $x_pos, $y_pos, $height, $width, $barcode, $barcodetype ) = @_;
1157 my $num_of_bars = length($barcode);
1158 my $bar_width = $width * .8; # %80 of length of label width
1159 my $tot_bar_length = 0;
1161 my $guard_length = 10;
1162 my $xsize_ratio = 0;
1164 if ( $barcodetype eq 'CODE39' ) {
1165 $bar_length = '17.5';
1167 ( $bar_length * $num_of_bars ) + ( $guard_length * 2 );
1168 $xsize_ratio = ( $bar_width / $tot_bar_length );
1170 PDF::Reuse::Barcode::Code39(
1171 x => ( $x_pos + ( $width / 10 ) ),
1172 y => ( $y_pos + ( $height / 10 ) ),
1173 value => "*$barcode*",
1174 ySize => ( .02 * $height ),
1175 xSize => $xsize_ratio,
1180 warn "$barcodetype, $barcode FAILED:$@";
1184 elsif ( $barcodetype eq 'CODE39MOD' ) {
1186 # get modulo43 checksum
1187 my $c39 = CheckDigits('code_39');
1188 $barcode = $c39->complete($barcode);
1192 ( $bar_length * $num_of_bars ) + ( $guard_length * 2 );
1193 $xsize_ratio = ( $bar_width / $tot_bar_length );
1195 PDF::Reuse::Barcode::Code39(
1196 x => ( $x_pos + ( $width / 10 ) ),
1197 y => ( $y_pos + ( $height / 10 ) ),
1198 value => "*$barcode*",
1199 ySize => ( .02 * $height ),
1200 xSize => $xsize_ratio,
1206 warn "$barcodetype, $barcode FAILED:$@";
1209 elsif ( $barcodetype eq 'CODE39MOD10' ) {
1211 # get modulo43 checksum
1212 my $c39_10 = CheckDigits('visa');
1213 $barcode = $c39_10->complete($barcode);
1217 ( $bar_length * $num_of_bars ) + ( $guard_length * 2 );
1218 $xsize_ratio = ( $bar_width / $tot_bar_length );
1220 PDF::Reuse::Barcode::Code39(
1221 x => ( $x_pos + ( $width / 10 ) ),
1222 y => ( $y_pos + ( $height / 10 ) ),
1223 value => "*$barcode*",
1224 ySize => ( .02 * $height ),
1225 xSize => $xsize_ratio,
1232 warn "$barcodetype, $barcode FAILED:$@";
1237 elsif ( $barcodetype eq 'COOP2OF5' ) {
1238 $bar_length = '9.43333333333333';
1240 ( $bar_length * $num_of_bars ) + ( $guard_length * 2 );
1241 $xsize_ratio = ( $bar_width / $tot_bar_length ) * .9;
1243 PDF::Reuse::Barcode::COOP2of5(
1244 x => ( $x_pos + ( $width / 10 ) ),
1245 y => ( $y_pos + ( $height / 10 ) ),
1247 ySize => ( .02 * $height ),
1248 xSize => $xsize_ratio,
1252 warn "$barcodetype, $barcode FAILED:$@";
1256 elsif ( $barcodetype eq 'INDUSTRIAL2OF5' ) {
1257 $bar_length = '13.1333333333333';
1259 ( $bar_length * $num_of_bars ) + ( $guard_length * 2 );
1260 $xsize_ratio = ( $bar_width / $tot_bar_length ) * .9;
1262 PDF::Reuse::Barcode::Industrial2of5(
1263 x => ( $x_pos + ( $width / 10 ) ),
1264 y => ( $y_pos + ( $height / 10 ) ),
1266 ySize => ( .02 * $height ),
1267 xSize => $xsize_ratio,
1271 warn "$barcodetype, $barcode FAILED:$@";
1275 my $moo2 = $tot_bar_length * $xsize_ratio;
1277 warn "$x_pos, $y_pos, $barcode, $barcodetype" if $debug;
1278 warn "BAR_WDTH = $bar_width, TOT.BAR.LGHT=$tot_bar_length R*TOT.BAR =$moo2" if $debug;
1281 =item build_circ_barcode;
1283 build_circ_barcode( $x_pos, $y_pos, $barcode,
1284 $barcodetype, \$item);
1286 $item is the result of a previous call to GetLabelItems();
1291 sub build_circ_barcode {
1292 my ( $x_pos_circ, $y_pos, $value, $barcodetype, $item ) = @_;
1294 #warn Dumper \$item;
1296 #warn "value = $value\n";
1300 if ( $barcodetype eq 'EAN13' ) {
1302 #testing EAN13 barcodes hack
1303 $value = $value . '000000000';
1305 $value = substr( $value, 0, 12 );
1309 PDF::Reuse::Barcode::EAN13(
1310 x => ( $x_pos_circ + 27 ),
1311 y => ( $y_pos + 15 ),
1319 # added for xpdf compat. doesnt use type3 fonts., but increases filesize from 20k to 200k
1320 # i think its embedding extra fonts in the pdf file.
1321 # mode => 'graphic',
1325 $item->{'barcodeerror'} = 1;
1327 #warn "EAN13BARCODE FAILED:$@";
1333 elsif ( $barcodetype eq 'Code39' ) {
1336 PDF::Reuse::Barcode::Code39(
1337 x => ( $x_pos_circ + 9 ),
1338 y => ( $y_pos + 15 ),
1348 $item->{'barcodeerror'} = 1;
1350 #warn "CODE39BARCODE $value FAILED:$@";
1357 elsif ( $barcodetype eq 'Matrix2of5' ) {
1359 #warn "MATRIX ELSE:";
1361 #testing MATRIX25 barcodes hack
1362 # $value = $value.'000000000';
1365 # $value = substr( $value, 0, 12 );
1369 PDF::Reuse::Barcode::Matrix2of5(
1370 x => ( $x_pos_circ + 27 ),
1371 y => ( $y_pos + 15 ),
1381 $item->{'barcodeerror'} = 1;
1383 #warn "BARCODE FAILED:$@";
1390 elsif ( $barcodetype eq 'EAN8' ) {
1392 #testing ean8 barcodes hack
1393 $value = $value . '000000000';
1395 $value = substr( $value, 0, 8 );
1399 #warn "EAN8 ELSEIF";
1401 PDF::Reuse::Barcode::EAN8(
1402 x => ( $x_pos_circ + 42 ),
1403 y => ( $y_pos + 15 ),
1413 $item->{'barcodeerror'} = 1;
1415 #warn "BARCODE FAILED:$@";
1422 elsif ( $barcodetype eq 'UPC-E' ) {
1424 PDF::Reuse::Barcode::UPCE(
1425 x => ( $x_pos_circ + 27 ),
1426 y => ( $y_pos + 15 ),
1436 $item->{'barcodeerror'} = 1;
1438 #warn "BARCODE FAILED:$@";
1444 elsif ( $barcodetype eq 'NW7' ) {
1446 PDF::Reuse::Barcode::NW7(
1447 x => ( $x_pos_circ + 27 ),
1448 y => ( $y_pos + 15 ),
1458 $item->{'barcodeerror'} = 1;
1460 #warn "BARCODE FAILED:$@";
1466 elsif ( $barcodetype eq 'ITF' ) {
1468 PDF::Reuse::Barcode::ITF(
1469 x => ( $x_pos_circ + 27 ),
1470 y => ( $y_pos + 15 ),
1480 $item->{'barcodeerror'} = 1;
1482 #warn "BARCODE FAILED:$@";
1488 elsif ( $barcodetype eq 'Industrial2of5' ) {
1490 PDF::Reuse::Barcode::Industrial2of5(
1491 x => ( $x_pos_circ + 27 ),
1492 y => ( $y_pos + 15 ),
1501 $item->{'barcodeerror'} = 1;
1503 #warn "BARCODE FAILED:$@";
1509 elsif ( $barcodetype eq 'IATA2of5' ) {
1511 PDF::Reuse::Barcode::IATA2of5(
1512 x => ( $x_pos_circ + 27 ),
1513 y => ( $y_pos + 15 ),
1522 $item->{'barcodeerror'} = 1;
1524 #warn "BARCODE FAILED:$@";
1531 elsif ( $barcodetype eq 'COOP2of5' ) {
1533 PDF::Reuse::Barcode::COOP2of5(
1534 x => ( $x_pos_circ + 27 ),
1535 y => ( $y_pos + 15 ),
1544 $item->{'barcodeerror'} = 1;
1546 #warn "BARCODE FAILED:$@";
1552 elsif ( $barcodetype eq 'UPC-A' ) {
1555 PDF::Reuse::Barcode::UPCA(
1556 x => ( $x_pos_circ + 27 ),
1557 y => ( $y_pos + 15 ),
1566 $item->{'barcodeerror'} = 1;
1568 #warn "BARCODE FAILED:$@";
1577 =item draw_boundaries
1579 sub draw_boundaries ($x_pos_spine, $x_pos_circ1, $x_pos_circ2,
1580 $y_pos, $spine_width, $label_height, $circ_width)
1582 This sub draws boundary lines where the label outlines are, to aid in printer testing, and debugging.
1587 sub draw_boundaries {
1590 $x_pos_spine, $x_pos_circ1, $x_pos_circ2, $y_pos,
1591 $spine_width, $label_height, $circ_width
1594 my $y_pos_initial = ( ( 792 - 36 ) - 90 );
1595 $y_pos = $y_pos_initial; # FIXME - why are we ignoring the y_pos parameter by redefining it?
1598 for ( $i = 1 ; $i <= 8 ; $i++ ) {
1600 &drawbox( $x_pos_spine, $y_pos, ($spine_width), ($label_height) );
1602 #warn "OLD BOXES x=$x_pos_spine, y=$y_pos, w=$spine_width, h=$label_height";
1603 &drawbox( $x_pos_circ1, $y_pos, ($circ_width), ($label_height) );
1604 &drawbox( $x_pos_circ2, $y_pos, ($circ_width), ($label_height) );
1606 $y_pos = ( $y_pos - $label_height );
1613 sub drawbox { $lower_left_x, $lower_left_y,
1614 $upper_right_x, $upper_right_y )
1616 this is a low level sub, that draws a pdf box, it is called by draw_boxes
1618 FYI: the $upper_right_x and $upper_right_y values are RELATIVE to $lower_left_x and $lower_left_y
1620 and $lower_left_x, $lower_left_y are ABSOLUTE, this caught me out!
1626 my ( $llx, $lly, $urx, $ury ) = @_;
1628 # warn "llx,y= $llx,$lly , urx,y=$urx,$ury \n";
1630 my $str = "q\n"; # save the graphic state
1631 $str .= "0.5 w\n"; # border color red
1632 $str .= "1.0 0.0 0.0 RG\n"; # border color red
1633 # $str .= "0.5 0.75 1.0 rg\n"; # fill color blue
1634 $str .= "1.0 1.0 1.0 rg\n"; # fill color white
1636 $str .= "$llx $lly $urx $ury re\n"; # a rectangle
1637 $str .= "B\n"; # fill (and a little more)
1638 $str .= "Q\n"; # save the graphic state
1644 END { } # module clean-up code here (global destructor)
1653 Mason James <mason@katipo.co.nz>