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 warnings; # FIXME
22 use vars qw($VERSION @ISA @EXPORT);
26 use Algorithm::CheckDigits;
39 &get_label_options &GetLabelItems
40 &build_circ_barcode &draw_boundaries
41 &drawbox &GetActiveLabelTemplate
42 &GetAllLabelTemplates &DeleteTemplate
43 &GetSingleLabelTemplate &SaveTemplate
44 &CreateTemplate &SetActiveTemplate
45 &SaveConf &GetTextWrapCols
50 &get_printingtypes &GetPatronCardItems
53 &get_batches &delete_batch
57 get_layout &save_layout &add_layout
60 &delete_layout &get_active_layout
63 &GetAllPrinterProfiles &GetSinglePrinterProfile
64 &SaveProfile &CreateProfile &DeleteProfile
65 &GetAssociatedProfile &SetAssociatedProfile
72 C4::Labels - Functions for printing spine labels and barcodes in Koha
76 =head2 get_label_options;
78 $options = get_label_options()
80 Return a pointer on a hash list containing info from labels_conf table in Koha DB.
84 sub get_label_options {
85 my $query2 = " SELECT * FROM labels_conf where active = 1"; # FIXME: exact same as get_active_layout
86 my $sth = C4::Context->dbh->prepare($query2);
88 return $sth->fetchrow_hashref;
92 my $dbh = C4::Context->dbh;
93 my $query = " Select * from labels_conf";
94 my $sth = $dbh->prepare($query);
97 while ( my $data = $sth->fetchrow_hashref ) {
98 $data->{'fieldlist'} = get_text_fields( $data->{'id'} );
99 push( @resultsloop, $data );
105 my ($layout_id) = @_;
106 my $dbh = C4::Context->dbh;
107 # get the actual items to be printed.
108 my $query = " Select * from labels_conf where id = ?";
109 my $sth = $dbh->prepare($query);
110 $sth->execute($layout_id);
111 my $data = $sth->fetchrow_hashref;
115 sub get_active_layout {
116 my $query = " Select * from labels_conf where active = 1"; # FIXME: exact same as get_label_options
117 my $sth = C4::Context->dbh->prepare($query);
119 return $sth->fetchrow_hashref;
123 my ($layout_id) = @_;
124 my $dbh = C4::Context->dbh;
125 # get the actual items to be printed.
126 my $query = "delete from labels_conf where id = ?";
127 my $sth = $dbh->prepare($query);
128 $sth->execute($layout_id);
131 sub get_printingtypes {
132 my ($layout_id) = @_;
134 # FIXME hard coded print types
135 push( @printtypes, { code => 'BAR', desc => "barcode only" } );
136 push( @printtypes, { code => 'BIB', desc => "biblio only" } );
137 push( @printtypes, { code => 'BARBIB', desc => "barcode / biblio" } );
138 push( @printtypes, { code => 'BIBBAR', desc => "biblio / barcode" } );
139 push( @printtypes, { code => 'ALT', desc => "alternating labels" } );
140 push( @printtypes, { code => 'CSV', desc => "csv output" } );
141 push( @printtypes, { code => 'PATCRD', desc => "patron cards" } );
143 my $conf = get_layout($layout_id);
144 my $active_printtype = $conf->{'printingtype'};
146 # lop thru layout, insert selected to hash
148 foreach my $printtype (@printtypes) {
149 if ( $printtype->{'code'} eq $active_printtype ) {
150 $printtype->{'active'} = 1;
156 # this sub (build_text_dropbox) is deprecated and should be deleted.
159 sub build_text_dropbox {
161 my $field_count = 7; # <----------- FIXME hard coded
164 ? push( @lines, { num => '', selected => '1' } )
165 : push( @lines, { num => '' } );
166 for ( my $i = 1 ; $i <= $field_count ; $i++ ) {
167 my $line = { num => "$i" };
168 $line->{'selected'} = 1 if $i eq $order;
169 push( @lines, $line );
174 sub get_text_fields {
175 my ( $layout_id, $sorttype ) = @_;
178 my $sortorder = get_layout($layout_id);
179 if ( $sortorder->{formatstring} ) {
181 return $sortorder->{formatstring};
184 my $csv = Text::CSV_XS->new( { allow_whitespace => 1 } );
185 my $line = $sortorder->{formatstring};
186 my $status = $csv->parse($line);
188 map { { 'code' => $_, desc => $_ } } $csv->fields();
189 $error = $csv->error_input();
190 warn $error if $error; # TODO - do more with this.
195 # These fields are hardcoded based on the template for label-edit-layout.pl
200 order => $sortorder->{'itemtype'}
205 order => $sortorder->{'issn'}
210 order => $sortorder->{'isbn'}
215 order => $sortorder->{'barcode'}
220 order => $sortorder->{'author'}
225 order => $sortorder->{'title'}
228 code => 'itemcallnumber',
229 desc => "Call Number",
230 order => $sortorder->{'itemcallnumber'}
235 foreach my $field (@text_fields) {
236 push( @new_fields, $field ) if $field->{'order'} > 0;
239 @sorted_fields = sort { $$a{order} <=> $$b{order} } @new_fields;
242 # if we have a 'formatstring', then we ignore these hardcoded fields.
245 if ( $sorttype eq 'codes' )
246 { # FIXME: This sub should really always return the array of hashrefs and let the caller take what he wants from that -fbcit
247 return @sorted_fields;
250 foreach my $field (@sorted_fields) {
251 $active_fields .= "$field->{'desc'} ";
253 return $active_fields;
261 add_batch($batch_type,\@batch_list);
262 if $batch_list is supplied,
263 create a new batch with those items.
264 else, return the next available batch_id.
270 sub add_batch ($;$) {
271 my $table = (@_ and 'patroncards' eq shift) ? 'patroncards' : 'labels';
272 my $batch_list = (@_) ? shift : undef;
273 my $dbh = C4::Context->dbh;
274 # FIXME : batch_id should be an auto_incr INT. Temporarily casting as int ( see koha bug 2555 )
275 # until a label_batches table is added, and we can convert batch_id to int.
276 my $q ="SELECT MAX( CAST(batch_id AS SIGNED) ) 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 (id:$batch_id) of type $batch_type";
319 my $q = "DELETE FROM $batch_type WHERE batch_id = ?";
320 my $sth = C4::Context->dbh->prepare($q);
321 $sth->execute($batch_id);
324 sub get_barcode_types {
325 my ($layout_id) = @_;
326 my $layout = get_layout($layout_id);
327 my $barcode = $layout->{'barcodetype'};
330 push( @array, { code => 'CODE39', desc => 'Code 39' } );
331 push( @array, { code => 'CODE39MOD', desc => 'Code39 + Modulo43' } );
332 push( @array, { code => 'CODE39MOD10', desc => 'Code39 + Modulo10' } );
333 push( @array, { code => 'ITF', desc => 'Interleaved 2 of 5' } );
335 foreach my $line (@array) {
336 if ( $line->{'code'} eq $barcode ) {
337 $line->{'active'} = 1;
346 $unitvalue = '1' if ( $units eq 'POINT' );
347 $unitvalue = '2.83464567' if ( $units eq 'MM' );
348 $unitvalue = '28.3464567' if ( $units eq 'CM' );
349 $unitvalue = 72 if ( $units eq 'INCH' );
353 sub GetTextWrapCols {
354 my ( $font, $fontsize, $label_width, $left_text_margin ) = @_;
358 # my $textlimit = $label_width - ($left_text_margin);
359 my $textlimit = $label_width - ( 3 * $left_text_margin);
361 while ( $strwidth < $textlimit ) {
362 $strwidth = prStrWidth( $string, $font, $fontsize );
363 $string = $string . '0';
364 #warn "strwidth:$strwidth, textlimit:$textlimit, count:$count string:$string";
370 sub GetActiveLabelTemplate {
371 my $dbh = C4::Context->dbh;
372 my $query = " SELECT * FROM labels_templates where active = 1 limit 1";
373 my $sth = $dbh->prepare($query);
375 my $active_tmpl = $sth->fetchrow_hashref;
379 sub GetSingleLabelTemplate {
381 my $dbh = C4::Context->dbh;
382 my $query = " SELECT * FROM labels_templates where tmpl_id = ?";
383 my $sth = $dbh->prepare($query);
384 $sth->execute($tmpl_id);
385 my $template = $sth->fetchrow_hashref;
389 sub SetActiveTemplate {
391 my $dbh = C4::Context->dbh;
392 my $query = " UPDATE labels_templates SET active = NULL";
393 my $sth = $dbh->prepare($query);
396 $query = "UPDATE labels_templates SET active = 1 WHERE tmpl_id = ?";
397 $sth = $dbh->prepare($query);
398 $sth->execute($tmpl_id);
401 sub set_active_layout {
402 my ($layout_id) = @_;
403 my $dbh = C4::Context->dbh;
404 my $query = " UPDATE labels_conf SET active = NULL";
405 my $sth = $dbh->prepare($query);
408 $query = "UPDATE labels_conf SET active = 1 WHERE id = ?";
409 $sth = $dbh->prepare($query);
410 $sth->execute($layout_id);
415 my $dbh = C4::Context->dbh;
416 my $query = " DELETE FROM labels_templates where tmpl_id = ?";
417 my $sth = $dbh->prepare($query);
418 $sth->execute($tmpl_id);
423 $tmpl_id, $tmpl_code, $tmpl_desc, $page_width,
424 $page_height, $label_width, $label_height, $topmargin,
425 $leftmargin, $cols, $rows, $colgap,
426 $rowgap, $font, $fontsize, $units
428 $debug and warn "Passed \$font:$font";
429 my $dbh = C4::Context->dbh;
431 " UPDATE labels_templates SET tmpl_code=?, tmpl_desc=?, page_width=?,
432 page_height=?, label_width=?, label_height=?, topmargin=?,
433 leftmargin=?, cols=?, rows=?, colgap=?, rowgap=?, font=?, fontsize=?,
437 my $sth = $dbh->prepare($query);
439 $tmpl_code, $tmpl_desc, $page_width, $page_height,
440 $label_width, $label_height, $topmargin, $leftmargin,
441 $cols, $rows, $colgap, $rowgap,
442 $font, $fontsize, $units, $tmpl_id
444 my $dberror = $sth->errstr;
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
457 my $dbh = C4::Context->dbh;
459 my $query = "INSERT INTO labels_templates (tmpl_code, tmpl_desc, page_width,
460 page_height, label_width, label_height, topmargin,
461 leftmargin, cols, rows, colgap, rowgap, font, fontsize, units)
462 VALUES(?,?,?,?,?,?,?,?,?,?,?,?,?,?,?)";
464 my $sth = $dbh->prepare($query);
466 $tmpl_code, $tmpl_desc, $page_width, $page_height,
467 $label_width, $label_height, $topmargin, $leftmargin,
468 $cols, $rows, $colgap, $rowgap,
469 $font, $fontsize, $units
471 my $dberror = $sth->errstr;
475 sub GetAllLabelTemplates {
476 my $dbh = C4::Context->dbh;
477 # get the actual items to be printed.
479 my $query = " Select * from labels_templates ";
480 my $sth = $dbh->prepare($query);
483 while ( my $data = $sth->fetchrow_hashref ) {
484 push( @resultsloop, $data );
486 #warn Dumper @resultsloop;
494 $barcodetype, $title, $subtitle, $isbn, $issn,
495 $itemtype, $bcn, $text_justify, $callnum_split,
496 $itemcallnumber, $author, $tmpl_id,
497 $printingtype, $guidebox, $startlabel, $layoutname, $formatstring
500 my $dbh = C4::Context->dbh;
501 my $query2 = "update labels_conf set active = NULL";
502 my $sth2 = $dbh->prepare($query2);
504 $query2 = "INSERT INTO labels_conf
505 ( barcodetype, title, subtitle, isbn,issn, itemtype, barcode,
506 text_justify, callnum_split, itemcallnumber, author, printingtype,
507 guidebox, startlabel, layoutname, formatstring, active )
508 values ( ?, ?,?, ?, ?, ?, ?, ?, ?, ?, ?, ?, ?, ?,?,?, 1 )";
509 $sth2 = $dbh->prepare($query2);
511 $barcodetype, $title, $subtitle, $isbn, $issn,
512 $itemtype, $bcn, $text_justify, $callnum_split,
513 $itemcallnumber, $author, $printingtype,
514 $guidebox, $startlabel, $layoutname, $formatstring
516 SetActiveTemplate($tmpl_id);
522 $barcodetype, $title, $subtitle, $isbn, $issn,
523 $itemtype, $bcn, $text_justify, $callnum_split,
524 $itemcallnumber, $author, $tmpl_id,
525 $printingtype, $guidebox, $startlabel, $layoutname, $formatstring,
531 my $dbh = C4::Context->dbh;
532 my $query2 = "update labels_conf set
533 barcodetype=?, title=?, subtitle=?, isbn=?,issn=?,
534 itemtype=?, barcode=?, text_justify=?, callnum_split=?,
535 itemcallnumber=?, author=?, printingtype=?,
536 guidebox=?, startlabel=?, layoutname=?, formatstring=? where id = ?";
537 my $sth2 = $dbh->prepare($query2);
539 $barcodetype, $title, $subtitle, $isbn, $issn,
540 $itemtype, $bcn, $text_justify, $callnum_split,
541 $itemcallnumber, $author, $printingtype,
542 $guidebox, $startlabel, $layoutname, $formatstring, $layout_id
546 =head2 GetAllPrinterProfiles;
548 @profiles = GetAllPrinterProfiles()
550 Returns an array of references-to-hash, whos keys are .....
554 sub GetAllPrinterProfiles {
555 my $dbh = C4::Context->dbh;
557 my $query = "SELECT * FROM printers_profile AS pp INNER JOIN labels_templates AS lt ON pp.tmpl_id = lt.tmpl_id";
558 my $sth = $dbh->prepare($query);
561 while ( my $data = $sth->fetchrow_hashref ) {
562 push( @resultsloop, $data );
567 =head2 GetSinglePrinterProfile;
569 $profile = GetSinglePrinterProfile()
571 Returns a hashref whos keys are...
575 sub GetSinglePrinterProfile {
577 my $query = "SELECT * FROM printers_profile WHERE prof_id = ?";
578 my $sth = C4::Context->dbh->prepare($query);
579 $sth->execute($prof_id);
580 my $template = $sth->fetchrow_hashref;
586 SaveProfile('parameters')
588 When passed a set of parameters, this function updates the given profile with the new parameters.
594 $prof_id, $offset_horz, $offset_vert, $creep_horz, $creep_vert, $units
596 my $dbh = C4::Context->dbh;
598 " UPDATE printers_profile
599 SET offset_horz=?, offset_vert=?, creep_horz=?, creep_vert=?, unit=?
601 my $sth = $dbh->prepare($query);
603 $offset_horz, $offset_vert, $creep_horz, $creep_vert, $units, $prof_id
607 =head2 CreateProfile;
609 CreateProfile('parameters')
611 When passed a set of parameters, this function creates a new profile containing those parameters
612 and returns any errors.
618 $prof_id, $printername, $paper_bin, $tmpl_id, $offset_horz,
619 $offset_vert, $creep_horz, $creep_vert, $units
621 my $dbh = C4::Context->dbh;
623 " INSERT INTO printers_profile (prof_id, printername, paper_bin, tmpl_id,
624 offset_horz, offset_vert, creep_horz, creep_vert, unit)
625 VALUES(?,?,?,?,?,?,?,?,?) ";
626 my $sth = $dbh->prepare($query);
628 $prof_id, $printername, $paper_bin, $tmpl_id, $offset_horz,
629 $offset_vert, $creep_horz, $creep_vert, $units
631 my $error = $sth->errstr;
635 =head2 DeleteProfile;
637 DeleteProfile(prof_id)
639 When passed a profile id, this function deletes that profile from the database and returns any errors.
645 my $dbh = C4::Context->dbh;
646 my $query = " DELETE FROM printers_profile WHERE prof_id = ?";
647 my $sth = $dbh->prepare($query);
648 $sth->execute($prof_id);
649 my $error = $sth->errstr;
653 =head2 GetAssociatedProfile;
655 $assoc_prof = GetAssociatedProfile(tmpl_id)
657 When passed a template id, this function returns the parameters from the currently associated printer profile
658 in a hashref where key=fieldname and value=fieldvalue.
662 sub GetAssociatedProfile {
664 my $dbh = C4::Context->dbh;
665 # First we find out the prof_id for the associated profile...
666 my $query = "SELECT * FROM labels_profile WHERE tmpl_id = ?";
667 my $sth = $dbh->prepare($query);
668 $sth->execute($tmpl_id);
669 my $assoc_prof = $sth->fetchrow_hashref or return;
670 # Then we retrieve that profile and return it to the caller...
671 $assoc_prof = GetSinglePrinterProfile($assoc_prof->{'prof_id'});
675 =head2 SetAssociatedProfile;
677 SetAssociatedProfile($prof_id, $tmpl_id)
679 When passed both a profile id and template id, this function establishes an association between the two. No more
680 than one profile may be associated with any given template at the same time.
684 sub SetAssociatedProfile {
685 my ($prof_id, $tmpl_id) = @_;
686 my $dbh = C4::Context->dbh;
687 my $query = "INSERT INTO labels_profile (prof_id, tmpl_id) VALUES (?,?) ON DUPLICATE KEY UPDATE prof_id = ?";
688 my $sth = $dbh->prepare($query);
689 $sth->execute($prof_id, $tmpl_id, $prof_id);
693 =head2 GetLabelItems;
695 $options = GetLabelItems()
697 Returns an array of references-to-hash, whos keys are the fields from the biblio, biblioitems, items and labels tables in the Koha database.
703 my $dbh = C4::Context->dbh;
705 my @resultsloop = ();
716 $sth = $dbh->prepare($query3);
717 $sth->execute($batch_id);
723 $sth = $dbh->prepare($query3);
726 my $cnt = $sth->rows;
728 while ( my $data = $sth->fetchrow_hashref ) {
730 # lets get some summary info from each item
732 # FIXME This makes for a very bulky data structure; data from tables w/duplicate col names also gets overwritten.
733 # Something like this, perhaps, but this also causes problems because we need more fields sometimes.
734 # SELECT i.barcode, i.itemcallnumber, i.itype, bi.isbn, bi.issn, b.title, b.author
735 "SELECT bi.*, i.*, b.*
736 FROM items AS i, biblioitems AS bi ,biblio AS b
737 WHERE itemnumber=? AND i.biblioitemnumber=bi.biblioitemnumber AND bi.biblionumber=b.biblionumber";
738 my $sth1 = $dbh->prepare($query1);
739 $sth1->execute( $data->{'itemnumber'} );
741 my $data1 = $sth1->fetchrow_hashref();
742 $data1->{'labelno'} = $i1;
743 $data1->{'labelid'} = $data->{'labelid'};
744 $data1->{'batch_id'} = $batch_id;
745 $data1->{'summary'} = "$data1->{'barcode'}, $data1->{'title'}, $data1->{'isbn'}";
747 push( @resultsloop, $data1 );
767 =head2 GetBarcodeData
771 Parse labels_conf.formatstring value
772 (one value of the csv, which has already been split)
773 and return string from koha tables or MARC record.
780 my ( $f, $item, $record ) = @_;
781 my $kohatables = &_descKohaTables();
783 my $match_kohatable = join(
786 @{ $kohatables->{biblio} },
787 @{ $kohatables->{biblioitems} },
788 @{ $kohatables->{items} }
793 if ( $f =~ /^'(.*)'.*/ ) {
794 # single quotes indicate a static text string.
798 elsif ( $f =~ /^($match_kohatable).*/ ) {
799 $datastring .= $item->{$f};
802 elsif ( $f =~ /^([0-9a-z]{3})(\w)(\W?).*?/ ) {
803 my ($field,$subf,$ws) = ($1,$2,$3);
805 my ($itemtag, $itemsubfieldcode) = &GetMarcFromKohaField("items.itemnumber",'');
806 my @marcfield = $record->field($field);
808 if($field eq $itemtag) { # item-level data, we need to get the right item.
809 foreach my $itemfield (@marcfield) {
810 if ( $itemfield->subfield($itemsubfieldcode) eq $item->{'itemnumber'} ) {
811 $datastring .= $itemfield->subfield($subf ) . $ws;
815 } else { # bib-level data, we'll take the first matching tag/subfield.
816 $datastring .= $marcfield[0]->subfield($subf) . $ws ;
822 warn "failed to parse label formatstring: $f";
823 last; # Failed to match
829 =head2 descKohaTables
831 Return a hashref of an array of hashes,
836 sub _descKohaTables {
837 my $dbh = C4::Context->dbh();
839 for my $table ( 'biblio','biblioitems','items' ) {
840 my $sth = $dbh->column_info(undef,undef,$table,'%');
841 while (my $info = $sth->fetchrow_hashref()){
842 push @{$kohatables->{$table}} , $info->{'COLUMN_NAME'} ;
848 sub GetPatronCardItems {
849 my ( $batch_id ) = @_;
852 my $dbh = C4::Context->dbh;
853 # my $query = "SELECT * FROM patroncards WHERE batch_id = ? ORDER BY borrowernumber";
854 my $query = "SELECT * FROM patroncards WHERE batch_id = ? ORDER BY cardid";
855 my $sth = $dbh->prepare($query);
856 $sth->execute($batch_id);
858 while ( my $data = $sth->fetchrow_hashref ) {
859 my $patron_data = GetMember( $data->{'borrowernumber'} );
860 $patron_data->{'branchname'} = GetBranchName( $patron_data->{'branchcode'} );
861 $patron_data->{'cardno'} = $cardno;
862 $patron_data->{'cardid'} = $data->{'cardid'};
863 $patron_data->{'batch_id'} = $batch_id;
864 push( @resultsloop, $patron_data );
870 sub deduplicate_batch {
871 my ( $batch_id, $batch_type ) = @_;
874 batch_id," . (($batch_type eq 'labels') ? 'itemnumber' : 'borrowernumber') . ",
875 count(". (($batch_type eq 'labels') ? 'labelid' : 'cardid') . ") as count
878 GROUP BY " . (($batch_type eq 'labels') ? 'itemnumber' : 'borrowernumber') . ",batch_id
882 my $sth = C4::Context->dbh->prepare($query);
883 $sth->execute($batch_id);
884 warn $sth->errstr if $sth->errstr;
885 $sth->rows or return undef, $sth->errstr;
891 AND " . (($batch_type eq 'labels') ? 'itemnumber' : 'borrowernumber') . " = ?
892 ORDER BY timestamp ASC
895 while (my $data = $sth->fetchrow_hashref()) {
896 my $itemnumber = $data->{(($batch_type eq 'labels') ? 'itemnumber' : 'borrowernumber')} or next;
897 my $limit = $data->{count} - 1 or next;
898 my $sth2 = C4::Context->dbh->prepare("$del_query LIMIT $limit");
899 # die sprintf "$del_query LIMIT %s\n (%s, %s)", $limit, $batch_id, $itemnumber;
900 # $sth2->execute($batch_id, C4::Context->dbh->quote($data->{itemnumber}), $data->{count} - 1)
901 $sth2->execute($batch_id, $itemnumber) and
902 $killed += ($data->{count} - 1);
903 warn $sth2->errstr if $sth2->errstr;
905 return $killed, undef;
911 # lccn examples: 'HE8700.7 .P6T44 1983', 'BS2545.E8 H39 1996';
913 ^([a-zA-Z]+) # HE # BS
914 (\d+(?:\.\d)*) # 8700.7 # 2545
916 (\.*\D+\d*) # .P6 # .E8
918 (.*) # T44 1983 # H39 1996 # everything else (except any bracketing spaces)
921 unless (scalar @parts) {
922 $debug and print STDERR "split_lccn regexp failed to match string: $_\n";
923 push @parts, $_; # if no match, just push the whole string.
925 push @parts, split /\s+/, pop @parts; # split the last piece into an arbitrary number of pieces at spaces
926 $debug and print STDERR "split_lccn array: ", join(" | ", @parts), "\n";
930 our $possible_decimal = qr/\d{3,}(?:\.\d+)?/; # at least three digits for a DDCN
935 s/\///g; # in theory we should be able to simply remove all segmentation markers and arrive at the correct call number...
936 # ddcn examples: 'R220.3 H2793Z H32 c.2', 'BIO JP2 R5c.1'
939 ^([a-zA-Z-]+(?:$possible_decimal)?) # R220.3 # BIO # first example will require extra splitting
941 (.+) # H2793Z H32 c.2 # R5c.1 # everything else (except bracketing spaces)
944 unless (scalar @parts) {
945 $debug and print STDERR "split_ddcn regexp failed to match string: $_\n";
946 push @parts, $_; # if no match, just push the whole string.
949 if ($parts[ 0] =~ /^([a-zA-Z]+)($possible_decimal)$/) {
950 shift @parts; # pull off the mathching first element, like example 1
951 unshift @parts, $1, $2; # replace it with the two pieces
954 push @parts, split /\s+/, pop @parts; # split the last piece into an arbitrary number of pieces at spaces
956 if ($parts[-1] !~ /^.*\d-\d.*$/ && $parts[-1] =~ /^(.*\d+)(\D.*)$/) {
957 pop @parts; # pull off the mathching last element, like example 2
958 push @parts, $1, $2; # replace it with the two pieces
961 $debug and print STDERR "split_ddcn array: ", join(" | ", @parts), "\n";
968 # Split fiction call numbers based on spaces
971 if ($fcn =~ m/([A-Za-z0-9]+\.?[0-9]?)(\W?).*?/x) {
972 push (@fcn_split, $1);
976 last SPLIT_FCN; # No match, break out of the loop
983 # Class variable to avoid querying itemtypes for every DrawSpineText call!!
984 sub get_itemtype_descriptions () {
985 unless (scalar keys %itemtypemap) {
986 my $sth = C4::Context->dbh->prepare("SELECT itemtype,description FROM itemtypes");
988 while (my $data = $sth->fetchrow_hashref) {
989 $itemtypemap{$data->{itemtype}} = $data->{description};
992 return \%itemtypemap;
996 my ( $x_pos, $y_pos, $label_height, $label_width, $fontname, $fontsize, $left_text_margin,
997 $text_wrap_cols, $item, $conf_data, $printingtype ) = @_;
999 # Replace item's itemtype with the more user-friendly description...
1000 my $descriptions = get_itemtype_descriptions();
1001 foreach (qw(itemtype itype)) {
1002 my $description = $descriptions->{$$item->{$_}} or next;
1003 $$item->{$_} = $description;
1007 my $top_text_margin = ( $fontsize + 3 ); #FIXME: This should be a template parameter and passed in...
1008 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.).
1010 my $layout_id = $$conf_data->{'id'};
1012 my $vPos = ( $y_pos + ( $label_height - $top_text_margin ) );
1014 my @str_fields = get_text_fields($layout_id, 'codes' );
1015 my $record = GetMarcBiblio($$item->{biblionumber});
1016 # FIXME - returns all items, so you can't get data from an embedded holdings field.
1017 # TODO - add a GetMarcBiblio1item(bibnum,itemnum) or a GetMarcItem(itemnum).
1019 my $old_fontname = $fontname; # We need to keep track of the original font passed in...
1021 # Grab the cn_source and if that is NULL, the DefaultClassificationSource syspref
1022 my $cn_source = ($$item->{'cn_source'} ? $$item->{'cn_source'} : C4::Context->preference('DefaultClassificationSource'));
1023 for my $field (@str_fields) {
1024 $field->{'code'} or warn "get_text_fields($layout_id, 'codes') element missing 'code' field";
1025 if ($field->{'code'} eq 'itemtype') {
1026 $field->{'data'} = C4::Context->preference('item-level_itypes') ? $$item->{'itype'} : $$item->{'itemtype'};
1028 elsif ($$conf_data->{'formatstring'}) {
1029 # if labels_conf.formatstring has a value, then it overrides the hardcoded option.
1030 $field->{'data'} = GetBarcodeData($field->{'code'},$$item,$record) ;
1033 $field->{'data'} = $$item->{$field->{'code'}};
1035 # This allows us to print the title in italic (oblique) type... (Times Roman has a different nomenclature.)
1036 # It seems there should be a better way to handle fonts in the label/patron card tool altogether -fbcit
1037 ($field->{code} eq 'title') ? (($old_fontname =~ /T/) ? ($fontname = 'TI') : ($fontname = ($old_fontname . 'O'))) : ($fontname = $old_fontname);
1038 my $font = prFont($fontname);
1039 # if the display option for this field is selected in the DB,
1040 # and the item record has some values for this field, display it.
1041 # Or if there is a csv list of fields to display, display them.
1042 if ( ($$conf_data->{'formatstring'}) || ( $$conf_data->{$field->{code}} && $$item->{$field->{code}} ) ) {
1044 my $str = $field->{data} ;
1045 # strip out naughty existing nl/cr's
1049 my @callnumber_list = ('itemcallnumber', '050a', '050b', '082a', '952o'); # Fields which hold call number data ( 060? 090? 092? 099? )
1050 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
1051 if ($cn_source eq 'lcc') {
1052 @strings = split_lccn($str);
1053 @strings = split_fcn($str) if !@strings; # If it was not a true lccn, try it as a fiction call number
1054 push (@strings, $str) if !@strings; # If it was not that, send it on unsplit
1055 } elsif ($cn_source eq 'ddc') {
1056 @strings = split_ddcn($str);
1057 @strings = split_fcn($str) if !@strings;
1058 push (@strings, $str) if !@strings;
1060 # FIXME Need error trapping here; something to be informative to the user perhaps -crn
1061 push @strings, $str;
1064 $str =~ s/\/$//g; # Here we will strip out all trailing '/' in fields other than the call number...
1065 $str =~ s/\(/\\\(/g; # Escape '(' and ')' for the postscript stream...
1066 $str =~ s/\)/\\\)/g;
1067 # Wrap text lines exceeding $text_wrap_cols length...
1068 $Text::Wrap::columns = $text_wrap_cols;
1069 my @line = split(/\n/ ,wrap('', '', $str));
1070 # If this is a title field, limit to two lines; all others limit to one...
1071 my $limit = ($field->{code} eq 'title') ? 2 : 1;
1072 while (scalar(@line) > $limit) {
1075 push(@strings, @line);
1077 # loop for each string line
1078 foreach my $str (@strings) {
1081 my $stringwidth = prStrWidth($str, $fontname, $fontsize);
1082 if ( $$conf_data->{'text_justify'} eq 'R' ) {
1083 $hPos += $label_width - ($left_text_margin + $stringwidth);
1084 } elsif($$conf_data->{'text_justify'} eq 'C') {
1085 # some code to try and center each line on the label based on font size and string point width...
1086 my $whitespace = ( $label_width - ( $stringwidth + (2 * $left_text_margin) ) );
1087 $hPos += ($whitespace / 2) + $left_text_margin;
1088 #warn "\$label_width=$label_width \$stringwidth=$stringwidth \$whitespace=$whitespace \$left_text_margin=$left_text_margin for $str\n";
1090 $hPos += $left_text_margin;
1092 # utf8::encode($str);
1093 # Say $str has a diacritical like: The séance
1094 # WITOUT encode, PrintText crashes with: Wide character in syswrite at /usr/local/share/perl/5.8.8/PDF/Reuse.pm line 968
1095 # WITH encode, PrintText prints: The se̕ancee
1096 # Neither is appropriate.
1097 PrintText( $hPos, $vPos, $font, $fontsize, $str );
1098 $vPos -= $line_spacer;
1105 my ( $hPos, $vPos, $font, $fontsize, $text ) = @_;
1106 my $str = "BT /$font $fontsize Tf $hPos $vPos Td ($text) Tj ET";
1110 sub DrawPatronCardText {
1111 my ( $x_pos, $y_pos, $label_height, $label_width, $fontname, $fontsize, $left_text_margin,
1112 $text_wrap_cols, $text, $printingtype )
1115 my $top_text_margin = 25; #FIXME: This should be a template parameter and passed in...
1117 my $vPos = ( $y_pos + ( $label_height - $top_text_margin ) );
1118 my $font = prFont($fontname);
1122 foreach my $line (keys %$text) {
1123 $debug and warn "Current text is \"$line\" and font size for \"$line\" is $text->{$line} points";
1124 # some code to try and center each line on the label based on font size and string point width...
1125 my $stringwidth = prStrWidth($line, $fontname, $text->{$line});
1126 my $whitespace = ( $label_width - ( $stringwidth + (2 * $left_text_margin) ) );
1127 $hPos = ( ( $whitespace / 2 ) + $x_pos + $left_text_margin );
1129 PrintText( $hPos, $vPos, $font, $text->{$line}, $line );
1130 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.).
1131 $vPos = $vPos - ($line_spacer + $text->{$line}); # Linefeed equiv: leading + font size
1135 # Not used anywhere.
1139 # my ($fontsize) = @_;
1141 # my $str = "BT/F13 30 Tf288 720 Td( AAAAAAAAAA ) TjET";
1146 # x and y are from the top-left :)
1147 my ( $x_pos, $y_pos, $height, $width, $barcode, $barcodetype ) = @_;
1148 my $num_of_bars = length($barcode);
1149 my $bar_width = $width * .8; # %80 of length of label width
1150 my $tot_bar_length = 0;
1152 my $guard_length = 10;
1153 my $xsize_ratio = 0;
1155 if ( $barcodetype eq 'CODE39' ) {
1156 $bar_length = '17.5';
1158 ( $bar_length * $num_of_bars ) + ( $guard_length * 2 );
1159 $xsize_ratio = ( $bar_width / $tot_bar_length );
1161 PDF::Reuse::Barcode::Code39(
1162 x => ( $x_pos + ( $width / 10 ) ),
1163 y => ( $y_pos + ( $height / 10 ) ),
1164 value => "*$barcode*",
1165 ySize => ( .02 * $height ),
1166 xSize => $xsize_ratio,
1168 mode => 'graphic', # the only other option here is Type3...
1172 elsif ( $barcodetype eq 'CODE39MOD' ) {
1173 # get modulo43 checksum
1174 my $c39 = CheckDigits('code_39');
1175 $barcode = $c39->complete($barcode);
1179 ( $bar_length * $num_of_bars ) + ( $guard_length * 2 );
1180 $xsize_ratio = ( $bar_width / $tot_bar_length );
1182 PDF::Reuse::Barcode::Code39(
1183 x => ( $x_pos + ( $width / 10 ) ),
1184 y => ( $y_pos + ( $height / 10 ) ),
1185 value => "*$barcode*",
1186 ySize => ( .02 * $height ),
1187 xSize => $xsize_ratio,
1189 mode => 'graphic', # the only other option here is Type3...
1193 elsif ( $barcodetype eq 'CODE39MOD10' ) {
1194 # get modulo43 checksum
1195 my $c39_10 = CheckDigits('visa');
1196 $barcode = $c39_10->complete($barcode);
1200 ( $bar_length * $num_of_bars ) + ( $guard_length * 2 );
1201 $xsize_ratio = ( $bar_width / $tot_bar_length );
1203 PDF::Reuse::Barcode::Code39(
1204 x => ( $x_pos + ( $width / 10 ) ),
1205 y => ( $y_pos + ( $height / 10 ) ),
1206 value => "*$barcode*",
1207 ySize => ( .02 * $height ),
1208 xSize => $xsize_ratio,
1211 mode => 'graphic', # the only other option here is Type3...
1215 elsif ( $barcodetype eq 'COOP2OF5' ) {
1216 $bar_length = '9.43333333333333';
1218 ( $bar_length * $num_of_bars ) + ( $guard_length * 2 );
1219 $xsize_ratio = ( $bar_width / $tot_bar_length ) * .9;
1221 PDF::Reuse::Barcode::COOP2of5(
1222 x => ( $x_pos + ( $width / 10 ) ),
1223 y => ( $y_pos + ( $height / 10 ) ),
1225 ySize => ( .02 * $height ),
1226 xSize => $xsize_ratio,
1230 elsif ( $barcodetype eq 'INDUSTRIAL2OF5' ) {
1231 $bar_length = '13.1333333333333';
1233 ( $bar_length * $num_of_bars ) + ( $guard_length * 2 );
1234 $xsize_ratio = ( $bar_width / $tot_bar_length ) * .9;
1236 PDF::Reuse::Barcode::Industrial2of5(
1237 x => ( $x_pos + ( $width / 10 ) ),
1238 y => ( $y_pos + ( $height / 10 ) ),
1240 ySize => ( .02 * $height ),
1241 xSize => $xsize_ratio,
1244 } # else {die "Unknown barcodetype '$barcodetype'";}
1247 warn "DrawBarcode (type: $barcodetype) FAILED for value '$barcode' :$@";
1250 my $moo2 = $tot_bar_length * $xsize_ratio;
1252 warn "x_pos,y_pos,barcode,barcodetype = $x_pos, $y_pos, $barcode, $barcodetype\n"
1253 . "BAR_WDTH = $bar_width, TOT.BAR.LGHT=$tot_bar_length R*TOT.BAR =$moo2" if $debug;
1256 =head2 build_circ_barcode;
1258 build_circ_barcode( $x_pos, $y_pos, $barcode, $barcodetype, \$item);
1260 $item is the result of a previous call to GetLabelItems();
1264 sub build_circ_barcode {
1265 my ( $x_pos_circ, $y_pos, $value, $barcodetype, $item ) = @_;
1267 #warn Dumper \$item;
1268 #warn "Barcode (type: $barcodetype) value = $value\n";
1271 if ( $barcodetype eq 'EAN13' ) {
1272 #testing EAN13 barcodes hack
1273 $value = $value . '000000000';
1275 $value = substr( $value, 0, 12 );
1276 #warn "revised value: $value";
1278 PDF::Reuse::Barcode::EAN13(
1279 x => ( $x_pos_circ + 27 ),
1280 y => ( $y_pos + 15 ),
1285 # added for xpdf compat. doesnt use type3 fonts., but increases filesize from 20k to 200k
1286 # i think its embedding extra fonts in the pdf file.
1287 # mode => 'graphic',
1291 elsif ( $barcodetype eq 'Code39' ) {
1293 PDF::Reuse::Barcode::Code39(
1294 x => ( $x_pos_circ + 9 ),
1295 y => ( $y_pos + 15 ),
1300 mode => 'graphic', # the only other option here is Type3...
1304 elsif ( $barcodetype eq 'Matrix2of5' ) {
1305 # testing MATRIX25 barcodes hack
1306 # $value = $value.'000000000';
1308 # $value = substr( $value, 0, 12 );
1309 #warn "revised value: $value";
1311 PDF::Reuse::Barcode::Matrix2of5(
1312 x => ( $x_pos_circ + 27 ),
1313 y => ( $y_pos + 15 ),
1321 elsif ( $barcodetype eq 'EAN8' ) {
1322 #testing ean8 barcodes hack
1323 $value = $value . '000000000';
1325 $value = substr( $value, 0, 8 );
1326 #warn "revised value: $value";
1328 PDF::Reuse::Barcode::EAN8(
1329 x => ( $x_pos_circ + 42 ),
1330 y => ( $y_pos + 15 ),
1338 elsif ( $barcodetype eq 'UPC-E' ) {
1340 PDF::Reuse::Barcode::UPCE(
1341 x => ( $x_pos_circ + 27 ),
1342 y => ( $y_pos + 15 ),
1350 elsif ( $barcodetype eq 'NW7' ) {
1352 PDF::Reuse::Barcode::NW7(
1353 x => ( $x_pos_circ + 27 ),
1354 y => ( $y_pos + 15 ),
1362 elsif ( $barcodetype eq 'ITF' ) {
1364 PDF::Reuse::Barcode::ITF(
1365 x => ( $x_pos_circ + 27 ),
1366 y => ( $y_pos + 15 ),
1374 elsif ( $barcodetype eq 'Industrial2of5' ) {
1376 PDF::Reuse::Barcode::Industrial2of5(
1377 x => ( $x_pos_circ + 27 ),
1378 y => ( $y_pos + 15 ),
1386 elsif ( $barcodetype eq 'IATA2of5' ) {
1388 PDF::Reuse::Barcode::IATA2of5(
1389 x => ( $x_pos_circ + 27 ),
1390 y => ( $y_pos + 15 ),
1398 elsif ( $barcodetype eq 'COOP2of5' ) {
1400 PDF::Reuse::Barcode::COOP2of5(
1401 x => ( $x_pos_circ + 27 ),
1402 y => ( $y_pos + 15 ),
1410 elsif ( $barcodetype eq 'UPC-A' ) {
1412 PDF::Reuse::Barcode::UPCA(
1413 x => ( $x_pos_circ + 27 ),
1414 y => ( $y_pos + 15 ),
1423 $item->{'barcodeerror'} = 1;
1424 #warn "BARCODE (type: $barcodetype) FAILED:$@";
1428 =head2 draw_boundaries
1430 sub draw_boundaries ($x_pos_spine, $x_pos_circ1, $x_pos_circ2,
1431 $y_pos, $spine_width, $label_height, $circ_width)
1433 This sub draws boundary lines where the label outlines are, to aid in printer testing, and debugging.
1437 sub draw_boundaries {
1439 $x_pos_spine, $x_pos_circ1, $x_pos_circ2, $y_pos,
1440 $spine_width, $label_height, $circ_width
1443 my $y_pos_initial = ( ( 792 - 36 ) - 90 );
1444 $y_pos = $y_pos_initial; # FIXME - why are we ignoring the y_pos parameter by redefining it?
1447 for ( $i = 1 ; $i <= 8 ; $i++ ) {
1448 &drawbox( $x_pos_spine, $y_pos, ($spine_width), ($label_height) );
1449 #warn "OLD BOXES x=$x_pos_spine, y=$y_pos, w=$spine_width, h=$label_height";
1450 &drawbox( $x_pos_circ1, $y_pos, ($circ_width), ($label_height) );
1451 &drawbox( $x_pos_circ2, $y_pos, ($circ_width), ($label_height) );
1452 $y_pos = ( $y_pos - $label_height );
1458 sub drawbox { $lower_left_x, $lower_left_y,
1459 $upper_right_x, $upper_right_y )
1461 this is a low level sub, that draws a pdf box, it is called by draw_boxes
1463 FYI: the $upper_right_x and $upper_right_y values are RELATIVE to $lower_left_x and $lower_left_y
1465 and $lower_left_x, $lower_left_y are ABSOLUTE, this caught me out!
1470 my ( $llx, $lly, $urx, $ury ) = @_;
1471 # warn "llx,y= $llx,$lly , urx,y=$urx,$ury \n";
1473 my $str = "q\n"; # save the graphic state
1474 $str .= "0.5 w\n"; # border color red
1475 $str .= "1.0 0.0 0.0 RG\n"; # border color red
1476 # $str .= "0.5 0.75 1.0 rg\n"; # fill color blue
1477 $str .= "1.0 1.0 1.0 rg\n"; # fill color white
1479 $str .= "$llx $lly $urx $ury re\n"; # a rectangle
1480 $str .= "B\n"; # fill (and a little more)
1481 $str .= "Q\n"; # save the graphic state
1491 Mason James <mason@katipo.co.nz>